From 162925706d7d508ed9db45484f117e6eb228ede6 Mon Sep 17 00:00:00 2001 From: HarrisonGrodin Date: Sat, 16 Mar 2024 18:25:12 +0000 Subject: [PATCH] deploy: 10f1ba616e1ade017e4048324ae894281379ce08 --- Agda.Builtin.Char.Properties.html | 12 - Agda.Builtin.String.Properties.html | 13 - Algebra.Apartness.Bundles.html | 67 + Algebra.Apartness.Structures.html | 54 + Algebra.Apartness.html | 14 + Algebra.Bundles.Raw.html | 324 +- Algebra.Bundles.html | 2168 ++++---- Algebra.Consequences.Base.html | 29 +- Algebra.Consequences.Propositional.html | 281 +- Algebra.Consequences.Setoid.html | 728 +-- Algebra.Construct.LiftedChoice.html | 189 - Algebra.Construct.NaturalChoice.Base.html | 98 +- Algebra.Construct.NaturalChoice.Max.html | 49 - Algebra.Construct.NaturalChoice.MaxOp.html | 113 +- Algebra.Construct.NaturalChoice.Min.html | 55 - Algebra.Construct.NaturalChoice.MinMaxOp.html | 263 +- Algebra.Construct.NaturalChoice.MinOp.html | 486 +- Algebra.Cost.Bundles.html | 106 +- Algebra.Cost.Instances.html | 532 +- Algebra.Cost.Structures.html | 62 +- Algebra.Definitions.RawMagma.html | 95 +- Algebra.Definitions.RawMonoid.html | 6 +- Algebra.Definitions.RawSemiring.html | 18 +- Algebra.Definitions.html | 290 +- Algebra.Lattice.Bundles.Raw.html | 32 +- Algebra.Lattice.Bundles.html | 361 +- ...Lattice.Construct.NaturalChoice.MaxOp.html | 24 +- ...tice.Construct.NaturalChoice.MinMaxOp.html | 170 +- ...Lattice.Construct.NaturalChoice.MinOp.html | 40 +- ....Lattice.Morphism.LatticeMonomorphism.html | 212 +- Algebra.Lattice.Morphism.Structures.html | 157 +- ...bra.Lattice.Properties.BooleanAlgebra.html | 994 ++-- ...attice.Properties.DistributiveLattice.html | 24 +- Algebra.Lattice.Properties.Lattice.html | 340 +- Algebra.Lattice.Properties.Semilattice.html | 101 +- Algebra.Lattice.Structures.Biased.html | 212 +- Algebra.Lattice.Structures.html | 331 +- Algebra.Morphism.Definitions.html | 2 +- Algebra.Morphism.GroupMonomorphism.html | 142 +- Algebra.Morphism.MagmaMonomorphism.html | 196 +- Algebra.Morphism.MonoidMonomorphism.html | 140 +- Algebra.Morphism.RingMonomorphism.html | 275 +- Algebra.Morphism.Structures.html | 1285 ++--- Algebra.Morphism.html | 300 +- Algebra.Properties.AbelianGroup.html | 42 +- Algebra.Properties.CommutativeSemigroup.html | 242 +- Algebra.Properties.Group.html | 196 +- Algebra.Properties.Monoid.Mult.html | 132 +- Algebra.Properties.Ring.html | 87 +- Algebra.Properties.RingWithoutOne.html | 76 + Algebra.Properties.Semigroup.html | 30 +- Algebra.Properties.Semiring.Exp.html | 100 +- ...bra.Solver.Ring.AlmostCommutativeRing.html | 266 +- Algebra.Solver.Ring.Lemmas.html | 170 +- Algebra.Solver.Ring.Simple.html | 18 +- Algebra.Solver.Ring.html | 957 ++-- Algebra.Structures.Biased.html | 507 +- Algebra.Structures.html | 1705 +++--- Axiom.Extensionality.Propositional.html | 6 +- Axiom.UniquenessOfIdentityProofs.html | 36 +- Calf.CBPV.html | 6 +- Calf.Data.BigO.html | 18 +- Calf.Data.IsBounded.html | 50 +- Calf.Data.IsBoundedG.html | 38 +- Calf.Data.Maybe.html | 2 +- Calf.Data.Product.html | 4 +- Calf.Directed.html | 65 +- Calf.Parallel.html | 48 +- Calf.Phase.Closed.html | 8 +- Calf.Phase.Noninterference.html | 18 +- Calf.Phase.Open.html | 32 +- Calf.Step.html | 40 +- Calf.html | 4 +- Data.Bool.Base.html | 22 +- Data.Bool.Properties.html | 1424 ++--- Data.Bool.html | 19 +- Data.Char.Base.html | 20 +- Data.Char.Properties.html | 301 -- Data.Char.html | 18 - Data.Digit.html | 230 +- Data.Empty.html | 8 +- Data.Fin.Base.html | 475 +- Data.Fin.Patterns.html | 20 +- Data.Fin.Properties.html | 2242 ++++---- Data.Fin.html | 6 +- Data.Integer.Base.html | 487 +- Data.Integer.Coprimality.html | 33 +- Data.Integer.Divisibility.html | 90 +- Data.Integer.GCD.html | 68 +- Data.Integer.Properties.html | 4614 +++++++++-------- Data.Integer.Show.html | 6 +- Data.Integer.Solver.html | 4 +- Data.Integer.html | 30 +- Data.Interval.Base.html | 126 +- Data.List.Base.html | 887 ++-- Data.List.Effectful.html | 524 +- Data.List.Extrema.Core.html | 122 - Data.List.Extrema.html | 249 - Data.List.Membership.DecPropositional.html | 22 - Data.List.Membership.DecSetoid.html | 33 - ...bership.Propositional.Properties.Core.html | 142 +- ...t.Membership.Propositional.Properties.html | 611 +-- Data.List.Membership.Propositional.html | 31 +- Data.List.Membership.Setoid.Properties.html | 670 +-- Data.List.Membership.Setoid.html | 66 +- Data.List.NonEmpty.Base.html | 463 +- Data.List.NonEmpty.html | 56 - Data.List.Properties.html | 2366 +++++---- ...elation.Binary.Equality.Propositional.html | 31 +- ....List.Relation.Binary.Equality.Setoid.html | 212 +- Data.List.Relation.Binary.Lex.Core.html | 70 +- Data.List.Relation.Binary.Lex.Strict.html | 246 - Data.List.Relation.Binary.Lex.html | 117 - ....Permutation.Propositional.Properties.html | 669 +-- ...tion.Binary.Permutation.Propositional.html | 175 +- Data.List.Relation.Binary.Pointwise.Base.html | 100 +- ....Relation.Binary.Pointwise.Properties.html | 134 +- Data.List.Relation.Binary.Pointwise.html | 525 +- ...ion.Binary.Sublist.Heterogeneous.Core.html | 22 +- ...nary.Sublist.Heterogeneous.Properties.html | 1427 ++--- ...Relation.Binary.Sublist.Heterogeneous.html | 149 +- ...nary.Sublist.Propositional.Properties.html | 444 +- ...Relation.Binary.Sublist.Propositional.html | 273 +- ...tion.Binary.Sublist.Setoid.Properties.html | 438 +- Data.List.Relation.Binary.Sublist.Setoid.html | 515 +- ....Relation.Binary.Subset.Propositional.html | 8 +- Data.List.Relation.Binary.Subset.Setoid.html | 41 +- Data.List.Relation.Unary.All.Properties.html | 1430 ++--- Data.List.Relation.Unary.All.html | 333 +- Data.List.Relation.Unary.AllPairs.Core.html | 28 +- Data.List.Relation.Unary.AllPairs.html | 104 +- Data.List.Relation.Unary.Any.Properties.html | 1445 +++--- Data.List.Relation.Unary.Any.html | 148 +- Data.List.Relation.Unary.Unique.Setoid.html | 27 +- Data.Maybe.Base.html | 174 +- Data.Maybe.Effectful.html | 87 +- Data.Maybe.Relation.Unary.All.html | 150 +- Data.Maybe.Relation.Unary.Any.html | 90 +- Data.Maybe.html | 10 +- Data.Nat.Base.html | 595 ++- Data.Nat.Coprimality.html | 206 +- Data.Nat.DivMod.Core.html | 492 +- Data.Nat.DivMod.html | 914 ++-- Data.Nat.Divisibility.Core.html | 96 +- Data.Nat.Divisibility.html | 605 ++- Data.Nat.GCD.Lemmas.html | 330 +- Data.Nat.GCD.html | 671 ++- Data.Nat.GeneralisedArithmetic.html | 106 + Data.Nat.Induction.html | 199 +- Data.Nat.Log2.html | 66 +- Data.Nat.Logarithm.Core.html | 244 +- Data.Nat.Logarithm.html | 78 +- Data.Nat.PredExp2.html | 162 +- Data.Nat.Primality.html | 525 +- Data.Nat.Properties.html | 4268 +++++++-------- Data.Nat.Show.html | 110 +- Data.Nat.Solver.html | 2 +- Data.Nat.Square.html | 8 +- Data.Nat.html | 25 +- Data.Parity.Base.html | 176 +- Data.Product.Algebra.html | 338 +- Data.Product.Base.html | 260 +- ...duct.Function.Dependent.Propositional.html | 627 ++- ...t.Function.NonDependent.Propositional.html | 133 +- ....Product.Function.NonDependent.Setoid.html | 253 +- Data.Product.Properties.html | 151 +- ...elation.Binary.Pointwise.NonDependent.html | 428 +- Data.Product.Relation.Unary.All.html | 20 +- Data.Product.html | 36 +- Data.Rational.Base.html | 567 +- Data.Rational.Properties.html | 3319 ++++++------ Data.Rational.Unnormalised.Base.html | 633 +-- Data.Rational.Unnormalised.Properties.html | 3788 +++++++------- Data.Rational.html | 16 +- Data.Sign.Properties.html | 365 +- Data.Sign.html | 2 +- Data.String.Base.html | 261 +- Data.String.Properties.html | 173 - Data.String.html | 82 - Data.Sum.Algebra.html | 215 +- Data.Sum.Base.html | 8 +- Data.Sum.Function.Propositional.html | 129 +- Data.Sum.Function.Setoid.html | 304 +- Data.Sum.Properties.html | 266 +- Data.Sum.Relation.Binary.Pointwise.html | 429 +- Data.Sum.html | 16 +- Data.Unit.Polymorphic.Properties.html | 189 +- Data.Unit.Polymorphic.html | 2 +- Data.Unit.Properties.html | 150 +- Data.Unit.html | 2 +- Data.Vec.Base.html | 505 +- Data.Vec.Functional.html | 216 +- Data.Vec.N-ary.html | 343 +- Effect.Applicative.html | 180 +- Effect.Monad.html | 171 +- Examples.Amortized.Core.html | 2 +- Examples.Amortized.DynamicArray.html | 204 +- Examples.Amortized.Queue.html | 126 +- Examples.Amortized.Simple.html | 12 +- Examples.Decalf.Basic.html | 38 +- Examples.Decalf.GlobalState.html | 40 +- Examples.Decalf.HigherOrderFunction.html | 70 +- Examples.Decalf.Nondeterminism.html | 292 +- Examples.Decalf.ProbabilisticChoice.html | 90 +- Examples.Exp2.html | 96 +- Examples.Id.html | 30 +- Examples.Sorting.Comparable.html | 50 +- Examples.Sorting.Core.html | 76 +- Examples.Sorting.Sequential.Comparable.html | 4 +- Examples.Sorting.Sequential.Core.html | 4 +- ...ples.Sorting.Sequential.InsertionSort.html | 104 +- ...es.Sorting.Sequential.MergeSort.Merge.html | 84 +- ...es.Sorting.Sequential.MergeSort.Split.html | 34 +- Examples.Sorting.Sequential.MergeSort.html | 400 +- Examples.Sorting.Sequential.html | 12 +- Examples.TreeSum.html | 32 +- Function.Base.html | 266 +- Function.Bijection.html | 129 - Function.Bundles.html | 923 ++-- Function.Consequences.Propositional.html | 55 + Function.Consequences.Setoid.html | 94 + Function.Consequences.html | 138 +- Function.Construct.Composition.html | 523 +- Function.Construct.Identity.html | 472 +- Function.Construct.Symmetry.html | 444 +- Function.Definitions.Core1.html | 27 - Function.Definitions.Core2.html | 31 - Function.Definitions.html | 71 +- Function.Dependent.Bundles.html | 52 + Function.Equality.html | 126 - Function.Equivalence.html | 130 - Function.HalfAdjointEquivalence.html | 115 - ...tion.Indexed.Relation.Binary.Equality.html | 29 + Function.Injection.html | 80 - Function.Inverse.html | 196 - Function.LeftInverse.html | 132 - Function.Metric.Bundles.html | 245 +- Function.Metric.Definitions.html | 72 +- Function.Metric.Nat.Bundles.html | 246 +- Function.Metric.Nat.Definitions.html | 34 +- Function.Metric.Nat.Structures.html | 90 +- Function.Metric.Structures.html | 171 +- Function.Properties.Bijection.html | 131 +- ...erties.Inverse.HalfAdjointEquivalence.html | 123 + Function.Properties.Inverse.html | 250 +- Function.Properties.RightInverse.html | 109 +- Function.Properties.Surjection.html | 90 +- Function.Related.Propositional.html | 752 +-- Function.Related.TypeIsomorphisms.html | 638 ++- Function.Related.html | 453 -- Function.Structures.Biased.html | 129 + Function.Structures.html | 241 +- Function.Surjection.html | 133 - Function.html | 3 +- Induction.Lexicographic.html | 146 +- Induction.WellFounded.html | 352 +- Induction.html | 16 +- Relation.Binary.Bundles.html | 593 ++- Relation.Binary.Consequences.html | 536 +- ...onstruct.Closure.Reflexive.Properties.html | 144 - ...on.Binary.Construct.Closure.Reflexive.html | 22 +- Relation.Binary.Construct.Constant.Core.html | 4 +- Relation.Binary.Construct.Converse.html | 197 - Relation.Binary.Construct.Flip.EqAndOrd.html | 202 + Relation.Binary.Construct.Intersection.html | 238 +- ...on.Binary.Construct.NaturalOrder.Left.html | 356 +- ...on.Binary.Construct.NonStrictToStrict.html | 277 +- Relation.Binary.Construct.On.html | 221 - Relation.Binary.Construct.Subst.Equality.html | 44 - Relation.Binary.Core.html | 74 +- Relation.Binary.Definitions.html | 309 +- ....Binary.Indexed.Heterogeneous.Bundles.html | 73 +- ...dexed.Heterogeneous.Construct.Trivial.html | 94 +- ...ion.Binary.Indexed.Heterogeneous.Core.html | 2 +- ...ary.Indexed.Heterogeneous.Definitions.html | 6 +- ...nary.Indexed.Heterogeneous.Structures.html | 40 +- Relation.Binary.Lattice.Bundles.html | 423 +- Relation.Binary.Lattice.Definitions.html | 36 +- Relation.Binary.Lattice.Structures.html | 348 +- Relation.Binary.Morphism.Bundles.html | 68 +- Relation.Binary.Morphism.Definitions.html | 2 +- ...ion.Binary.Morphism.OrderMonomorphism.html | 191 +- Relation.Binary.Morphism.RelMonomorphism.html | 79 +- Relation.Binary.Morphism.Structures.html | 214 +- ...n.Binary.Properties.ApartnessRelation.html | 31 + Relation.Binary.Properties.DecTotalOrder.html | 175 +- Relation.Binary.Properties.Poset.html | 234 +- Relation.Binary.Properties.Preorder.html | 78 +- Relation.Binary.Properties.Setoid.html | 172 +- Relation.Binary.Properties.TotalOrder.html | 186 +- ....Binary.PropositionalEquality.Algebra.html | 10 +- ...ion.Binary.PropositionalEquality.Core.html | 144 +- ...nary.PropositionalEquality.Properties.html | 362 +- Relation.Binary.PropositionalEquality.html | 239 +- Relation.Binary.Reasoning.Base.Double.html | 148 +- Relation.Binary.Reasoning.Base.Single.html | 100 +- Relation.Binary.Reasoning.Base.Triple.html | 255 +- Relation.Binary.Reasoning.Preorder.html | 20 +- Relation.Binary.Reasoning.Setoid.html | 38 +- Relation.Binary.Reasoning.Syntax.html | 446 ++ Relation.Binary.Reflection.html | 188 +- Relation.Binary.Structures.Biased.html | 51 + Relation.Binary.Structures.html | 446 +- Relation.Binary.html | 3 +- Relation.Nullary.Decidable.Core.html | 259 +- Relation.Nullary.Decidable.html | 148 +- Relation.Nullary.Negation.Core.html | 129 +- Relation.Nullary.Negation.html | 207 +- Relation.Nullary.Reflects.html | 175 +- Relation.Nullary.html | 29 +- Relation.Unary.Properties.html | 320 +- Relation.Unary.html | 394 +- 312 files changed, 43197 insertions(+), 43695 deletions(-) delete mode 100644 Agda.Builtin.Char.Properties.html delete mode 100644 Agda.Builtin.String.Properties.html create mode 100644 Algebra.Apartness.Bundles.html create mode 100644 Algebra.Apartness.Structures.html create mode 100644 Algebra.Apartness.html delete mode 100644 Algebra.Construct.LiftedChoice.html delete mode 100644 Algebra.Construct.NaturalChoice.Max.html delete mode 100644 Algebra.Construct.NaturalChoice.Min.html create mode 100644 Algebra.Properties.RingWithoutOne.html delete mode 100644 Data.Char.Properties.html delete mode 100644 Data.Char.html delete mode 100644 Data.List.Extrema.Core.html delete mode 100644 Data.List.Extrema.html delete mode 100644 Data.List.Membership.DecPropositional.html delete mode 100644 Data.List.Membership.DecSetoid.html delete mode 100644 Data.List.NonEmpty.html delete mode 100644 Data.List.Relation.Binary.Lex.Strict.html delete mode 100644 Data.List.Relation.Binary.Lex.html create mode 100644 Data.Nat.GeneralisedArithmetic.html delete mode 100644 Data.String.Properties.html delete mode 100644 Data.String.html delete mode 100644 Function.Bijection.html create mode 100644 Function.Consequences.Propositional.html create mode 100644 Function.Consequences.Setoid.html delete mode 100644 Function.Definitions.Core1.html delete mode 100644 Function.Definitions.Core2.html create mode 100644 Function.Dependent.Bundles.html delete mode 100644 Function.Equality.html delete mode 100644 Function.Equivalence.html delete mode 100644 Function.HalfAdjointEquivalence.html create mode 100644 Function.Indexed.Relation.Binary.Equality.html delete mode 100644 Function.Injection.html delete mode 100644 Function.Inverse.html delete mode 100644 Function.LeftInverse.html create mode 100644 Function.Properties.Inverse.HalfAdjointEquivalence.html delete mode 100644 Function.Related.html create mode 100644 Function.Structures.Biased.html delete mode 100644 Function.Surjection.html delete mode 100644 Relation.Binary.Construct.Closure.Reflexive.Properties.html delete mode 100644 Relation.Binary.Construct.Converse.html create mode 100644 Relation.Binary.Construct.Flip.EqAndOrd.html delete mode 100644 Relation.Binary.Construct.On.html delete mode 100644 Relation.Binary.Construct.Subst.Equality.html create mode 100644 Relation.Binary.Properties.ApartnessRelation.html create mode 100644 Relation.Binary.Reasoning.Syntax.html create mode 100644 Relation.Binary.Structures.Biased.html diff --git a/Agda.Builtin.Char.Properties.html b/Agda.Builtin.Char.Properties.html deleted file mode 100644 index 524b4460..00000000 --- a/Agda.Builtin.Char.Properties.html +++ /dev/null @@ -1,12 +0,0 @@ - -Agda.Builtin.Char.Properties
{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}
-
-module Agda.Builtin.Char.Properties where
-
-open import Agda.Builtin.Char
-open import Agda.Builtin.Equality
-
-primitive
-
-  primCharToNatInjective : ∀ a b → primCharToNat a ≡ primCharToNat b → a ≡ b
-
\ No newline at end of file diff --git a/Agda.Builtin.String.Properties.html b/Agda.Builtin.String.Properties.html deleted file mode 100644 index dd6a0564..00000000 --- a/Agda.Builtin.String.Properties.html +++ /dev/null @@ -1,13 +0,0 @@ - -Agda.Builtin.String.Properties
{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}
-
-module Agda.Builtin.String.Properties where
-
-open import Agda.Builtin.String
-open import Agda.Builtin.Equality
-
-primitive
-
-  primStringToListInjective : ∀ a b → primStringToList a ≡ primStringToList b → a ≡ b
-  primStringFromListInjective : ∀ a b → primStringFromList a ≡ primStringFromList b → a ≡ b
-
\ No newline at end of file diff --git a/Algebra.Apartness.Bundles.html b/Algebra.Apartness.Bundles.html new file mode 100644 index 00000000..eb29c0ec --- /dev/null +++ b/Algebra.Apartness.Bundles.html @@ -0,0 +1,67 @@ + +Algebra.Apartness.Bundles
------------------------------------------------------------------------
+-- The Agda standard library
+--
+-- Bundles for local algebraic structures
+------------------------------------------------------------------------
+
+{-# OPTIONS --cubical-compatible --safe #-}
+
+module Algebra.Apartness.Bundles where
+
+open import Level using (_⊔_; suc)
+open import Relation.Binary.Core using (Rel)
+open import Relation.Binary.Bundles using (ApartnessRelation)
+open import Algebra.Core using (Op₁; Op₂)
+open import Algebra.Bundles using (CommutativeRing)
+open import Algebra.Apartness.Structures
+
+record HeytingCommutativeRing c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where
+  infix  8 -_
+  infixl 7 _*_
+  infixl 6 _+_
+  infix  4 _≈_ _#_
+  field
+    Carrier                  : Set c
+    _≈_                      : Rel Carrier ℓ₁
+    _#_                      : Rel Carrier ℓ₂
+    _+_                      : Op₂ Carrier
+    _*_                      : Op₂ Carrier
+    -_                       : Op₁ Carrier
+    0#                       : Carrier
+    1#                       : Carrier
+    isHeytingCommutativeRing : IsHeytingCommutativeRing _≈_ _#_ _+_ _*_ -_ 0# 1#
+
+  open IsHeytingCommutativeRing isHeytingCommutativeRing public
+
+  commutativeRing : CommutativeRing c ℓ₁
+  commutativeRing = record { isCommutativeRing = isCommutativeRing }
+
+  apartnessRelation : ApartnessRelation c ℓ₁ ℓ₂
+  apartnessRelation = record { isApartnessRelation = isApartnessRelation }
+
+
+record HeytingField c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where
+  infix  8 -_
+  infixl 7 _*_
+  infixl 6 _+_
+  infix  4 _≈_ _#_
+  field
+    Carrier        : Set c
+    _≈_            : Rel Carrier ℓ₁
+    _#_            : Rel Carrier ℓ₂
+    _+_            : Op₂ Carrier
+    _*_            : Op₂ Carrier
+    -_             : Op₁ Carrier
+    0#             : Carrier
+    1#             : Carrier
+    isHeytingField : IsHeytingField _≈_ _#_ _+_ _*_ -_ 0# 1#
+
+  open IsHeytingField isHeytingField public
+
+  heytingCommutativeRing : HeytingCommutativeRing c ℓ₁ ℓ₂
+  heytingCommutativeRing = record { isHeytingCommutativeRing = isHeytingCommutativeRing }
+
+  apartnessRelation : ApartnessRelation c ℓ₁ ℓ₂
+  apartnessRelation = record { isApartnessRelation = isApartnessRelation }
+
\ No newline at end of file diff --git a/Algebra.Apartness.Structures.html b/Algebra.Apartness.Structures.html new file mode 100644 index 00000000..6870ff80 --- /dev/null +++ b/Algebra.Apartness.Structures.html @@ -0,0 +1,54 @@ + +Algebra.Apartness.Structures
------------------------------------------------------------------------
+-- The Agda standard library
+--
+-- Algebraic structures with an apartness relation
+------------------------------------------------------------------------
+
+{-# OPTIONS --cubical-compatible --safe #-}
+
+open import Algebra.Core using (Op₁; Op₂)
+open import Relation.Binary.Core using (Rel)
+
+module Algebra.Apartness.Structures
+  {c ℓ₁ ℓ₂} {Carrier : Set c}
+  (_≈_ : Rel Carrier ℓ₁)
+  (_#_ : Rel Carrier ℓ₂)
+  (_+_ _*_ : Op₂ Carrier) (-_ : Op₁ Carrier) (0# 1# : Carrier)
+  where
+
+open import Level using (_⊔_; suc)
+open import Data.Product.Base using (∃-syntax; _×_; _,_; proj₂)
+open import Algebra.Definitions _≈_ using (Invertible)
+open import Algebra.Structures _≈_ using (IsCommutativeRing)
+open import Relation.Binary.Structures using (IsEquivalence; IsApartnessRelation)
+open import Relation.Binary.Definitions using (Tight)
+open import Relation.Nullary.Negation using (¬_)
+import Relation.Binary.Properties.ApartnessRelation as AR
+
+
+record IsHeytingCommutativeRing : Set (c ⊔ ℓ₁ ⊔ ℓ₂) where
+
+  field
+    isCommutativeRing   : IsCommutativeRing _+_ _*_ -_ 0# 1#
+    isApartnessRelation : IsApartnessRelation _≈_ _#_
+
+  open IsCommutativeRing isCommutativeRing public
+  open IsApartnessRelation isApartnessRelation public
+
+  field
+    #⇒invertible : ∀ {x y} → x # y → Invertible 1# _*_ (x - y)
+    invertible⇒# : ∀ {x y} → Invertible 1# _*_ (x - y) → x # y
+
+  ¬#-isEquivalence : IsEquivalence _¬#_
+  ¬#-isEquivalence = AR.¬#-isEquivalence refl isApartnessRelation
+
+
+record IsHeytingField : Set (c ⊔ ℓ₁ ⊔ ℓ₂) where
+
+  field
+    isHeytingCommutativeRing : IsHeytingCommutativeRing
+    tight                    : Tight _≈_ _#_
+
+  open IsHeytingCommutativeRing isHeytingCommutativeRing public
+
\ No newline at end of file diff --git a/Algebra.Apartness.html b/Algebra.Apartness.html new file mode 100644 index 00000000..5eed7157 --- /dev/null +++ b/Algebra.Apartness.html @@ -0,0 +1,14 @@ + +Algebra.Apartness
------------------------------------------------------------------------
+-- The Agda standard library
+--
+-- Algebraic objects with an apartness relation
+------------------------------------------------------------------------
+
+{-# OPTIONS --cubical-compatible --safe #-}
+
+module Algebra.Apartness where
+
+open import Algebra.Apartness.Structures public
+open import Algebra.Apartness.Bundles public
+
\ No newline at end of file diff --git a/Algebra.Bundles.Raw.html b/Algebra.Bundles.Raw.html index ed5fdb11..ddbbba22 100644 --- a/Algebra.Bundles.Raw.html +++ b/Algebra.Bundles.Raw.html @@ -10,9 +10,9 @@ module Algebra.Bundles.Raw where open import Algebra.Core -open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Core using (Rel) open import Level using (suc; _⊔_) -open import Relation.Nullary.Negation.Core using (¬_) +open import Relation.Nullary.Negation.Core using (¬_) ------------------------------------------------------------------------ -- Raw bundles with 1 binary operation @@ -23,12 +23,12 @@ infix 4 _≈_ field Carrier : Set c - _≈_ : Rel Carrier ℓ + _≈_ : Rel Carrier ℓ _∙_ : Op₂ Carrier infix 4 _≉_ - _≉_ : Rel Carrier _ - x ≉ y = ¬ (x ≈ y) + _≉_ : Rel Carrier _ + x ≉ y = ¬ (x ≈ y) ------------------------------------------------------------------------ -- Raw bundles with 1 binary operation & 1 element @@ -41,7 +41,7 @@ infix 4 _≈_ field Carrier : Set c - _≈_ : Rel Carrier ℓ + _≈_ : Rel Carrier ℓ _∙_ : Op₂ Carrier ε : Carrier @@ -64,7 +64,7 @@ infix 4 _≈_ field Carrier : Set c - _≈_ : Rel Carrier ℓ + _≈_ : Rel Carrier ℓ _∙_ : Op₂ Carrier ε : Carrier _⁻¹ : Op₁ Carrier @@ -89,7 +89,7 @@ infix 4 _≈_ field Carrier : Set c - _≈_ : Rel Carrier ℓ + _≈_ : Rel Carrier ℓ _+_ : Op₂ Carrier _*_ : Op₂ Carrier 0# : Carrier @@ -120,7 +120,7 @@ infix 4 _≈_ field Carrier : Set c - _≈_ : Rel Carrier ℓ + _≈_ : Rel Carrier ℓ _+_ : Op₂ Carrier _*_ : Op₂ Carrier 0# : Carrier @@ -149,141 +149,175 @@ ------------------------------------------------------------------------ record RawRingWithoutOne c ℓ : Set (suc (c ⊔ ℓ)) where - infix 8 -_ - infixl 7 _*_ - infixl 6 _+_ - infix 4 _≈_ + infix 8 -_ + infixl 7 _*_ + infixl 6 _+_ + infix 4 _≈_ field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _+_ : Op₂ Carrier - _*_ : Op₂ Carrier - -_ : Op₁ Carrier - 0# : Carrier - - +-rawGroup : RawGroup c ℓ - +-rawGroup = record - { _≈_ = _≈_ - ; _∙_ = _+_ - ; ε = 0# - ; _⁻¹ = -_ - } - - open RawGroup +-rawGroup public - using (_≉_) renaming (rawMagma to +-rawMagma; rawMonoid to +-rawMonoid) - - *-rawMagma : RawMagma c ℓ - *-rawMagma = record - { _≈_ = _≈_ - ; _∙_ = _*_ - } - ------------------------------------------------------------------------- --- Raw bundles with 2 binary operations, 1 unary operation & 2 elements ------------------------------------------------------------------------- - --- A raw ring is a ring without any laws. - -record RawRing c ℓ : Set (suc (c ⊔ ℓ)) where - infix 8 -_ - infixl 7 _*_ - infixl 6 _+_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _+_ : Op₂ Carrier - _*_ : Op₂ Carrier - -_ : Op₁ Carrier - 0# : Carrier - 1# : Carrier - - rawSemiring : RawSemiring c ℓ - rawSemiring = record - { _≈_ = _≈_ - ; _+_ = _+_ - ; _*_ = _*_ - ; 0# = 0# - ; 1# = 1# - } - - open RawSemiring rawSemiring public - using - ( _≉_ - ; +-rawMagma; +-rawMonoid - ; *-rawMagma; *-rawMonoid - ) - - +-rawGroup : RawGroup c ℓ - +-rawGroup = record - { _≈_ = _≈_ - ; _∙_ = _+_ - ; ε = 0# - ; _⁻¹ = -_ - } - ------------------------------------------------------------------------- --- Raw bundles with 3 binary operations ------------------------------------------------------------------------- - -record RawQuasigroup c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infixl 7 _\\_ - infixl 7 _//_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - _\\_ : Op₂ Carrier - _//_ : Op₂ Carrier - - ∙-rawMagma : RawMagma c ℓ - ∙-rawMagma = record - { _≈_ = _≈_ - ; _∙_ = _∙_ - } - - \\-rawMagma : RawMagma c ℓ - \\-rawMagma = record - { _≈_ = _≈_ - ; _∙_ = _\\_ - } - - //-rawMagma : RawMagma c ℓ - //-rawMagma = record - { _≈_ = _≈_ - ; _∙_ = _//_ - } - - open RawMagma \\-rawMagma public - using (_≉_) - ------------------------------------------------------------------------- --- Raw bundles with 3 binary operations & 1 element ------------------------------------------------------------------------- - -record RawLoop c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infixl 7 _\\_ - infixl 7 _//_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - _\\_ : Op₂ Carrier - _//_ : Op₂ Carrier - ε : Carrier - - rawQuasigroup : RawQuasigroup c ℓ - rawQuasigroup = record - { _≈_ = _≈_ - ; _∙_ = _∙_ - ; _\\_ = _\\_ - ; _//_ = _//_ - } - - open RawQuasigroup rawQuasigroup public - using (_≉_ ; ∙-rawMagma; \\-rawMagma; //-rawMagma) + Carrier : Set c + _≈_ : Rel Carrier ℓ + _+_ : Op₂ Carrier + _*_ : Op₂ Carrier + -_ : Op₁ Carrier + 0# : Carrier + + +-rawGroup : RawGroup c ℓ + +-rawGroup = record + { _≈_ = _≈_ + ; _∙_ = _+_ + ; ε = 0# + ; _⁻¹ = -_ + } + + open RawGroup +-rawGroup public + using (_≉_) renaming (rawMagma to +-rawMagma; rawMonoid to +-rawMonoid) + + *-rawMagma : RawMagma c ℓ + *-rawMagma = record + { _≈_ = _≈_ + ; _∙_ = _*_ + } + +------------------------------------------------------------------------ +-- Raw bundles with 2 binary operations, 1 unary operation & 2 elements +------------------------------------------------------------------------ + +-- A raw ring is a ring without any laws. + +record RawRing c ℓ : Set (suc (c ⊔ ℓ)) where + infix 8 -_ + infixl 7 _*_ + infixl 6 _+_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _+_ : Op₂ Carrier + _*_ : Op₂ Carrier + -_ : Op₁ Carrier + 0# : Carrier + 1# : Carrier + + rawSemiring : RawSemiring c ℓ + rawSemiring = record + { _≈_ = _≈_ + ; _+_ = _+_ + ; _*_ = _*_ + ; 0# = 0# + ; 1# = 1# + } + + open RawSemiring rawSemiring public + using + ( _≉_ + ; +-rawMagma; +-rawMonoid + ; *-rawMagma; *-rawMonoid + ) + + rawRingWithoutOne : RawRingWithoutOne c ℓ + rawRingWithoutOne = record + { _≈_ = _≈_ + ; _+_ = _+_ + ; _*_ = _*_ + ; -_ = -_ + ; 0# = 0# + } + + open RawRingWithoutOne rawRingWithoutOne public + using (+-rawGroup) + +------------------------------------------------------------------------ +-- Raw bundles with 3 binary operations +------------------------------------------------------------------------ + +record RawQuasigroup c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infixl 7 _\\_ + infixl 7 _//_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + _\\_ : Op₂ Carrier + _//_ : Op₂ Carrier + + ∙-rawMagma : RawMagma c ℓ + ∙-rawMagma = record + { _≈_ = _≈_ + ; _∙_ = _∙_ + } + + \\-rawMagma : RawMagma c ℓ + \\-rawMagma = record + { _≈_ = _≈_ + ; _∙_ = _\\_ + } + + //-rawMagma : RawMagma c ℓ + //-rawMagma = record + { _≈_ = _≈_ + ; _∙_ = _//_ + } + + open RawMagma \\-rawMagma public + using (_≉_) + +------------------------------------------------------------------------ +-- Raw bundles with 3 binary operations & 1 element +------------------------------------------------------------------------ + +record RawLoop c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infixl 7 _\\_ + infixl 7 _//_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + _\\_ : Op₂ Carrier + _//_ : Op₂ Carrier + ε : Carrier + + rawQuasigroup : RawQuasigroup c ℓ + rawQuasigroup = record + { _≈_ = _≈_ + ; _∙_ = _∙_ + ; _\\_ = _\\_ + ; _//_ = _//_ + } + + open RawQuasigroup rawQuasigroup public + using (_≉_ ; ∙-rawMagma; \\-rawMagma; //-rawMagma) + +record RawKleeneAlgebra c ℓ : Set (suc (c ⊔ ℓ)) where + infix 8 _⋆ + infixl 7 _*_ + infixl 6 _+_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _+_ : Op₂ Carrier + _*_ : Op₂ Carrier + _⋆ : Op₁ Carrier + 0# : Carrier + 1# : Carrier + + rawSemiring : RawSemiring c ℓ + rawSemiring = record + { _≈_ = _≈_ + ; _+_ = _+_ + ; _*_ = _*_ + ; 0# = 0# + ; 1# = 1# + } + + open RawSemiring rawSemiring public + using + ( _≉_ + ; +-rawMagma; +-rawMonoid + ; *-rawMagma; *-rawMonoid + ) \ No newline at end of file diff --git a/Algebra.Bundles.html b/Algebra.Bundles.html index 9a7f486a..b315fec4 100644 --- a/Algebra.Bundles.html +++ b/Algebra.Bundles.html @@ -15,1148 +15,1158 @@ import Algebra.Bundles.Raw as Raw open import Algebra.Core open import Algebra.Structures -open import Relation.Binary -open import Function.Base -import Relation.Nullary as N -open import Level +open import Relation.Binary.Core using (Rel) +open import Function.Base +import Relation.Nullary as N +open import Level ------------------------------------------------------------------------- --- Re-export definitions of 'raw' bundles - -open Raw public - using (RawMagma; RawMonoid; RawGroup - ; RawNearSemiring; RawSemiring - ; RawRingWithoutOne; RawRing - ; RawQuasigroup; RawLoop) +------------------------------------------------------------------------ +-- Re-export definitions of 'raw' bundles + +open Raw public + using (RawMagma; RawMonoid; RawGroup + ; RawNearSemiring; RawSemiring + ; RawRingWithoutOne; RawRing + ; RawQuasigroup; RawLoop; RawKleeneAlgebra) ------------------------------------------------------------------------- --- Bundles with 1 binary operation ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Bundles with 1 binary operation +------------------------------------------------------------------------ -record Magma c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - isMagma : IsMagma _≈_ _∙_ - - open IsMagma isMagma public - - rawMagma : RawMagma _ _ - rawMagma = record { _≈_ = _≈_; _∙_ = _∙_ } - - open RawMagma rawMagma public - using (_≉_) +record Magma c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + isMagma : IsMagma _≈_ _∙_ + + open IsMagma isMagma public + + rawMagma : RawMagma _ _ + rawMagma = record { _≈_ = _≈_; _∙_ = _∙_ } + + open RawMagma rawMagma public + using (_≉_) -record SelectiveMagma c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - isSelectiveMagma : IsSelectiveMagma _≈_ _∙_ - - open IsSelectiveMagma isSelectiveMagma public - - magma : Magma c ℓ - magma = record { isMagma = isMagma } - - open Magma magma public using (rawMagma) - - -record CommutativeMagma c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - isCommutativeMagma : IsCommutativeMagma _≈_ _∙_ - - open IsCommutativeMagma isCommutativeMagma public - - magma : Magma c ℓ - magma = record { isMagma = isMagma } - - open Magma magma public using (rawMagma) +record SelectiveMagma c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + isSelectiveMagma : IsSelectiveMagma _≈_ _∙_ + + open IsSelectiveMagma isSelectiveMagma public + + magma : Magma c ℓ + magma = record { isMagma = isMagma } + + open Magma magma public using (rawMagma) + + +record CommutativeMagma c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + isCommutativeMagma : IsCommutativeMagma _≈_ _∙_ + + open IsCommutativeMagma isCommutativeMagma public + + magma : Magma c ℓ + magma = record { isMagma = isMagma } + + open Magma magma public using (rawMagma) -record IdempotentMagma c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - isIdempotentMagma : IsIdempotentMagma _≈_ _∙_ +record IdempotentMagma c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + isIdempotentMagma : IsIdempotentMagma _≈_ _∙_ - open IsIdempotentMagma isIdempotentMagma public - - magma : Magma c ℓ - magma = record { isMagma = isMagma } + open IsIdempotentMagma isIdempotentMagma public + + magma : Magma c ℓ + magma = record { isMagma = isMagma } - open Magma magma public - using (rawMagma) + open Magma magma public + using (rawMagma) -record AlternativeMagma c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - isAlternativeMagma : IsAlternativeMagma _≈_ _∙_ +record AlternativeMagma c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + isAlternativeMagma : IsAlternativeMagma _≈_ _∙_ - open IsAlternativeMagma isAlternativeMagma public + open IsAlternativeMagma isAlternativeMagma public - magma : Magma c ℓ - magma = record { isMagma = isMagma } + magma : Magma c ℓ + magma = record { isMagma = isMagma } - open Magma magma public - using (rawMagma) + open Magma magma public + using (rawMagma) -record FlexibleMagma c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - isFlexibleMagma : IsFlexibleMagma _≈_ _∙_ +record FlexibleMagma c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + isFlexibleMagma : IsFlexibleMagma _≈_ _∙_ - open IsFlexibleMagma isFlexibleMagma public + open IsFlexibleMagma isFlexibleMagma public - magma : Magma c ℓ - magma = record { isMagma = isMagma } + magma : Magma c ℓ + magma = record { isMagma = isMagma } - open Magma magma public - using (rawMagma) + open Magma magma public + using (rawMagma) -record MedialMagma c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - isMedialMagma : IsMedialMagma _≈_ _∙_ +record MedialMagma c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + isMedialMagma : IsMedialMagma _≈_ _∙_ - open IsMedialMagma isMedialMagma public + open IsMedialMagma isMedialMagma public - magma : Magma c ℓ - magma = record { isMagma = isMagma } + magma : Magma c ℓ + magma = record { isMagma = isMagma } - open Magma magma public - using (rawMagma) + open Magma magma public + using (rawMagma) -record SemimedialMagma c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - isSemimedialMagma : IsSemimedialMagma _≈_ _∙_ +record SemimedialMagma c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + isSemimedialMagma : IsSemimedialMagma _≈_ _∙_ - open IsSemimedialMagma isSemimedialMagma public + open IsSemimedialMagma isSemimedialMagma public - magma : Magma c ℓ - magma = record { isMagma = isMagma } + magma : Magma c ℓ + magma = record { isMagma = isMagma } - open Magma magma public - using (rawMagma) + open Magma magma public + using (rawMagma) -record Semigroup c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - isSemigroup : IsSemigroup _≈_ _∙_ +record Semigroup c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + isSemigroup : IsSemigroup _≈_ _∙_ - open IsSemigroup isSemigroup public + open IsSemigroup isSemigroup public - magma : Magma c ℓ - magma = record { isMagma = isMagma } + magma : Magma c ℓ + magma = record { isMagma = isMagma } - open Magma magma public - using (_≉_; rawMagma) + open Magma magma public + using (_≉_; rawMagma) -record Band c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - isBand : IsBand _≈_ _∙_ +record Band c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + isBand : IsBand _≈_ _∙_ - open IsBand isBand public + open IsBand isBand public - semigroup : Semigroup c ℓ - semigroup = record { isSemigroup = isSemigroup } + semigroup : Semigroup c ℓ + semigroup = record { isSemigroup = isSemigroup } - open Semigroup semigroup public - using (_≉_; magma; rawMagma) + open Semigroup semigroup public + using (_≉_; magma; rawMagma) -record CommutativeSemigroup c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - isCommutativeSemigroup : IsCommutativeSemigroup _≈_ _∙_ +record CommutativeSemigroup c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + isCommutativeSemigroup : IsCommutativeSemigroup _≈_ _∙_ - open IsCommutativeSemigroup isCommutativeSemigroup public + open IsCommutativeSemigroup isCommutativeSemigroup public - semigroup : Semigroup c ℓ - semigroup = record { isSemigroup = isSemigroup } + semigroup : Semigroup c ℓ + semigroup = record { isSemigroup = isSemigroup } - open Semigroup semigroup public - using (_≉_; magma; rawMagma) + open Semigroup semigroup public + using (_≉_; magma; rawMagma) - commutativeMagma : CommutativeMagma c ℓ - commutativeMagma = record { isCommutativeMagma = isCommutativeMagma } + commutativeMagma : CommutativeMagma c ℓ + commutativeMagma = record { isCommutativeMagma = isCommutativeMagma } ------------------------------------------------------------------------- --- Bundles with 1 binary operation & 1 element ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Bundles with 1 binary operation & 1 element +------------------------------------------------------------------------ -record UnitalMagma c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - ε : Carrier - isUnitalMagma : IsUnitalMagma _≈_ _∙_ ε +record UnitalMagma c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + ε : Carrier + isUnitalMagma : IsUnitalMagma _≈_ _∙_ ε - open IsUnitalMagma isUnitalMagma public + open IsUnitalMagma isUnitalMagma public - magma : Magma c ℓ - magma = record { isMagma = isMagma } + magma : Magma c ℓ + magma = record { isMagma = isMagma } - open Magma magma public - using (_≉_; rawMagma) + open Magma magma public + using (_≉_; rawMagma) -record Monoid c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - ε : Carrier - isMonoid : IsMonoid _≈_ _∙_ ε +record Monoid c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + ε : Carrier + isMonoid : IsMonoid _≈_ _∙_ ε - open IsMonoid isMonoid public + open IsMonoid isMonoid public - semigroup : Semigroup _ _ - semigroup = record { isSemigroup = isSemigroup } + semigroup : Semigroup _ _ + semigroup = record { isSemigroup = isSemigroup } - open Semigroup semigroup public - using (_≉_; rawMagma; magma) + open Semigroup semigroup public + using (_≉_; rawMagma; magma) - rawMonoid : RawMonoid _ _ - rawMonoid = record { _≈_ = _≈_; _∙_ = _∙_; ε = ε} + rawMonoid : RawMonoid _ _ + rawMonoid = record { _≈_ = _≈_; _∙_ = _∙_; ε = ε} - unitalMagma : UnitalMagma _ _ - unitalMagma = record { isUnitalMagma = isUnitalMagma } + unitalMagma : UnitalMagma _ _ + unitalMagma = record { isUnitalMagma = isUnitalMagma } -record CommutativeMonoid c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - ε : Carrier - isCommutativeMonoid : IsCommutativeMonoid _≈_ _∙_ ε +record CommutativeMonoid c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + ε : Carrier + isCommutativeMonoid : IsCommutativeMonoid _≈_ _∙_ ε - open IsCommutativeMonoid isCommutativeMonoid public + open IsCommutativeMonoid isCommutativeMonoid public - monoid : Monoid _ _ - monoid = record { isMonoid = isMonoid } + monoid : Monoid _ _ + monoid = record { isMonoid = isMonoid } - open Monoid monoid public - using (_≉_; rawMagma; magma; semigroup; unitalMagma; rawMonoid) + open Monoid monoid public + using (_≉_; rawMagma; magma; semigroup; unitalMagma; rawMonoid) - commutativeSemigroup : CommutativeSemigroup _ _ - commutativeSemigroup = record { isCommutativeSemigroup = isCommutativeSemigroup } + commutativeSemigroup : CommutativeSemigroup _ _ + commutativeSemigroup = record { isCommutativeSemigroup = isCommutativeSemigroup } - open CommutativeSemigroup commutativeSemigroup public - using (commutativeMagma) + open CommutativeSemigroup commutativeSemigroup public + using (commutativeMagma) -record IdempotentCommutativeMonoid c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - ε : Carrier - isIdempotentCommutativeMonoid : IsIdempotentCommutativeMonoid _≈_ _∙_ ε +record IdempotentCommutativeMonoid c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + ε : Carrier + isIdempotentCommutativeMonoid : IsIdempotentCommutativeMonoid _≈_ _∙_ ε - open IsIdempotentCommutativeMonoid isIdempotentCommutativeMonoid public + open IsIdempotentCommutativeMonoid isIdempotentCommutativeMonoid public - commutativeMonoid : CommutativeMonoid _ _ - commutativeMonoid = record { isCommutativeMonoid = isCommutativeMonoid } + commutativeMonoid : CommutativeMonoid _ _ + commutativeMonoid = record { isCommutativeMonoid = isCommutativeMonoid } - open CommutativeMonoid commutativeMonoid public - using - ( _≉_; rawMagma; magma; unitalMagma; commutativeMagma - ; semigroup; commutativeSemigroup - ; rawMonoid; monoid - ) - - --- Idempotent commutative monoids are also known as bounded lattices. --- Note that the BoundedLattice necessarily uses the notation inherited --- from monoids rather than lattices. - -BoundedLattice = IdempotentCommutativeMonoid - -module BoundedLattice {c ℓ} (idemCommMonoid : IdempotentCommutativeMonoid c ℓ) = - IdempotentCommutativeMonoid idemCommMonoid - - ------------------------------------------------------------------------- --- Bundles with 1 binary operation, 1 unary operation & 1 element ------------------------------------------------------------------------- + open CommutativeMonoid commutativeMonoid public + using + ( _≉_; rawMagma; magma; unitalMagma; commutativeMagma + ; semigroup; commutativeSemigroup + ; rawMonoid; monoid + ) + + +-- Idempotent commutative monoids are also known as bounded lattices. +-- Note that the BoundedLattice necessarily uses the notation inherited +-- from monoids rather than lattices. + +BoundedLattice = IdempotentCommutativeMonoid + +module BoundedLattice {c ℓ} (idemCommMonoid : IdempotentCommutativeMonoid c ℓ) = + IdempotentCommutativeMonoid idemCommMonoid + + +------------------------------------------------------------------------ +-- Bundles with 1 binary operation, 1 unary operation & 1 element +------------------------------------------------------------------------ + +record InvertibleMagma c ℓ : Set (suc (c ⊔ ℓ)) where + infix 8 _⁻¹ + infixl 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + ε : Carrier + _⁻¹ : Op₁ Carrier + isInvertibleMagma : IsInvertibleMagma _≈_ _∙_ ε _⁻¹ + + open IsInvertibleMagma isInvertibleMagma public + + magma : Magma _ _ + magma = record { isMagma = isMagma } + + open Magma magma public + using (_≉_; rawMagma) + + +record InvertibleUnitalMagma c ℓ : Set (suc (c ⊔ ℓ)) where + infix 8 _⁻¹ + infixl 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + ε : Carrier + _⁻¹ : Op₁ Carrier + isInvertibleUnitalMagma : IsInvertibleUnitalMagma _≈_ _∙_ ε _⁻¹ + + open IsInvertibleUnitalMagma isInvertibleUnitalMagma public + + invertibleMagma : InvertibleMagma _ _ + invertibleMagma = record { isInvertibleMagma = isInvertibleMagma } + + open InvertibleMagma invertibleMagma public + using (_≉_; rawMagma; magma) + +record Group c ℓ : Set (suc (c ⊔ ℓ)) where + infix 8 _⁻¹ + infixl 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + ε : Carrier + _⁻¹ : Op₁ Carrier + isGroup : IsGroup _≈_ _∙_ ε _⁻¹ + + open IsGroup isGroup public + + rawGroup : RawGroup _ _ + rawGroup = record { _≈_ = _≈_; _∙_ = _∙_; ε = ε; _⁻¹ = _⁻¹} + + monoid : Monoid _ _ + monoid = record { isMonoid = isMonoid } + + open Monoid monoid public + using (_≉_; rawMagma; magma; semigroup; unitalMagma; rawMonoid) + + invertibleMagma : InvertibleMagma c ℓ + invertibleMagma = record + { isInvertibleMagma = isInvertibleMagma + } + + invertibleUnitalMagma : InvertibleUnitalMagma c ℓ + invertibleUnitalMagma = record + { isInvertibleUnitalMagma = isInvertibleUnitalMagma + } + +record AbelianGroup c ℓ : Set (suc (c ⊔ ℓ)) where + infix 8 _⁻¹ + infixl 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + ε : Carrier + _⁻¹ : Op₁ Carrier + isAbelianGroup : IsAbelianGroup _≈_ _∙_ ε _⁻¹ + + open IsAbelianGroup isAbelianGroup public + + group : Group _ _ + group = record { isGroup = isGroup } + + open Group group public using + (_≉_; rawMagma; magma; semigroup + ; rawMonoid; monoid; rawGroup; invertibleMagma; invertibleUnitalMagma + ) + + commutativeMonoid : CommutativeMonoid _ _ + commutativeMonoid = record { isCommutativeMonoid = isCommutativeMonoid } + + open CommutativeMonoid commutativeMonoid public + using (commutativeMagma; commutativeSemigroup) + +------------------------------------------------------------------------ +-- Bundles with 2 binary operations & 1 element +------------------------------------------------------------------------ + +record NearSemiring c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _*_ + infixl 6 _+_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _+_ : Op₂ Carrier + _*_ : Op₂ Carrier + 0# : Carrier + isNearSemiring : IsNearSemiring _≈_ _+_ _*_ 0# + + open IsNearSemiring isNearSemiring public + + rawNearSemiring : RawNearSemiring _ _ + rawNearSemiring = record + { _≈_ = _≈_ + ; _+_ = _+_ + ; _*_ = _*_ + ; 0# = 0# + } + + +-monoid : Monoid _ _ + +-monoid = record { isMonoid = +-isMonoid } + + open Monoid +-monoid public + using (_≉_) renaming + ( rawMagma to +-rawMagma + ; magma to +-magma + ; semigroup to +-semigroup + ; unitalMagma to +-unitalMagma + ; rawMonoid to +-rawMonoid + ) + + *-semigroup : Semigroup _ _ + *-semigroup = record { isSemigroup = *-isSemigroup } + + open Semigroup *-semigroup public + using () renaming + ( rawMagma to *-rawMagma + ; magma to *-magma + ) + + +record SemiringWithoutOne c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _*_ + infixl 6 _+_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _+_ : Op₂ Carrier + _*_ : Op₂ Carrier + 0# : Carrier + isSemiringWithoutOne : IsSemiringWithoutOne _≈_ _+_ _*_ 0# + + open IsSemiringWithoutOne isSemiringWithoutOne public + + nearSemiring : NearSemiring _ _ + nearSemiring = record { isNearSemiring = isNearSemiring } + + open NearSemiring nearSemiring public + using + ( +-rawMagma; +-magma; +-unitalMagma; +-semigroup + ; +-rawMonoid; +-monoid + ; *-rawMagma; *-magma; *-semigroup + ; rawNearSemiring + ) + + +-commutativeMonoid : CommutativeMonoid _ _ + +-commutativeMonoid = record { isCommutativeMonoid = +-isCommutativeMonoid } + + open CommutativeMonoid +-commutativeMonoid public + using () renaming + ( commutativeMagma to +-commutativeMagma + ; commutativeSemigroup to +-commutativeSemigroup + ) + + +record CommutativeSemiringWithoutOne c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _*_ + infixl 6 _+_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _+_ : Op₂ Carrier + _*_ : Op₂ Carrier + 0# : Carrier + isCommutativeSemiringWithoutOne : + IsCommutativeSemiringWithoutOne _≈_ _+_ _*_ 0# + + open IsCommutativeSemiringWithoutOne + isCommutativeSemiringWithoutOne public + + semiringWithoutOne : SemiringWithoutOne _ _ + semiringWithoutOne = + record { isSemiringWithoutOne = isSemiringWithoutOne } + + open SemiringWithoutOne semiringWithoutOne public + using + ( +-rawMagma; +-magma; +-unitalMagma; +-semigroup; +-commutativeSemigroup + ; *-rawMagma; *-magma; *-semigroup + ; +-rawMonoid; +-monoid; +-commutativeMonoid + ; nearSemiring; rawNearSemiring + ) + +------------------------------------------------------------------------ +-- Bundles with 2 binary operations & 2 elements +------------------------------------------------------------------------ + +record SemiringWithoutAnnihilatingZero c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _*_ + infixl 6 _+_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _+_ : Op₂ Carrier + _*_ : Op₂ Carrier + 0# : Carrier + 1# : Carrier + isSemiringWithoutAnnihilatingZero : + IsSemiringWithoutAnnihilatingZero _≈_ _+_ _*_ 0# 1# + + open IsSemiringWithoutAnnihilatingZero + isSemiringWithoutAnnihilatingZero public + + rawSemiring : RawSemiring c ℓ + rawSemiring = record + { _≈_ = _≈_ + ; _+_ = _+_ + ; _*_ = _*_ + ; 0# = 0# + ; 1# = 1# + } + + open RawSemiring rawSemiring public + using (rawNearSemiring) + + +-commutativeMonoid : CommutativeMonoid _ _ + +-commutativeMonoid = + record { isCommutativeMonoid = +-isCommutativeMonoid } + + open CommutativeMonoid +-commutativeMonoid public + using (_≉_) renaming + ( rawMagma to +-rawMagma + ; magma to +-magma + ; unitalMagma to +-unitalMagma + ; commutativeMagma to +-commutativeMagma + ; semigroup to +-semigroup + ; commutativeSemigroup to +-commutativeSemigroup + ; rawMonoid to +-rawMonoid + ; monoid to +-monoid + ) + + *-monoid : Monoid _ _ + *-monoid = record { isMonoid = *-isMonoid } + + open Monoid *-monoid public + using () renaming + ( rawMagma to *-rawMagma + ; magma to *-magma + ; semigroup to *-semigroup + ; rawMonoid to *-rawMonoid + ) + + +record Semiring c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _*_ + infixl 6 _+_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _+_ : Op₂ Carrier + _*_ : Op₂ Carrier + 0# : Carrier + 1# : Carrier + isSemiring : IsSemiring _≈_ _+_ _*_ 0# 1# + + open IsSemiring isSemiring public + + semiringWithoutAnnihilatingZero : SemiringWithoutAnnihilatingZero _ _ + semiringWithoutAnnihilatingZero = record + { isSemiringWithoutAnnihilatingZero = + isSemiringWithoutAnnihilatingZero + } + + open SemiringWithoutAnnihilatingZero + semiringWithoutAnnihilatingZero public + using + ( _≉_; +-rawMagma; +-magma; +-unitalMagma; +-commutativeMagma + ; +-semigroup; +-commutativeSemigroup + ; *-rawMagma; *-magma; *-semigroup + ; +-rawMonoid; +-monoid; +-commutativeMonoid + ; *-rawMonoid; *-monoid + ; rawNearSemiring ; rawSemiring + ) + + semiringWithoutOne : SemiringWithoutOne _ _ + semiringWithoutOne = + record { isSemiringWithoutOne = isSemiringWithoutOne } + + open SemiringWithoutOne semiringWithoutOne public + using (nearSemiring) + + +record CommutativeSemiring c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _*_ + infixl 6 _+_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _+_ : Op₂ Carrier + _*_ : Op₂ Carrier + 0# : Carrier + 1# : Carrier + isCommutativeSemiring : IsCommutativeSemiring _≈_ _+_ _*_ 0# 1# + + open IsCommutativeSemiring isCommutativeSemiring public + + semiring : Semiring _ _ + semiring = record { isSemiring = isSemiring } + + open Semiring semiring public + using + ( _≉_; +-rawMagma; +-magma; +-unitalMagma; +-commutativeMagma + ; +-semigroup; +-commutativeSemigroup + ; *-rawMagma; *-magma; *-semigroup + ; +-rawMonoid; +-monoid; +-commutativeMonoid + ; *-rawMonoid; *-monoid + ; nearSemiring; semiringWithoutOne + ; semiringWithoutAnnihilatingZero + ; rawSemiring + ) + + *-commutativeMonoid : CommutativeMonoid _ _ + *-commutativeMonoid = record + { isCommutativeMonoid = *-isCommutativeMonoid + } + + open CommutativeMonoid *-commutativeMonoid public + using () renaming + ( commutativeMagma to *-commutativeMagma + ; commutativeSemigroup to *-commutativeSemigroup + ) + + commutativeSemiringWithoutOne : CommutativeSemiringWithoutOne _ _ + commutativeSemiringWithoutOne = record + { isCommutativeSemiringWithoutOne = isCommutativeSemiringWithoutOne + } + + +record CancellativeCommutativeSemiring c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _*_ + infixl 6 _+_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _+_ : Op₂ Carrier + _*_ : Op₂ Carrier + 0# : Carrier + 1# : Carrier + isCancellativeCommutativeSemiring : IsCancellativeCommutativeSemiring _≈_ _+_ _*_ 0# 1# + + open IsCancellativeCommutativeSemiring isCancellativeCommutativeSemiring public + + commutativeSemiring : CommutativeSemiring c ℓ + commutativeSemiring = record + { isCommutativeSemiring = isCommutativeSemiring + } + + open CommutativeSemiring commutativeSemiring public + using + ( +-rawMagma; +-magma; +-unitalMagma; +-commutativeMagma + ; +-semigroup; +-commutativeSemigroup + ; *-rawMagma; *-magma; *-commutativeMagma; *-semigroup; *-commutativeSemigroup + ; +-rawMonoid; +-monoid; +-commutativeMonoid + ; *-rawMonoid; *-monoid; *-commutativeMonoid + ; nearSemiring; semiringWithoutOne + ; semiringWithoutAnnihilatingZero + ; rawSemiring + ; semiring + ; _≉_ + ) + +record IdempotentSemiring c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _*_ + infixl 6 _+_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _+_ : Op₂ Carrier + _*_ : Op₂ Carrier + 0# : Carrier + 1# : Carrier + isIdempotentSemiring : IsIdempotentSemiring _≈_ _+_ _*_ 0# 1# + + open IsIdempotentSemiring isIdempotentSemiring public + + semiring : Semiring _ _ + semiring = record { isSemiring = isSemiring } + + open Semiring semiring public + using + ( _≉_; +-rawMagma; +-magma; +-unitalMagma; +-commutativeMagma + ; +-semigroup; +-commutativeSemigroup + ; *-rawMagma; *-magma; *-semigroup + ; +-rawMonoid; +-monoid; +-commutativeMonoid + ; *-rawMonoid; *-monoid + ; nearSemiring; semiringWithoutOne + ; semiringWithoutAnnihilatingZero + ; rawSemiring + ) + +record KleeneAlgebra c ℓ : Set (suc (c ⊔ ℓ)) where + infix 8 _⋆ + infixl 7 _*_ + infixl 6 _+_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _+_ : Op₂ Carrier + _*_ : Op₂ Carrier + _⋆ : Op₁ Carrier + 0# : Carrier + 1# : Carrier + isKleeneAlgebra : IsKleeneAlgebra _≈_ _+_ _*_ _⋆ 0# 1# + + open IsKleeneAlgebra isKleeneAlgebra public + + idempotentSemiring : IdempotentSemiring _ _ + idempotentSemiring = record { isIdempotentSemiring = isIdempotentSemiring } + + open IdempotentSemiring idempotentSemiring public + using + ( _≉_; +-rawMagma; +-magma; +-unitalMagma; +-commutativeMagma + ; +-semigroup; +-commutativeSemigroup + ; *-rawMagma; *-magma; *-semigroup + ; +-rawMonoid; +-monoid; +-commutativeMonoid + ; *-rawMonoid; *-monoid + ; nearSemiring; semiringWithoutOne + ; semiringWithoutAnnihilatingZero + ; rawSemiring; semiring + ) + +record Quasiring c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _*_ + infixl 6 _+_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _+_ : Op₂ Carrier + _*_ : Op₂ Carrier + 0# : Carrier + 1# : Carrier + isQuasiring : IsQuasiring _≈_ _+_ _*_ 0# 1# + + open IsQuasiring isQuasiring public + + +-monoid : Monoid _ _ + +-monoid = record { isMonoid = +-isMonoid } + + open Monoid +-monoid public + using (_≉_) renaming + ( rawMagma to +-rawMagma + ; magma to +-magma + ; semigroup to +-semigroup + ; unitalMagma to +-unitalMagma + ; rawMonoid to +-rawMonoid + ) + + *-monoid : Monoid _ _ + *-monoid = record { isMonoid = *-isMonoid } + + open Monoid *-monoid public + using () renaming + ( rawMagma to *-rawMagma + ; magma to *-magma + ; semigroup to *-semigroup + ; rawMonoid to *-rawMonoid + ) + +------------------------------------------------------------------------ +-- Bundles with 2 binary operations, 1 unary operation & 1 element +------------------------------------------------------------------------ + +record RingWithoutOne c ℓ : Set (suc (c ⊔ ℓ)) where + infix 8 -_ + infixl 7 _*_ + infixl 6 _+_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _+_ : Op₂ Carrier + _*_ : Op₂ Carrier + -_ : Op₁ Carrier + 0# : Carrier + isRingWithoutOne : IsRingWithoutOne _≈_ _+_ _*_ -_ 0# + + open IsRingWithoutOne isRingWithoutOne public + + +-abelianGroup : AbelianGroup _ _ + +-abelianGroup = record { isAbelianGroup = +-isAbelianGroup } + + *-semigroup : Semigroup _ _ + *-semigroup = record { isSemigroup = *-isSemigroup } + + open AbelianGroup +-abelianGroup public + using () renaming (group to +-group; invertibleMagma to +-invertibleMagma; invertibleUnitalMagma to +-invertibleUnitalMagma) + + open Semigroup *-semigroup public + using () renaming + ( rawMagma to *-rawMagma + ; magma to *-magma + ) + +------------------------------------------------------------------------ +-- Bundles with 2 binary operations, 1 unary operation & 2 elements +------------------------------------------------------------------------ + +record NonAssociativeRing c ℓ : Set (suc (c ⊔ ℓ)) where + infix 8 -_ + infixl 7 _*_ + infixl 6 _+_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _+_ : Op₂ Carrier + _*_ : Op₂ Carrier + -_ : Op₁ Carrier + 0# : Carrier + 1# : Carrier + isNonAssociativeRing : IsNonAssociativeRing _≈_ _+_ _*_ -_ 0# 1# + + open IsNonAssociativeRing isNonAssociativeRing public + + +-abelianGroup : AbelianGroup _ _ + +-abelianGroup = record { isAbelianGroup = +-isAbelianGroup } + + open AbelianGroup +-abelianGroup public + using () renaming (group to +-group; invertibleMagma to +-invertibleMagma; invertibleUnitalMagma to +-invertibleUnitalMagma) + + *-unitalMagma : UnitalMagma _ _ + *-unitalMagma = record { isUnitalMagma = *-isUnitalMagma} + + open UnitalMagma *-unitalMagma public + using () renaming (magma to *-magma; identity to *-identity) + +record Nearring c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _*_ + infixl 6 _+_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _+_ : Op₂ Carrier + _*_ : Op₂ Carrier + -_ : Op₁ Carrier + 0# : Carrier + 1# : Carrier + isNearring : IsNearring _≈_ _+_ _*_ 0# 1# -_ + + open IsNearring isNearring public + + quasiring : Quasiring _ _ + quasiring = record { isQuasiring = isQuasiring } + + open Quasiring quasiring public + using + (_≉_; +-rawMagma; +-magma; +-unitalMagma; +-semigroup; +-monoid; +-rawMonoid + ;*-rawMagma; *-magma; *-semigroup; *-monoid + ) + + +record Ring c ℓ : Set (suc (c ⊔ ℓ)) where + infix 8 -_ + infixl 7 _*_ + infixl 6 _+_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _+_ : Op₂ Carrier + _*_ : Op₂ Carrier + -_ : Op₁ Carrier + 0# : Carrier + 1# : Carrier + isRing : IsRing _≈_ _+_ _*_ -_ 0# 1# + + open IsRing isRing public + + +-abelianGroup : AbelianGroup _ _ + +-abelianGroup = record { isAbelianGroup = +-isAbelianGroup } + + ringWithoutOne : RingWithoutOne _ _ + ringWithoutOne = record { isRingWithoutOne = isRingWithoutOne } + + semiring : Semiring _ _ + semiring = record { isSemiring = isSemiring } + + open Semiring semiring public + using + ( _≉_; +-rawMagma; +-magma; +-unitalMagma; +-commutativeMagma + ; +-semigroup; +-commutativeSemigroup + ; *-rawMagma; *-magma; *-semigroup + ; +-rawMonoid; +-monoid ; +-commutativeMonoid + ; *-rawMonoid; *-monoid + ; nearSemiring; semiringWithoutOne + ; semiringWithoutAnnihilatingZero + ) + + open AbelianGroup +-abelianGroup public + using () renaming (group to +-group; invertibleMagma to +-invertibleMagma; invertibleUnitalMagma to +-invertibleUnitalMagma) + + rawRing : RawRing _ _ + rawRing = record + { _≈_ = _≈_ + ; _+_ = _+_ + ; _*_ = _*_ + ; -_ = -_ + ; 0# = 0# + ; 1# = 1# + } + + +record CommutativeRing c ℓ : Set (suc (c ⊔ ℓ)) where + infix 8 -_ + infixl 7 _*_ + infixl 6 _+_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _+_ : Op₂ Carrier + _*_ : Op₂ Carrier + -_ : Op₁ Carrier + 0# : Carrier + 1# : Carrier + isCommutativeRing : IsCommutativeRing _≈_ _+_ _*_ -_ 0# 1# + + open IsCommutativeRing isCommutativeRing public + + ring : Ring _ _ + ring = record { isRing = isRing } + + open Ring ring public using (_≉_; rawRing; +-invertibleMagma; +-invertibleUnitalMagma; +-group; +-abelianGroup) + + commutativeSemiring : CommutativeSemiring _ _ + commutativeSemiring = + record { isCommutativeSemiring = isCommutativeSemiring } + + open CommutativeSemiring commutativeSemiring public + using + ( +-rawMagma; +-magma; +-unitalMagma; +-commutativeMagma + ; +-semigroup; +-commutativeSemigroup + ; *-rawMagma; *-magma; *-commutativeMagma; *-semigroup; *-commutativeSemigroup + ; +-rawMonoid; +-monoid; +-commutativeMonoid + ; *-rawMonoid; *-monoid; *-commutativeMonoid + ; nearSemiring; semiringWithoutOne + ; semiringWithoutAnnihilatingZero; semiring + ; commutativeSemiringWithoutOne + ) + +------------------------------------------------------------------------ +-- Bundles with 3 binary operations +------------------------------------------------------------------------ + +record Quasigroup c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infixl 7 _\\_ + infixl 7 _//_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + _\\_ : Op₂ Carrier + _//_ : Op₂ Carrier + isQuasigroup : IsQuasigroup _≈_ _∙_ _\\_ _//_ + + open IsQuasigroup isQuasigroup public + + magma : Magma c ℓ + magma = record { isMagma = isMagma } + + open Magma magma public + using (_≉_; rawMagma) + + rawQuasigroup : RawQuasigroup c ℓ + rawQuasigroup = record + { _≈_ = _≈_ + ; _∙_ = _∙_ + ; _\\_ = _\\_ + ; _//_ = _//_ + } + + open RawQuasigroup rawQuasigroup public + using (//-rawMagma; \\-rawMagma; ∙-rawMagma) + +record Loop c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infixl 7 _\\_ + infixl 7 _//_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + _\\_ : Op₂ Carrier + _//_ : Op₂ Carrier + ε : Carrier + isLoop : IsLoop _≈_ _∙_ _\\_ _//_ ε + + open IsLoop isLoop public + + rawLoop : RawLoop c ℓ + rawLoop = record + { _≈_ = _≈_ + ; _∙_ = _∙_ + ; _\\_ = _\\_ + ; _//_ = _//_ + ; ε = ε + } + + quasigroup : Quasigroup _ _ + quasigroup = record { isQuasigroup = isQuasigroup } + + open Quasigroup quasigroup public + using (_≉_; ∙-rawMagma; \\-rawMagma; //-rawMagma) + +record LeftBolLoop c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infixl 7 _\\_ + infixl 7 _//_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + _\\_ : Op₂ Carrier + _//_ : Op₂ Carrier + ε : Carrier + isLeftBolLoop : IsLeftBolLoop _≈_ _∙_ _\\_ _//_ ε + + open IsLeftBolLoop isLeftBolLoop public + + loop : Loop _ _ + loop = record { isLoop = isLoop } + + open Loop loop public + using (quasigroup) + +record RightBolLoop c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infixl 7 _\\_ + infixl 7 _//_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + _\\_ : Op₂ Carrier + _//_ : Op₂ Carrier + ε : Carrier + isRightBolLoop : IsRightBolLoop _≈_ _∙_ _\\_ _//_ ε + + open IsRightBolLoop isRightBolLoop public + + loop : Loop _ _ + loop = record { isLoop = isLoop } + + open Loop loop public + using (quasigroup) + +record MoufangLoop c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infixl 7 _\\_ + infixl 7 _//_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + _\\_ : Op₂ Carrier + _//_ : Op₂ Carrier + ε : Carrier + isMoufangLoop : IsMoufangLoop _≈_ _∙_ _\\_ _//_ ε + + open IsMoufangLoop isMoufangLoop public + + leftBolLoop : LeftBolLoop _ _ + leftBolLoop = record { isLeftBolLoop = isLeftBolLoop } + + open LeftBolLoop leftBolLoop public + using (loop) + +record MiddleBolLoop c ℓ : Set (suc (c ⊔ ℓ)) where + infixl 7 _∙_ + infixl 7 _\\_ + infixl 7 _//_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + _\\_ : Op₂ Carrier + _//_ : Op₂ Carrier + ε : Carrier + isMiddleBolLoop : IsMiddleBolLoop _≈_ _∙_ _\\_ _//_ ε + + open IsMiddleBolLoop isMiddleBolLoop public + + loop : Loop _ _ + loop = record { isLoop = isLoop } + + open Loop loop public + using (quasigroup) -record InvertibleMagma c ℓ : Set (suc (c ⊔ ℓ)) where - infix 8 _⁻¹ - infixl 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - ε : Carrier - _⁻¹ : Op₁ Carrier - isInvertibleMagma : IsInvertibleMagma _≈_ _∙_ ε _⁻¹ - - open IsInvertibleMagma isInvertibleMagma public - - magma : Magma _ _ - magma = record { isMagma = isMagma } - - open Magma magma public - using (_≉_; rawMagma) - - -record InvertibleUnitalMagma c ℓ : Set (suc (c ⊔ ℓ)) where - infix 8 _⁻¹ - infixl 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - ε : Carrier - _⁻¹ : Op₁ Carrier - isInvertibleUnitalMagma : IsInvertibleUnitalMagma _≈_ _∙_ ε _⁻¹ - - open IsInvertibleUnitalMagma isInvertibleUnitalMagma public - - invertibleMagma : InvertibleMagma _ _ - invertibleMagma = record { isInvertibleMagma = isInvertibleMagma } - - open InvertibleMagma invertibleMagma public - using (_≉_; rawMagma; magma) - -record Group c ℓ : Set (suc (c ⊔ ℓ)) where - infix 8 _⁻¹ - infixl 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - ε : Carrier - _⁻¹ : Op₁ Carrier - isGroup : IsGroup _≈_ _∙_ ε _⁻¹ - - open IsGroup isGroup public - - rawGroup : RawGroup _ _ - rawGroup = record { _≈_ = _≈_; _∙_ = _∙_; ε = ε; _⁻¹ = _⁻¹} - - monoid : Monoid _ _ - monoid = record { isMonoid = isMonoid } - - open Monoid monoid public - using (_≉_; rawMagma; magma; semigroup; unitalMagma; rawMonoid) - - invertibleMagma : InvertibleMagma c ℓ - invertibleMagma = record - { isInvertibleMagma = isInvertibleMagma - } - - invertibleUnitalMagma : InvertibleUnitalMagma c ℓ - invertibleUnitalMagma = record - { isInvertibleUnitalMagma = isInvertibleUnitalMagma - } - -record AbelianGroup c ℓ : Set (suc (c ⊔ ℓ)) where - infix 8 _⁻¹ - infixl 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - ε : Carrier - _⁻¹ : Op₁ Carrier - isAbelianGroup : IsAbelianGroup _≈_ _∙_ ε _⁻¹ - - open IsAbelianGroup isAbelianGroup public - - group : Group _ _ - group = record { isGroup = isGroup } - - open Group group public using - (_≉_; rawMagma; magma; semigroup - ; rawMonoid; monoid; rawGroup; invertibleMagma; invertibleUnitalMagma - ) - - commutativeMonoid : CommutativeMonoid _ _ - commutativeMonoid = record { isCommutativeMonoid = isCommutativeMonoid } - - open CommutativeMonoid commutativeMonoid public - using (commutativeMagma; commutativeSemigroup) - ------------------------------------------------------------------------- --- Bundles with 2 binary operations & 1 element ------------------------------------------------------------------------- - -record NearSemiring c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _*_ - infixl 6 _+_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _+_ : Op₂ Carrier - _*_ : Op₂ Carrier - 0# : Carrier - isNearSemiring : IsNearSemiring _≈_ _+_ _*_ 0# - - open IsNearSemiring isNearSemiring public - - rawNearSemiring : RawNearSemiring _ _ - rawNearSemiring = record - { _≈_ = _≈_ - ; _+_ = _+_ - ; _*_ = _*_ - ; 0# = 0# - } - - +-monoid : Monoid _ _ - +-monoid = record { isMonoid = +-isMonoid } - - open Monoid +-monoid public - using (_≉_) renaming - ( rawMagma to +-rawMagma - ; magma to +-magma - ; semigroup to +-semigroup - ; unitalMagma to +-unitalMagma - ; rawMonoid to +-rawMonoid - ) - - *-semigroup : Semigroup _ _ - *-semigroup = record { isSemigroup = *-isSemigroup } - - open Semigroup *-semigroup public - using () renaming - ( rawMagma to *-rawMagma - ; magma to *-magma - ) - - -record SemiringWithoutOne c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _*_ - infixl 6 _+_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _+_ : Op₂ Carrier - _*_ : Op₂ Carrier - 0# : Carrier - isSemiringWithoutOne : IsSemiringWithoutOne _≈_ _+_ _*_ 0# - - open IsSemiringWithoutOne isSemiringWithoutOne public - - nearSemiring : NearSemiring _ _ - nearSemiring = record { isNearSemiring = isNearSemiring } - - open NearSemiring nearSemiring public - using - ( _≉_; +-rawMagma; +-magma; +-unitalMagma; +-semigroup - ; +-rawMonoid; +-monoid - ; *-rawMagma; *-magma; *-semigroup - ; rawNearSemiring - ) - - +-commutativeMonoid : CommutativeMonoid _ _ - +-commutativeMonoid = record { isCommutativeMonoid = +-isCommutativeMonoid } - - open CommutativeMonoid +-commutativeMonoid public - using () renaming - ( commutativeMagma to +-commutativeMagma - ; commutativeSemigroup to +-commutativeSemigroup - ) - - -record CommutativeSemiringWithoutOne c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _*_ - infixl 6 _+_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _+_ : Op₂ Carrier - _*_ : Op₂ Carrier - 0# : Carrier - isCommutativeSemiringWithoutOne : - IsCommutativeSemiringWithoutOne _≈_ _+_ _*_ 0# - - open IsCommutativeSemiringWithoutOne - isCommutativeSemiringWithoutOne public - - semiringWithoutOne : SemiringWithoutOne _ _ - semiringWithoutOne = - record { isSemiringWithoutOne = isSemiringWithoutOne } - - open SemiringWithoutOne semiringWithoutOne public - using - ( _≉_; +-rawMagma; +-magma; +-unitalMagma; +-semigroup; +-commutativeSemigroup - ; *-rawMagma; *-magma; *-semigroup - ; +-rawMonoid; +-monoid; +-commutativeMonoid - ; nearSemiring; rawNearSemiring - ) - ------------------------------------------------------------------------- --- Bundles with 2 binary operations & 2 elements ------------------------------------------------------------------------- - -record SemiringWithoutAnnihilatingZero c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _*_ - infixl 6 _+_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _+_ : Op₂ Carrier - _*_ : Op₂ Carrier - 0# : Carrier - 1# : Carrier - isSemiringWithoutAnnihilatingZero : - IsSemiringWithoutAnnihilatingZero _≈_ _+_ _*_ 0# 1# - - open IsSemiringWithoutAnnihilatingZero - isSemiringWithoutAnnihilatingZero public - - rawSemiring : RawSemiring c ℓ - rawSemiring = record - { _≈_ = _≈_ - ; _+_ = _+_ - ; _*_ = _*_ - ; 0# = 0# - ; 1# = 1# - } - - open RawSemiring rawSemiring public - using (rawNearSemiring) - - +-commutativeMonoid : CommutativeMonoid _ _ - +-commutativeMonoid = - record { isCommutativeMonoid = +-isCommutativeMonoid } - - open CommutativeMonoid +-commutativeMonoid public - using (_≉_) renaming - ( rawMagma to +-rawMagma - ; magma to +-magma - ; unitalMagma to +-unitalMagma - ; commutativeMagma to +-commutativeMagma - ; semigroup to +-semigroup - ; commutativeSemigroup to +-commutativeSemigroup - ; rawMonoid to +-rawMonoid - ; monoid to +-monoid - ) - - *-monoid : Monoid _ _ - *-monoid = record { isMonoid = *-isMonoid } - - open Monoid *-monoid public - using () renaming - ( rawMagma to *-rawMagma - ; magma to *-magma - ; semigroup to *-semigroup - ; rawMonoid to *-rawMonoid - ) - - -record Semiring c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _*_ - infixl 6 _+_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _+_ : Op₂ Carrier - _*_ : Op₂ Carrier - 0# : Carrier - 1# : Carrier - isSemiring : IsSemiring _≈_ _+_ _*_ 0# 1# - - open IsSemiring isSemiring public - - semiringWithoutAnnihilatingZero : SemiringWithoutAnnihilatingZero _ _ - semiringWithoutAnnihilatingZero = record - { isSemiringWithoutAnnihilatingZero = - isSemiringWithoutAnnihilatingZero - } - - open SemiringWithoutAnnihilatingZero - semiringWithoutAnnihilatingZero public - using - ( _≉_; +-rawMagma; +-magma; +-unitalMagma; +-commutativeMagma - ; +-semigroup; +-commutativeSemigroup - ; *-rawMagma; *-magma; *-semigroup - ; +-rawMonoid; +-monoid; +-commutativeMonoid - ; *-rawMonoid; *-monoid - ; rawNearSemiring ; rawSemiring - ) - - semiringWithoutOne : SemiringWithoutOne _ _ - semiringWithoutOne = - record { isSemiringWithoutOne = isSemiringWithoutOne } - - open SemiringWithoutOne semiringWithoutOne public - using (nearSemiring) - - -record CommutativeSemiring c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _*_ - infixl 6 _+_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _+_ : Op₂ Carrier - _*_ : Op₂ Carrier - 0# : Carrier - 1# : Carrier - isCommutativeSemiring : IsCommutativeSemiring _≈_ _+_ _*_ 0# 1# - - open IsCommutativeSemiring isCommutativeSemiring public - - semiring : Semiring _ _ - semiring = record { isSemiring = isSemiring } - - open Semiring semiring public - using - ( _≉_; +-rawMagma; +-magma; +-unitalMagma; +-commutativeMagma - ; +-semigroup; +-commutativeSemigroup - ; *-rawMagma; *-magma; *-semigroup - ; +-rawMonoid; +-monoid; +-commutativeMonoid - ; *-rawMonoid; *-monoid - ; nearSemiring; semiringWithoutOne - ; semiringWithoutAnnihilatingZero - ; rawSemiring - ) - - *-commutativeMonoid : CommutativeMonoid _ _ - *-commutativeMonoid = record - { isCommutativeMonoid = *-isCommutativeMonoid - } - - open CommutativeMonoid *-commutativeMonoid public - using () renaming - ( commutativeMagma to *-commutativeMagma - ; commutativeSemigroup to *-commutativeSemigroup - ) - - commutativeSemiringWithoutOne : CommutativeSemiringWithoutOne _ _ - commutativeSemiringWithoutOne = record - { isCommutativeSemiringWithoutOne = isCommutativeSemiringWithoutOne - } - - -record CancellativeCommutativeSemiring c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _*_ - infixl 6 _+_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _+_ : Op₂ Carrier - _*_ : Op₂ Carrier - 0# : Carrier - 1# : Carrier - isCancellativeCommutativeSemiring : IsCancellativeCommutativeSemiring _≈_ _+_ _*_ 0# 1# - - open IsCancellativeCommutativeSemiring isCancellativeCommutativeSemiring public - - commutativeSemiring : CommutativeSemiring c ℓ - commutativeSemiring = record - { isCommutativeSemiring = isCommutativeSemiring - } - - open CommutativeSemiring commutativeSemiring public - using - ( +-rawMagma; +-magma; +-unitalMagma; +-commutativeMagma - ; +-semigroup; +-commutativeSemigroup - ; *-rawMagma; *-magma; *-commutativeMagma; *-semigroup; *-commutativeSemigroup - ; +-rawMonoid; +-monoid; +-commutativeMonoid - ; *-rawMonoid; *-monoid; *-commutativeMonoid - ; nearSemiring; semiringWithoutOne - ; semiringWithoutAnnihilatingZero - ; rawSemiring - ; semiring - ; _≉_ - ) - -record IdempotentSemiring c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _*_ - infixl 6 _+_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _+_ : Op₂ Carrier - _*_ : Op₂ Carrier - 0# : Carrier - 1# : Carrier - isIdempotentSemiring : IsIdempotentSemiring _≈_ _+_ _*_ 0# 1# - - open IsIdempotentSemiring isIdempotentSemiring public - - semiring : Semiring _ _ - semiring = record { isSemiring = isSemiring } - - open Semiring semiring public - using - ( _≉_; +-rawMagma; +-magma; +-unitalMagma; +-commutativeMagma - ; +-semigroup; +-commutativeSemigroup - ; *-rawMagma; *-magma; *-semigroup - ; +-rawMonoid; +-monoid; +-commutativeMonoid - ; *-rawMonoid; *-monoid - ; nearSemiring; semiringWithoutOne - ; semiringWithoutAnnihilatingZero - ; rawSemiring - ) - -record KleeneAlgebra c ℓ : Set (suc (c ⊔ ℓ)) where - infix 8 _⋆ - infixl 7 _*_ - infixl 6 _+_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _+_ : Op₂ Carrier - _*_ : Op₂ Carrier - _⋆ : Op₁ Carrier - 0# : Carrier - 1# : Carrier - isKleeneAlgebra : IsKleeneAlgebra _≈_ _+_ _*_ _⋆ 0# 1# - - open IsKleeneAlgebra isKleeneAlgebra public - - idempotentSemiring : IdempotentSemiring _ _ - idempotentSemiring = record { isIdempotentSemiring = isIdempotentSemiring } - - open IdempotentSemiring idempotentSemiring public - using - ( _≉_; +-rawMagma; +-magma; +-unitalMagma; +-commutativeMagma - ; +-semigroup; +-commutativeSemigroup - ; *-rawMagma; *-magma; *-semigroup - ; +-rawMonoid; +-monoid; +-commutativeMonoid - ; *-rawMonoid; *-monoid - ; nearSemiring; semiringWithoutOne - ; semiringWithoutAnnihilatingZero - ; rawSemiring; semiring - ) - -record Quasiring c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _*_ - infixl 6 _+_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _+_ : Op₂ Carrier - _*_ : Op₂ Carrier - 0# : Carrier - 1# : Carrier - isQuasiring : IsQuasiring _≈_ _+_ _*_ 0# 1# - - open IsQuasiring isQuasiring public - - +-monoid : Monoid _ _ - +-monoid = record { isMonoid = +-isMonoid } - - open Monoid +-monoid public - using (_≉_) renaming - ( rawMagma to +-rawMagma - ; magma to +-magma - ; semigroup to +-semigroup - ; unitalMagma to +-unitalMagma - ; rawMonoid to +-rawMonoid - ) - - *-monoid : Monoid _ _ - *-monoid = record { isMonoid = *-isMonoid } - - open Monoid *-monoid public - using () renaming - ( rawMagma to *-rawMagma - ; magma to *-magma - ; semigroup to *-semigroup - ; rawMonoid to *-rawMonoid - ) - ------------------------------------------------------------------------- --- Bundles with 2 binary operations, 1 unary operation & 1 element ------------------------------------------------------------------------- - -record RingWithoutOne c ℓ : Set (suc (c ⊔ ℓ)) where - infix 8 -_ - infixl 7 _*_ - infixl 6 _+_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _+_ : Op₂ Carrier - _*_ : Op₂ Carrier - -_ : Op₁ Carrier - 0# : Carrier - isRingWithoutOne : IsRingWithoutOne _≈_ _+_ _*_ -_ 0# - - open IsRingWithoutOne isRingWithoutOne public - - +-abelianGroup : AbelianGroup _ _ - +-abelianGroup = record { isAbelianGroup = +-isAbelianGroup } - - *-semigroup : Semigroup _ _ - *-semigroup = record { isSemigroup = *-isSemigroup } - - open AbelianGroup +-abelianGroup public - using () renaming (group to +-group; invertibleMagma to +-invertibleMagma; invertibleUnitalMagma to +-invertibleUnitalMagma) - - open Semigroup *-semigroup public - using () renaming - ( rawMagma to *-rawMagma - ; magma to *-magma - ) - ------------------------------------------------------------------------- --- Bundles with 2 binary operations, 1 unary operation & 2 elements ------------------------------------------------------------------------- - -record NonAssociativeRing c ℓ : Set (suc (c ⊔ ℓ)) where - infix 8 -_ - infixl 7 _*_ - infixl 6 _+_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _+_ : Op₂ Carrier - _*_ : Op₂ Carrier - -_ : Op₁ Carrier - 0# : Carrier - 1# : Carrier - isNonAssociativeRing : IsNonAssociativeRing _≈_ _+_ _*_ -_ 0# 1# - - open IsNonAssociativeRing isNonAssociativeRing public - - +-abelianGroup : AbelianGroup _ _ - +-abelianGroup = record { isAbelianGroup = +-isAbelianGroup } - - open AbelianGroup +-abelianGroup public - using () renaming (group to +-group; invertibleMagma to +-invertibleMagma; invertibleUnitalMagma to +-invertibleUnitalMagma) - -record Nearring c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _*_ - infixl 6 _+_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _+_ : Op₂ Carrier - _*_ : Op₂ Carrier - -_ : Op₁ Carrier - 0# : Carrier - 1# : Carrier - isNearring : IsNearring _≈_ _+_ _*_ 0# 1# -_ - - open IsNearring isNearring public - - quasiring : Quasiring _ _ - quasiring = record { isQuasiring = isQuasiring } - - open Quasiring quasiring public - using - (_≉_; +-rawMagma; +-magma; +-unitalMagma; +-semigroup; +-monoid; +-rawMonoid - ;*-rawMagma; *-magma; *-semigroup; *-monoid - ) - - -record Ring c ℓ : Set (suc (c ⊔ ℓ)) where - infix 8 -_ - infixl 7 _*_ - infixl 6 _+_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _+_ : Op₂ Carrier - _*_ : Op₂ Carrier - -_ : Op₁ Carrier - 0# : Carrier - 1# : Carrier - isRing : IsRing _≈_ _+_ _*_ -_ 0# 1# - - open IsRing isRing public - - +-abelianGroup : AbelianGroup _ _ - +-abelianGroup = record { isAbelianGroup = +-isAbelianGroup } - - semiring : Semiring _ _ - semiring = record { isSemiring = isSemiring } - - open Semiring semiring public - using - ( _≉_; +-rawMagma; +-magma; +-unitalMagma; +-commutativeMagma - ; +-semigroup; +-commutativeSemigroup - ; *-rawMagma; *-magma; *-semigroup - ; +-rawMonoid; +-monoid ; +-commutativeMonoid - ; *-rawMonoid; *-monoid - ; nearSemiring; semiringWithoutOne - ; semiringWithoutAnnihilatingZero - ) - - open AbelianGroup +-abelianGroup public - using () renaming (group to +-group; invertibleMagma to +-invertibleMagma; invertibleUnitalMagma to +-invertibleUnitalMagma) - - rawRing : RawRing _ _ - rawRing = record - { _≈_ = _≈_ - ; _+_ = _+_ - ; _*_ = _*_ - ; -_ = -_ - ; 0# = 0# - ; 1# = 1# - } - - -record CommutativeRing c ℓ : Set (suc (c ⊔ ℓ)) where - infix 8 -_ - infixl 7 _*_ - infixl 6 _+_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _+_ : Op₂ Carrier - _*_ : Op₂ Carrier - -_ : Op₁ Carrier - 0# : Carrier - 1# : Carrier - isCommutativeRing : IsCommutativeRing _≈_ _+_ _*_ -_ 0# 1# - - open IsCommutativeRing isCommutativeRing public - - ring : Ring _ _ - ring = record { isRing = isRing } - - open Ring ring public using (_≉_; rawRing; +-invertibleMagma; +-invertibleUnitalMagma; +-group; +-abelianGroup) - - commutativeSemiring : CommutativeSemiring _ _ - commutativeSemiring = - record { isCommutativeSemiring = isCommutativeSemiring } - - open CommutativeSemiring commutativeSemiring public - using - ( +-rawMagma; +-magma; +-unitalMagma; +-commutativeMagma - ; +-semigroup; +-commutativeSemigroup - ; *-rawMagma; *-magma; *-commutativeMagma; *-semigroup; *-commutativeSemigroup - ; +-rawMonoid; +-monoid; +-commutativeMonoid - ; *-rawMonoid; *-monoid; *-commutativeMonoid - ; nearSemiring; semiringWithoutOne - ; semiringWithoutAnnihilatingZero; semiring - ; commutativeSemiringWithoutOne - ) - ------------------------------------------------------------------------- --- Bundles with 3 binary operations ------------------------------------------------------------------------- - -record Quasigroup c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infixl 7 _\\_ - infixl 7 _//_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - _\\_ : Op₂ Carrier - _//_ : Op₂ Carrier - isQuasigroup : IsQuasigroup _≈_ _∙_ _\\_ _//_ - - open IsQuasigroup isQuasigroup public - - magma : Magma c ℓ - magma = record { isMagma = isMagma } - - open Magma magma public - using (_≉_; rawMagma) - - rawQuasigroup : RawQuasigroup c ℓ - rawQuasigroup = record - { _≈_ = _≈_ - ; _∙_ = _∙_ - ; _\\_ = _\\_ - ; _//_ = _//_ - } - - open RawQuasigroup rawQuasigroup public - using (//-rawMagma; \\-rawMagma; ∙-rawMagma) - -record Loop c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infixl 7 _\\_ - infixl 7 _//_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - _\\_ : Op₂ Carrier - _//_ : Op₂ Carrier - ε : Carrier - isLoop : IsLoop _≈_ _∙_ _\\_ _//_ ε - - open IsLoop isLoop public - - rawLoop : RawLoop c ℓ - rawLoop = record - { _≈_ = _≈_ - ; _∙_ = _∙_ - ; _\\_ = _\\_ - ; _//_ = _//_ - ; ε = ε - } - - quasigroup : Quasigroup _ _ - quasigroup = record { isQuasigroup = isQuasigroup } - - open Quasigroup quasigroup public - using (_≉_; ∙-rawMagma; \\-rawMagma; //-rawMagma) - -record LeftBolLoop c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infixl 7 _\\_ - infixl 7 _//_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - _\\_ : Op₂ Carrier - _//_ : Op₂ Carrier - ε : Carrier - isLeftBolLoop : IsLeftBolLoop _≈_ _∙_ _\\_ _//_ ε - - open IsLeftBolLoop isLeftBolLoop public - - loop : Loop _ _ - loop = record { isLoop = isLoop } - - open Loop loop public - using (quasigroup) - -record RightBolLoop c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infixl 7 _\\_ - infixl 7 _//_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - _\\_ : Op₂ Carrier - _//_ : Op₂ Carrier - ε : Carrier - isRightBolLoop : IsRightBolLoop _≈_ _∙_ _\\_ _//_ ε - - open IsRightBolLoop isRightBolLoop public - - loop : Loop _ _ - loop = record { isLoop = isLoop } - - open Loop loop public - using (quasigroup) - -record MoufangLoop c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infixl 7 _\\_ - infixl 7 _//_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - _\\_ : Op₂ Carrier - _//_ : Op₂ Carrier - ε : Carrier - isMoufangLoop : IsMoufangLoop _≈_ _∙_ _\\_ _//_ ε - - open IsMoufangLoop isMoufangLoop public - - leftBolLoop : LeftBolLoop _ _ - leftBolLoop = record { isLeftBolLoop = isLeftBolLoop } - - open LeftBolLoop leftBolLoop public - using (loop) - -record MiddleBolLoop c ℓ : Set (suc (c ⊔ ℓ)) where - infixl 7 _∙_ - infixl 7 _\\_ - infixl 7 _//_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - _\\_ : Op₂ Carrier - _//_ : Op₂ Carrier - ε : Carrier - isMiddleBolLoop : IsMiddleBolLoop _≈_ _∙_ _\\_ _//_ ε - - open IsMiddleBolLoop isMiddleBolLoop public - - loop : Loop _ _ - loop = record { isLoop = isLoop } - - open Loop loop public - using (quasigroup) \ No newline at end of file diff --git a/Algebra.Consequences.Base.html b/Algebra.Consequences.Base.html index 0fffc84e..674a9b83 100644 --- a/Algebra.Consequences.Base.html +++ b/Algebra.Consequences.Base.html @@ -15,18 +15,31 @@ open import Algebra.Definitions open import Data.Sum.Base open import Relation.Binary.Core -open import Relation.Binary.Definitions using (Reflexive) +open import Relation.Binary.Definitions using (Reflexive) -module _ {ℓ} {_•_ : Op₂ A} (_≈_ : Rel A ℓ) where +module _ {ℓ} {_•_ : Op₂ A} (_≈_ : Rel A ℓ) where - sel⇒idem : Selective _≈_ _•_ → Idempotent _≈_ _•_ + sel⇒idem : Selective _≈_ _•_ → Idempotent _≈_ _•_ sel⇒idem sel x = reduce (sel x x) -module _ {ℓ} {f : Op₁ A} (_≈_ : Rel A ℓ) where +module _ {ℓ} {f : Op₁ A} (_≈_ : Rel A ℓ) where - reflexive+selfInverse⇒involutive : Reflexive _≈_ → - SelfInverse _≈_ f → - Involutive _≈_ f - reflexive+selfInverse⇒involutive refl inv _ = inv refl + reflexive∧selfInverse⇒involutive : Reflexive _≈_ → + SelfInverse _≈_ f → + Involutive _≈_ f + reflexive∧selfInverse⇒involutive refl inv _ = inv refl +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 2.0 + +reflexive+selfInverse⇒involutive = reflexive∧selfInverse⇒involutive +{-# WARNING_ON_USAGE reflexive+selfInverse⇒involutive +"Warning: reflexive+selfInverse⇒involutive was deprecated in v2.0. +Please use reflexive∧selfInverse⇒involutive instead." +#-} \ No newline at end of file diff --git a/Algebra.Consequences.Propositional.html b/Algebra.Consequences.Propositional.html index 84c0c02a..463a659e 100644 --- a/Algebra.Consequences.Propositional.html +++ b/Algebra.Consequences.Propositional.html @@ -12,97 +12,192 @@ {a} {A : Set a} where open import Data.Sum.Base using (inj₁; inj₂) -open import Relation.Binary using (Rel; Setoid; Symmetric; Total) -open import Relation.Binary.PropositionalEquality -open import Relation.Unary using (Pred) - -open import Algebra.Core -open import Algebra.Definitions {A = A} _≡_ -import Algebra.Consequences.Setoid (setoid A) as Base - ------------------------------------------------------------------------- --- Re-export all proofs that don't require congruence or substitutivity - -open Base public - hiding - ( assoc+distribʳ+idʳ+invʳ⇒zeˡ - ; assoc+distribˡ+idʳ+invʳ⇒zeʳ - ; assoc+id+invʳ⇒invˡ-unique - ; assoc+id+invˡ⇒invʳ-unique - ; comm+distrˡ⇒distrʳ - ; comm+distrʳ⇒distrˡ - ; comm⇒sym[distribˡ] - ; subst+comm⇒sym - ; wlog - ; sel⇒idem - ) - ------------------------------------------------------------------------- --- Group-like structures - -module _ {_•_ _⁻¹ ε} where - - assoc+id+invʳ⇒invˡ-unique : Associative _•_ → Identity ε _•_ → - RightInverse ε _⁻¹ _•_ → - ∀ x y → (x • y) ≡ ε → x ≡ (y ⁻¹) - assoc+id+invʳ⇒invˡ-unique = Base.assoc+id+invʳ⇒invˡ-unique (cong₂ _) - - assoc+id+invˡ⇒invʳ-unique : Associative _•_ → Identity ε _•_ → - LeftInverse ε _⁻¹ _•_ → - ∀ x y → (x • y) ≡ ε → y ≡ (x ⁻¹) - assoc+id+invˡ⇒invʳ-unique = Base.assoc+id+invˡ⇒invʳ-unique (cong₂ _) - ------------------------------------------------------------------------- --- Ring-like structures - -module _ {_+_ _*_ -_ 0#} where - - assoc+distribʳ+idʳ+invʳ⇒zeˡ : Associative _+_ → _*_ DistributesOverʳ _+_ → - RightIdentity 0# _+_ → RightInverse 0# -_ _+_ → - LeftZero 0# _*_ - assoc+distribʳ+idʳ+invʳ⇒zeˡ = - Base.assoc+distribʳ+idʳ+invʳ⇒zeˡ (cong₂ _+_) (cong₂ _*_) - - assoc+distribˡ+idʳ+invʳ⇒zeʳ : Associative _+_ → _*_ DistributesOverˡ _+_ → - RightIdentity 0# _+_ → RightInverse 0# -_ _+_ → - RightZero 0# _*_ - assoc+distribˡ+idʳ+invʳ⇒zeʳ = - Base.assoc+distribˡ+idʳ+invʳ⇒zeʳ (cong₂ _+_) (cong₂ _*_) - ------------------------------------------------------------------------- --- Bisemigroup-like structures - -module _ {_•_ _◦_ : Op₂ A} (•-comm : Commutative _•_) where - - comm+distrˡ⇒distrʳ : _•_ DistributesOverˡ _◦_ → _•_ DistributesOverʳ _◦_ - comm+distrˡ⇒distrʳ = Base.comm+distrˡ⇒distrʳ (cong₂ _) •-comm - - comm+distrʳ⇒distrˡ : _•_ DistributesOverʳ _◦_ → _•_ DistributesOverˡ _◦_ - comm+distrʳ⇒distrˡ = Base.comm+distrʳ⇒distrˡ (cong₂ _) •-comm - - comm⇒sym[distribˡ] : ∀ x → Symmetric (λ y z → (x ◦ (y • z)) ≡ ((x ◦ y) • (x ◦ z))) - comm⇒sym[distribˡ] = Base.comm⇒sym[distribˡ] (cong₂ _◦_) •-comm - ------------------------------------------------------------------------- --- Selectivity - -module _ {_•_ : Op₂ A} where - - sel⇒idem : Selective _•_ → Idempotent _•_ - sel⇒idem = Base.sel⇒idem _≡_ - ------------------------------------------------------------------------- --- Without Loss of Generality - -module _ {p} {P : Pred A p} where - - subst+comm⇒sym : ∀ {f} (f-comm : Commutative f) → - Symmetric (λ a b → P (f a b)) - subst+comm⇒sym = Base.subst+comm⇒sym {P = P} subst - - wlog : ∀ {f} (f-comm : Commutative f) → - ∀ {r} {_R_ : Rel _ r} → Total _R_ → - (∀ a b → a R b → P (f a b)) → - ∀ a b → P (f a b) - wlog = Base.wlog {P = P} subst +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Binary.Definitions using (Symmetric; Total) +open import Relation.Binary.PropositionalEquality +open import Relation.Unary using (Pred) + +open import Algebra.Core +open import Algebra.Definitions {A = A} _≡_ +import Algebra.Consequences.Setoid (setoid A) as Base + +------------------------------------------------------------------------ +-- Re-export all proofs that don't require congruence or substitutivity + +open Base public + hiding + ( comm∧assoc⇒middleFour + ; identity∧middleFour⇒assoc + ; identity∧middleFour⇒comm + ; assoc∧distribʳ∧idʳ∧invʳ⇒zeˡ + ; assoc∧distribˡ∧idʳ∧invʳ⇒zeʳ + ; assoc∧id∧invʳ⇒invˡ-unique + ; assoc∧id∧invˡ⇒invʳ-unique + ; comm∧distrˡ⇒distrʳ + ; comm∧distrʳ⇒distrˡ + ; comm⇒sym[distribˡ] + ; subst∧comm⇒sym + ; wlog + ; sel⇒idem +-- plus all the deprecated versions of the above + ; comm+assoc⇒middleFour + ; identity+middleFour⇒assoc + ; identity+middleFour⇒comm + ; assoc+distribʳ+idʳ+invʳ⇒zeˡ + ; assoc+distribˡ+idʳ+invʳ⇒zeʳ + ; assoc+id+invʳ⇒invˡ-unique + ; assoc+id+invˡ⇒invʳ-unique + ; comm+distrˡ⇒distrʳ + ; comm+distrʳ⇒distrˡ + ; subst+comm⇒sym + ) + +------------------------------------------------------------------------ +-- Group-like structures + +module _ {_∙_ _⁻¹ ε} where + + assoc∧id∧invʳ⇒invˡ-unique : Associative _∙_ → Identity ε _∙_ → + RightInverse ε _⁻¹ _∙_ → + ∀ x y → (x ∙ y) ≡ ε → x ≡ (y ⁻¹) + assoc∧id∧invʳ⇒invˡ-unique = Base.assoc∧id∧invʳ⇒invˡ-unique (cong₂ _) + + assoc∧id∧invˡ⇒invʳ-unique : Associative _∙_ → Identity ε _∙_ → + LeftInverse ε _⁻¹ _∙_ → + ∀ x y → (x ∙ y) ≡ ε → y ≡ (x ⁻¹) + assoc∧id∧invˡ⇒invʳ-unique = Base.assoc∧id∧invˡ⇒invʳ-unique (cong₂ _) + +------------------------------------------------------------------------ +-- Ring-like structures + +module _ {_+_ _*_ -_ 0#} where + + assoc∧distribʳ∧idʳ∧invʳ⇒zeˡ : Associative _+_ → _*_ DistributesOverʳ _+_ → + RightIdentity 0# _+_ → RightInverse 0# -_ _+_ → + LeftZero 0# _*_ + assoc∧distribʳ∧idʳ∧invʳ⇒zeˡ = + Base.assoc∧distribʳ∧idʳ∧invʳ⇒zeˡ (cong₂ _+_) (cong₂ _*_) + + assoc∧distribˡ∧idʳ∧invʳ⇒zeʳ : Associative _+_ → _*_ DistributesOverˡ _+_ → + RightIdentity 0# _+_ → RightInverse 0# -_ _+_ → + RightZero 0# _*_ + assoc∧distribˡ∧idʳ∧invʳ⇒zeʳ = + Base.assoc∧distribˡ∧idʳ∧invʳ⇒zeʳ (cong₂ _+_) (cong₂ _*_) + +------------------------------------------------------------------------ +-- Bisemigroup-like structures + +module _ {_∙_ _◦_ : Op₂ A} (∙-comm : Commutative _∙_) where + + comm∧distrˡ⇒distrʳ : _∙_ DistributesOverˡ _◦_ → _∙_ DistributesOverʳ _◦_ + comm∧distrˡ⇒distrʳ = Base.comm+distrˡ⇒distrʳ (cong₂ _) ∙-comm + + comm∧distrʳ⇒distrˡ : _∙_ DistributesOverʳ _◦_ → _∙_ DistributesOverˡ _◦_ + comm∧distrʳ⇒distrˡ = Base.comm∧distrʳ⇒distrˡ (cong₂ _) ∙-comm + + comm⇒sym[distribˡ] : ∀ x → Symmetric (λ y z → (x ◦ (y ∙ z)) ≡ ((x ◦ y) ∙ (x ◦ z))) + comm⇒sym[distribˡ] = Base.comm⇒sym[distribˡ] (cong₂ _◦_) ∙-comm + +------------------------------------------------------------------------ +-- Selectivity + +module _ {_∙_ : Op₂ A} where + + sel⇒idem : Selective _∙_ → Idempotent _∙_ + sel⇒idem = Base.sel⇒idem _≡_ + +------------------------------------------------------------------------ +-- Middle-Four Exchange + +module _ {_∙_ : Op₂ A} where + + comm∧assoc⇒middleFour : Commutative _∙_ → Associative _∙_ → + _∙_ MiddleFourExchange _∙_ + comm∧assoc⇒middleFour = Base.comm∧assoc⇒middleFour (cong₂ _∙_) + + identity∧middleFour⇒assoc : {e : A} → Identity e _∙_ → + _∙_ MiddleFourExchange _∙_ → + Associative _∙_ + identity∧middleFour⇒assoc = Base.identity∧middleFour⇒assoc (cong₂ _∙_) + + identity∧middleFour⇒comm : {_+_ : Op₂ A} {e : A} → Identity e _+_ → + _∙_ MiddleFourExchange _+_ → + Commutative _∙_ + identity∧middleFour⇒comm = Base.identity∧middleFour⇒comm (cong₂ _∙_) + +------------------------------------------------------------------------ +-- Without Loss of Generality + +module _ {p} {P : Pred A p} where + + subst∧comm⇒sym : ∀ {f} (f-comm : Commutative f) → + Symmetric (λ a b → P (f a b)) + subst∧comm⇒sym = Base.subst∧comm⇒sym {P = P} subst + + wlog : ∀ {f} (f-comm : Commutative f) → + ∀ {r} {_R_ : Rel _ r} → Total _R_ → + (∀ a b → a R b → P (f a b)) → + ∀ a b → P (f a b) + wlog = Base.wlog {P = P} subst + + +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 2.0 + +comm+assoc⇒middleFour = comm∧assoc⇒middleFour +{-# WARNING_ON_USAGE comm+assoc⇒middleFour +"Warning: comm+assoc⇒middleFour was deprecated in v2.0. +Please use comm∧assoc⇒middleFour instead." +#-} +identity+middleFour⇒assoc = identity∧middleFour⇒assoc +{-# WARNING_ON_USAGE identity+middleFour⇒assoc +"Warning: identity+middleFour⇒assoc was deprecated in v2.0. +Please use identity∧middleFour⇒assoc instead." +#-} +identity+middleFour⇒comm = identity∧middleFour⇒comm +{-# WARNING_ON_USAGE identity+middleFour⇒comm +"Warning: identity+middleFour⇒comm was deprecated in v2.0. +Please use identity∧middleFour⇒comm instead." +#-} +comm+distrˡ⇒distrʳ = comm∧distrˡ⇒distrʳ +{-# WARNING_ON_USAGE comm+distrˡ⇒distrʳ +"Warning: comm+distrˡ⇒distrʳ was deprecated in v2.0. +Please use comm∧distrˡ⇒distrʳ instead." +#-} +comm+distrʳ⇒distrˡ = comm∧distrʳ⇒distrˡ +{-# WARNING_ON_USAGE comm+distrʳ⇒distrˡ +"Warning: comm+distrʳ⇒distrˡ was deprecated in v2.0. +Please use comm∧distrʳ⇒distrˡ instead." +#-} +assoc+distribʳ+idʳ+invʳ⇒zeˡ = assoc∧distribʳ∧idʳ∧invʳ⇒zeˡ +{-# WARNING_ON_USAGE assoc+distribʳ+idʳ+invʳ⇒zeˡ +"Warning: assoc+distribʳ+idʳ+invʳ⇒zeˡ was deprecated in v2.0. +Please use assoc∧distribʳ∧idʳ∧invʳ⇒zeˡ instead." +#-} +assoc+distribˡ+idʳ+invʳ⇒zeʳ = assoc∧distribˡ∧idʳ∧invʳ⇒zeʳ +{-# WARNING_ON_USAGE assoc+distribˡ+idʳ+invʳ⇒zeʳ +"Warning: assoc+distribˡ+idʳ+invʳ⇒zeʳ was deprecated in v2.0. +Please use assoc∧distribˡ∧idʳ∧invʳ⇒zeʳ instead." +#-} +assoc+id+invʳ⇒invˡ-unique = assoc∧id∧invʳ⇒invˡ-unique +{-# WARNING_ON_USAGE assoc+id+invʳ⇒invˡ-unique +"Warning: assoc+id+invʳ⇒invˡ-unique was deprecated in v2.0. +Please use assoc∧id∧invʳ⇒invˡ-unique instead." +#-} +assoc+id+invˡ⇒invʳ-unique = assoc∧id∧invˡ⇒invʳ-unique +{-# WARNING_ON_USAGE assoc+id+invˡ⇒invʳ-unique +"Warning: assoc+id+invˡ⇒invʳ-unique was deprecated in v2.0. +Please use assoc∧id∧invˡ⇒invʳ-unique instead." +#-} +subst+comm⇒sym = subst∧comm⇒sym +{-# WARNING_ON_USAGE subst+comm⇒sym +"Warning: subst+comm⇒sym was deprecated in v2.0. +Please use subst∧comm⇒sym instead." +#-} \ No newline at end of file diff --git a/Algebra.Consequences.Setoid.html b/Algebra.Consequences.Setoid.html index 3884801c..6a28a1bc 100644 --- a/Algebra.Consequences.Setoid.html +++ b/Algebra.Consequences.Setoid.html @@ -8,296 +8,440 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary using (Rel; Setoid; Substitutive; Symmetric; Total) - -module Algebra.Consequences.Setoid {a ℓ} (S : Setoid a ℓ) where - -open Setoid S renaming (Carrier to A) -open import Algebra.Core -open import Algebra.Definitions _≈_ -open import Data.Sum.Base using (inj₁; inj₂) -open import Data.Product using (_,_) -open import Function.Base using (_$_) -import Function.Definitions as FunDefs -import Relation.Binary.Consequences as Bin -open import Relation.Binary.Reasoning.Setoid S -open import Relation.Unary using (Pred) - ------------------------------------------------------------------------- --- Re-exports - --- Export base lemmas that don't require the setoid - -open import Algebra.Consequences.Base public - ------------------------------------------------------------------------- --- Involutive/SelfInverse functions - -module _ {f : Op₁ A} (inv : Involutive f) where - - open FunDefs _≈_ _≈_ - - involutive⇒surjective : Surjective f - involutive⇒surjective y = f y , inv y - -module _ {f : Op₁ A} (self : SelfInverse f) where - - selfInverse⇒involutive : Involutive f - selfInverse⇒involutive = reflexive+selfInverse⇒involutive _≈_ refl self - - private - - inv = selfInverse⇒involutive - - open FunDefs _≈_ _≈_ - - selfInverse⇒congruent : Congruent f - selfInverse⇒congruent {x} {y} x≈y = sym (self (begin - f (f x) ≈⟨ inv x ⟩ - x ≈⟨ x≈y ⟩ - y ∎)) - - selfInverse⇒inverseᵇ : Inverseᵇ f f - selfInverse⇒inverseᵇ = inv , inv - - selfInverse⇒surjective : Surjective f - selfInverse⇒surjective = involutive⇒surjective inv - - selfInverse⇒injective : Injective f - selfInverse⇒injective {x} {y} x≈y = begin - x ≈˘⟨ self x≈y ⟩ - f (f y) ≈⟨ inv y ⟩ - y ∎ - - selfInverse⇒bijective : Bijective f - selfInverse⇒bijective = selfInverse⇒injective , selfInverse⇒surjective - ------------------------------------------------------------------------- --- Magma-like structures - -module _ {_•_ : Op₂ A} (comm : Commutative _•_) where - - comm+cancelˡ⇒cancelʳ : LeftCancellative _•_ → RightCancellative _•_ - comm+cancelˡ⇒cancelʳ cancelˡ x y z eq = cancelˡ x y z $ begin - x • y ≈⟨ comm x y ⟩ - y • x ≈⟨ eq ⟩ - z • x ≈⟨ comm z x ⟩ - x • z ∎ - - comm+cancelʳ⇒cancelˡ : RightCancellative _•_ → LeftCancellative _•_ - comm+cancelʳ⇒cancelˡ cancelʳ x y z eq = cancelʳ x y z $ begin - y • x ≈⟨ comm y x ⟩ - x • y ≈⟨ eq ⟩ - x • z ≈⟨ comm x z ⟩ - z • x ∎ - ------------------------------------------------------------------------- --- Monoid-like structures - -module _ {_•_ : Op₂ A} (comm : Commutative _•_) {e : A} where - - comm+idˡ⇒idʳ : LeftIdentity e _•_ → RightIdentity e _•_ - comm+idˡ⇒idʳ idˡ x = begin - x • e ≈⟨ comm x e ⟩ - e • x ≈⟨ idˡ x ⟩ - x ∎ - - comm+idʳ⇒idˡ : RightIdentity e _•_ → LeftIdentity e _•_ - comm+idʳ⇒idˡ idʳ x = begin - e • x ≈⟨ comm e x ⟩ - x • e ≈⟨ idʳ x ⟩ - x ∎ - - comm+idˡ⇒id : LeftIdentity e _•_ → Identity e _•_ - comm+idˡ⇒id idˡ = idˡ , comm+idˡ⇒idʳ idˡ - - comm+idʳ⇒id : RightIdentity e _•_ → Identity e _•_ - comm+idʳ⇒id idʳ = comm+idʳ⇒idˡ idʳ , idʳ - - comm+zeˡ⇒zeʳ : LeftZero e _•_ → RightZero e _•_ - comm+zeˡ⇒zeʳ zeˡ x = begin - x • e ≈⟨ comm x e ⟩ - e • x ≈⟨ zeˡ x ⟩ - e ∎ - - comm+zeʳ⇒zeˡ : RightZero e _•_ → LeftZero e _•_ - comm+zeʳ⇒zeˡ zeʳ x = begin - e • x ≈⟨ comm e x ⟩ - x • e ≈⟨ zeʳ x ⟩ - e ∎ - - comm+zeˡ⇒ze : LeftZero e _•_ → Zero e _•_ - comm+zeˡ⇒ze zeˡ = zeˡ , comm+zeˡ⇒zeʳ zeˡ - - comm+zeʳ⇒ze : RightZero e _•_ → Zero e _•_ - comm+zeʳ⇒ze zeʳ = comm+zeʳ⇒zeˡ zeʳ , zeʳ - - comm+almostCancelˡ⇒almostCancelʳ : AlmostLeftCancellative e _•_ → - AlmostRightCancellative e _•_ - comm+almostCancelˡ⇒almostCancelʳ cancelˡ-nonZero x y z x≉e yx≈zx = - cancelˡ-nonZero x y z x≉e $ begin - x • y ≈⟨ comm x y ⟩ - y • x ≈⟨ yx≈zx ⟩ - z • x ≈⟨ comm z x ⟩ - x • z ∎ - - comm+almostCancelʳ⇒almostCancelˡ : AlmostRightCancellative e _•_ → - AlmostLeftCancellative e _•_ - comm+almostCancelʳ⇒almostCancelˡ cancelʳ-nonZero x y z x≉e xy≈xz = - cancelʳ-nonZero x y z x≉e $ begin - y • x ≈⟨ comm y x ⟩ - x • y ≈⟨ xy≈xz ⟩ - x • z ≈⟨ comm x z ⟩ - z • x ∎ - ------------------------------------------------------------------------- --- Group-like structures - -module _ {_•_ : Op₂ A} {_⁻¹ : Op₁ A} {e} (comm : Commutative _•_) where - - comm+invˡ⇒invʳ : LeftInverse e _⁻¹ _•_ → RightInverse e _⁻¹ _•_ - comm+invˡ⇒invʳ invˡ x = begin - x • (x ⁻¹) ≈⟨ comm x (x ⁻¹) ⟩ - (x ⁻¹) • x ≈⟨ invˡ x ⟩ - e ∎ - - comm+invˡ⇒inv : LeftInverse e _⁻¹ _•_ → Inverse e _⁻¹ _•_ - comm+invˡ⇒inv invˡ = invˡ , comm+invˡ⇒invʳ invˡ - - comm+invʳ⇒invˡ : RightInverse e _⁻¹ _•_ → LeftInverse e _⁻¹ _•_ - comm+invʳ⇒invˡ invʳ x = begin - (x ⁻¹) • x ≈⟨ comm (x ⁻¹) x ⟩ - x • (x ⁻¹) ≈⟨ invʳ x ⟩ - e ∎ - - comm+invʳ⇒inv : RightInverse e _⁻¹ _•_ → Inverse e _⁻¹ _•_ - comm+invʳ⇒inv invʳ = comm+invʳ⇒invˡ invʳ , invʳ - -module _ {_•_ : Op₂ A} {_⁻¹ : Op₁ A} {e} (cong : Congruent₂ _•_) where - - assoc+id+invʳ⇒invˡ-unique : Associative _•_ → - Identity e _•_ → RightInverse e _⁻¹ _•_ → - ∀ x y → (x • y) ≈ e → x ≈ (y ⁻¹) - assoc+id+invʳ⇒invˡ-unique assoc (idˡ , idʳ) invʳ x y eq = begin - x ≈⟨ sym (idʳ x) ⟩ - x • e ≈⟨ cong refl (sym (invʳ y)) ⟩ - x • (y • (y ⁻¹)) ≈⟨ sym (assoc x y (y ⁻¹)) ⟩ - (x • y) • (y ⁻¹) ≈⟨ cong eq refl ⟩ - e • (y ⁻¹) ≈⟨ idˡ (y ⁻¹) ⟩ - y ⁻¹ ∎ - - assoc+id+invˡ⇒invʳ-unique : Associative _•_ → - Identity e _•_ → LeftInverse e _⁻¹ _•_ → - ∀ x y → (x • y) ≈ e → y ≈ (x ⁻¹) - assoc+id+invˡ⇒invʳ-unique assoc (idˡ , idʳ) invˡ x y eq = begin - y ≈⟨ sym (idˡ y) ⟩ - e • y ≈⟨ cong (sym (invˡ x)) refl ⟩ - ((x ⁻¹) • x) • y ≈⟨ assoc (x ⁻¹) x y ⟩ - (x ⁻¹) • (x • y) ≈⟨ cong refl eq ⟩ - (x ⁻¹) • e ≈⟨ idʳ (x ⁻¹) ⟩ - x ⁻¹ ∎ - ----------------------------------------------------------------------- --- Bisemigroup-like structures - -module _ {_•_ _◦_ : Op₂ A} - (◦-cong : Congruent₂ _◦_) - (•-comm : Commutative _•_) - where - - comm+distrˡ⇒distrʳ : _•_ DistributesOverˡ _◦_ → _•_ DistributesOverʳ _◦_ - comm+distrˡ⇒distrʳ distrˡ x y z = begin - (y ◦ z) • x ≈⟨ •-comm (y ◦ z) x ⟩ - x • (y ◦ z) ≈⟨ distrˡ x y z ⟩ - (x • y) ◦ (x • z) ≈⟨ ◦-cong (•-comm x y) (•-comm x z) ⟩ - (y • x) ◦ (z • x) ∎ - - comm+distrʳ⇒distrˡ : _•_ DistributesOverʳ _◦_ → _•_ DistributesOverˡ _◦_ - comm+distrʳ⇒distrˡ distrˡ x y z = begin - x • (y ◦ z) ≈⟨ •-comm x (y ◦ z) ⟩ - (y ◦ z) • x ≈⟨ distrˡ x y z ⟩ - (y • x) ◦ (z • x) ≈⟨ ◦-cong (•-comm y x) (•-comm z x) ⟩ - (x • y) ◦ (x • z) ∎ - - comm+distrˡ⇒distr : _•_ DistributesOverˡ _◦_ → _•_ DistributesOver _◦_ - comm+distrˡ⇒distr distrˡ = distrˡ , comm+distrˡ⇒distrʳ distrˡ - - comm+distrʳ⇒distr : _•_ DistributesOverʳ _◦_ → _•_ DistributesOver _◦_ - comm+distrʳ⇒distr distrʳ = comm+distrʳ⇒distrˡ distrʳ , distrʳ - - comm⇒sym[distribˡ] : ∀ x → Symmetric (λ y z → (x ◦ (y • z)) ≈ ((x ◦ y) • (x ◦ z))) - comm⇒sym[distribˡ] x {y} {z} prf = begin - x ◦ (z • y) ≈⟨ ◦-cong refl (•-comm z y) ⟩ - x ◦ (y • z) ≈⟨ prf ⟩ - (x ◦ y) • (x ◦ z) ≈⟨ •-comm (x ◦ y) (x ◦ z) ⟩ - (x ◦ z) • (x ◦ y) ∎ - - -module _ {_•_ _◦_ : Op₂ A} - (•-cong : Congruent₂ _•_) - (•-assoc : Associative _•_) - (◦-comm : Commutative _◦_) - where - - distrib+absorbs⇒distribˡ : _•_ Absorbs _◦_ → - _◦_ Absorbs _•_ → - _◦_ DistributesOver _•_ → - _•_ DistributesOverˡ _◦_ - distrib+absorbs⇒distribˡ •-absorbs-◦ ◦-absorbs-• (◦-distribˡ-• , ◦-distribʳ-•) x y z = begin - x • (y ◦ z) ≈˘⟨ •-cong (•-absorbs-◦ _ _) refl ⟩ - (x • (x ◦ y)) • (y ◦ z) ≈⟨ •-cong (•-cong refl (◦-comm _ _)) refl ⟩ - (x • (y ◦ x)) • (y ◦ z) ≈⟨ •-assoc _ _ _ ⟩ - x • ((y ◦ x) • (y ◦ z)) ≈˘⟨ •-cong refl (◦-distribˡ-• _ _ _) ⟩ - x • (y ◦ (x • z)) ≈˘⟨ •-cong (◦-absorbs-• _ _) refl ⟩ - (x ◦ (x • z)) • (y ◦ (x • z)) ≈˘⟨ ◦-distribʳ-• _ _ _ ⟩ - (x • y) ◦ (x • z) ∎ - ----------------------------------------------------------------------- --- Ring-like structures - -module _ {_+_ _*_ : Op₂ A} - {_⁻¹ : Op₁ A} {0# : A} - (+-cong : Congruent₂ _+_) - (*-cong : Congruent₂ _*_) - where - - assoc+distribʳ+idʳ+invʳ⇒zeˡ : Associative _+_ → _*_ DistributesOverʳ _+_ → - RightIdentity 0# _+_ → RightInverse 0# _⁻¹ _+_ → - LeftZero 0# _*_ - assoc+distribʳ+idʳ+invʳ⇒zeˡ +-assoc distribʳ idʳ invʳ x = begin - 0# * x ≈⟨ sym (idʳ _) ⟩ - (0# * x) + 0# ≈⟨ +-cong refl (sym (invʳ _)) ⟩ - (0# * x) + ((0# * x) + ((0# * x)⁻¹)) ≈⟨ sym (+-assoc _ _ _) ⟩ - ((0# * x) + (0# * x)) + ((0# * x)⁻¹) ≈⟨ +-cong (sym (distribʳ _ _ _)) refl ⟩ - ((0# + 0#) * x) + ((0# * x)⁻¹) ≈⟨ +-cong (*-cong (idʳ _) refl) refl ⟩ - (0# * x) + ((0# * x)⁻¹) ≈⟨ invʳ _ ⟩ - 0# ∎ - - assoc+distribˡ+idʳ+invʳ⇒zeʳ : Associative _+_ → _*_ DistributesOverˡ _+_ → - RightIdentity 0# _+_ → RightInverse 0# _⁻¹ _+_ → - RightZero 0# _*_ - assoc+distribˡ+idʳ+invʳ⇒zeʳ +-assoc distribˡ idʳ invʳ x = begin - x * 0# ≈⟨ sym (idʳ _) ⟩ - (x * 0#) + 0# ≈⟨ +-cong refl (sym (invʳ _)) ⟩ - (x * 0#) + ((x * 0#) + ((x * 0#)⁻¹)) ≈⟨ sym (+-assoc _ _ _) ⟩ - ((x * 0#) + (x * 0#)) + ((x * 0#)⁻¹) ≈⟨ +-cong (sym (distribˡ _ _ _)) refl ⟩ - (x * (0# + 0#)) + ((x * 0#)⁻¹) ≈⟨ +-cong (*-cong refl (idʳ _)) refl ⟩ - ((x * 0#) + ((x * 0#)⁻¹)) ≈⟨ invʳ _ ⟩ - 0# ∎ - ------------------------------------------------------------------------- --- Without Loss of Generality - -module _ {p} {f : Op₂ A} {P : Pred A p} - (≈-subst : Substitutive _≈_ p) - (comm : Commutative f) - where - - subst+comm⇒sym : Symmetric (λ a b → P (f a b)) - subst+comm⇒sym = ≈-subst P (comm _ _) - - wlog : ∀ {r} {_R_ : Rel _ r} → Total _R_ → - (∀ a b → a R b → P (f a b)) → - ∀ a b → P (f a b) - wlog r-total = Bin.wlog r-total subst+comm⇒sym +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Binary.Definitions + using (Substitutive; Symmetric; Total) + +module Algebra.Consequences.Setoid {a ℓ} (S : Setoid a ℓ) where + +open Setoid S renaming (Carrier to A) +open import Algebra.Core +open import Algebra.Definitions _≈_ +open import Data.Sum.Base using (inj₁; inj₂) +open import Data.Product.Base using (_,_) +open import Function.Base using (_$_; id; _∘_) +open import Function.Definitions +import Relation.Binary.Consequences as Bin +open import Relation.Binary.Reasoning.Setoid S +open import Relation.Unary using (Pred) + +------------------------------------------------------------------------ +-- Re-exports + +-- Export base lemmas that don't require the setoid + +open import Algebra.Consequences.Base public + +------------------------------------------------------------------------ +-- MiddleFourExchange + +module _ {_∙_ : Op₂ A} (cong : Congruent₂ _∙_) where + + comm∧assoc⇒middleFour : Commutative _∙_ → Associative _∙_ → + _∙_ MiddleFourExchange _∙_ + comm∧assoc⇒middleFour comm assoc w x y z = begin + (w ∙ x) ∙ (y ∙ z) ≈⟨ assoc w x (y ∙ z) ⟩ + w ∙ (x ∙ (y ∙ z)) ≈⟨ cong refl (sym (assoc x y z)) ⟩ + w ∙ ((x ∙ y) ∙ z) ≈⟨ cong refl (cong (comm x y) refl) ⟩ + w ∙ ((y ∙ x) ∙ z) ≈⟨ cong refl (assoc y x z) ⟩ + w ∙ (y ∙ (x ∙ z)) ≈⟨ sym (assoc w y (x ∙ z)) ⟩ + (w ∙ y) ∙ (x ∙ z) ∎ + + identity∧middleFour⇒assoc : {e : A} → Identity e _∙_ → + _∙_ MiddleFourExchange _∙_ → + Associative _∙_ + identity∧middleFour⇒assoc {e} (identityˡ , identityʳ) middleFour x y z = begin + (x ∙ y) ∙ z ≈⟨ cong refl (sym (identityˡ z)) ⟩ + (x ∙ y) ∙ (e ∙ z) ≈⟨ middleFour x y e z ⟩ + (x ∙ e) ∙ (y ∙ z) ≈⟨ cong (identityʳ x) refl ⟩ + x ∙ (y ∙ z) ∎ + + identity∧middleFour⇒comm : {_+_ : Op₂ A} {e : A} → Identity e _+_ → + _∙_ MiddleFourExchange _+_ → + Commutative _∙_ + identity∧middleFour⇒comm {_+_} {e} (identityˡ , identityʳ) middleFour x y + = begin + x ∙ y ≈⟨ sym (cong (identityˡ x) (identityʳ y)) ⟩ + (e + x) ∙ (y + e) ≈⟨ middleFour e x y e ⟩ + (e + y) ∙ (x + e) ≈⟨ cong (identityˡ y) (identityʳ x) ⟩ + y ∙ x ∎ + +------------------------------------------------------------------------ +-- SelfInverse + +module _ {f : Op₁ A} (self : SelfInverse f) where + + selfInverse⇒involutive : Involutive f + selfInverse⇒involutive = reflexive∧selfInverse⇒involutive _≈_ refl self + + selfInverse⇒congruent : Congruent _≈_ _≈_ f + selfInverse⇒congruent {x} {y} x≈y = sym (self (begin + f (f x) ≈⟨ selfInverse⇒involutive x ⟩ + x ≈⟨ x≈y ⟩ + y ∎)) + + selfInverse⇒inverseᵇ : Inverseᵇ _≈_ _≈_ f f + selfInverse⇒inverseᵇ = self ∘ sym , self ∘ sym + + selfInverse⇒surjective : Surjective _≈_ _≈_ f + selfInverse⇒surjective y = f y , self ∘ sym + + selfInverse⇒injective : Injective _≈_ _≈_ f + selfInverse⇒injective {x} {y} x≈y = begin + x ≈⟨ self x≈y ⟨ + f (f y) ≈⟨ selfInverse⇒involutive y ⟩ + y ∎ + + selfInverse⇒bijective : Bijective _≈_ _≈_ f + selfInverse⇒bijective = selfInverse⇒injective , selfInverse⇒surjective + +------------------------------------------------------------------------ +-- Magma-like structures + +module _ {_∙_ : Op₂ A} (comm : Commutative _∙_) where + + comm∧cancelˡ⇒cancelʳ : LeftCancellative _∙_ → RightCancellative _∙_ + comm∧cancelˡ⇒cancelʳ cancelˡ x y z eq = cancelˡ x y z $ begin + x ∙ y ≈⟨ comm x y ⟩ + y ∙ x ≈⟨ eq ⟩ + z ∙ x ≈⟨ comm z x ⟩ + x ∙ z ∎ + + comm∧cancelʳ⇒cancelˡ : RightCancellative _∙_ → LeftCancellative _∙_ + comm∧cancelʳ⇒cancelˡ cancelʳ x y z eq = cancelʳ x y z $ begin + y ∙ x ≈⟨ comm y x ⟩ + x ∙ y ≈⟨ eq ⟩ + x ∙ z ≈⟨ comm x z ⟩ + z ∙ x ∎ + +------------------------------------------------------------------------ +-- Monoid-like structures + +module _ {_∙_ : Op₂ A} (comm : Commutative _∙_) {e : A} where + + comm∧idˡ⇒idʳ : LeftIdentity e _∙_ → RightIdentity e _∙_ + comm∧idˡ⇒idʳ idˡ x = begin + x ∙ e ≈⟨ comm x e ⟩ + e ∙ x ≈⟨ idˡ x ⟩ + x ∎ + + comm∧idʳ⇒idˡ : RightIdentity e _∙_ → LeftIdentity e _∙_ + comm∧idʳ⇒idˡ idʳ x = begin + e ∙ x ≈⟨ comm e x ⟩ + x ∙ e ≈⟨ idʳ x ⟩ + x ∎ + + comm∧idˡ⇒id : LeftIdentity e _∙_ → Identity e _∙_ + comm∧idˡ⇒id idˡ = idˡ , comm∧idˡ⇒idʳ idˡ + + comm∧idʳ⇒id : RightIdentity e _∙_ → Identity e _∙_ + comm∧idʳ⇒id idʳ = comm∧idʳ⇒idˡ idʳ , idʳ + + comm∧zeˡ⇒zeʳ : LeftZero e _∙_ → RightZero e _∙_ + comm∧zeˡ⇒zeʳ zeˡ x = begin + x ∙ e ≈⟨ comm x e ⟩ + e ∙ x ≈⟨ zeˡ x ⟩ + e ∎ + + comm∧zeʳ⇒zeˡ : RightZero e _∙_ → LeftZero e _∙_ + comm∧zeʳ⇒zeˡ zeʳ x = begin + e ∙ x ≈⟨ comm e x ⟩ + x ∙ e ≈⟨ zeʳ x ⟩ + e ∎ + + comm∧zeˡ⇒ze : LeftZero e _∙_ → Zero e _∙_ + comm∧zeˡ⇒ze zeˡ = zeˡ , comm∧zeˡ⇒zeʳ zeˡ + + comm∧zeʳ⇒ze : RightZero e _∙_ → Zero e _∙_ + comm∧zeʳ⇒ze zeʳ = comm∧zeʳ⇒zeˡ zeʳ , zeʳ + + comm∧almostCancelˡ⇒almostCancelʳ : AlmostLeftCancellative e _∙_ → + AlmostRightCancellative e _∙_ + comm∧almostCancelˡ⇒almostCancelʳ cancelˡ-nonZero x y z x≉e yx≈zx = + cancelˡ-nonZero x y z x≉e $ begin + x ∙ y ≈⟨ comm x y ⟩ + y ∙ x ≈⟨ yx≈zx ⟩ + z ∙ x ≈⟨ comm z x ⟩ + x ∙ z ∎ + + comm∧almostCancelʳ⇒almostCancelˡ : AlmostRightCancellative e _∙_ → + AlmostLeftCancellative e _∙_ + comm∧almostCancelʳ⇒almostCancelˡ cancelʳ-nonZero x y z x≉e xy≈xz = + cancelʳ-nonZero x y z x≉e $ begin + y ∙ x ≈⟨ comm y x ⟩ + x ∙ y ≈⟨ xy≈xz ⟩ + x ∙ z ≈⟨ comm x z ⟩ + z ∙ x ∎ + +------------------------------------------------------------------------ +-- Group-like structures + +module _ {_∙_ : Op₂ A} {_⁻¹ : Op₁ A} {e} (comm : Commutative _∙_) where + + comm∧invˡ⇒invʳ : LeftInverse e _⁻¹ _∙_ → RightInverse e _⁻¹ _∙_ + comm∧invˡ⇒invʳ invˡ x = begin + x ∙ (x ⁻¹) ≈⟨ comm x (x ⁻¹) ⟩ + (x ⁻¹) ∙ x ≈⟨ invˡ x ⟩ + e ∎ + + comm∧invˡ⇒inv : LeftInverse e _⁻¹ _∙_ → Inverse e _⁻¹ _∙_ + comm∧invˡ⇒inv invˡ = invˡ , comm∧invˡ⇒invʳ invˡ + + comm∧invʳ⇒invˡ : RightInverse e _⁻¹ _∙_ → LeftInverse e _⁻¹ _∙_ + comm∧invʳ⇒invˡ invʳ x = begin + (x ⁻¹) ∙ x ≈⟨ comm (x ⁻¹) x ⟩ + x ∙ (x ⁻¹) ≈⟨ invʳ x ⟩ + e ∎ + + comm∧invʳ⇒inv : RightInverse e _⁻¹ _∙_ → Inverse e _⁻¹ _∙_ + comm∧invʳ⇒inv invʳ = comm∧invʳ⇒invˡ invʳ , invʳ + +module _ {_∙_ : Op₂ A} {_⁻¹ : Op₁ A} {e} (cong : Congruent₂ _∙_) where + + assoc∧id∧invʳ⇒invˡ-unique : Associative _∙_ → + Identity e _∙_ → RightInverse e _⁻¹ _∙_ → + ∀ x y → (x ∙ y) ≈ e → x ≈ (y ⁻¹) + assoc∧id∧invʳ⇒invˡ-unique assoc (idˡ , idʳ) invʳ x y eq = begin + x ≈⟨ sym (idʳ x) ⟩ + x ∙ e ≈⟨ cong refl (sym (invʳ y)) ⟩ + x ∙ (y ∙ (y ⁻¹)) ≈⟨ sym (assoc x y (y ⁻¹)) ⟩ + (x ∙ y) ∙ (y ⁻¹) ≈⟨ cong eq refl ⟩ + e ∙ (y ⁻¹) ≈⟨ idˡ (y ⁻¹) ⟩ + y ⁻¹ ∎ + + assoc∧id∧invˡ⇒invʳ-unique : Associative _∙_ → + Identity e _∙_ → LeftInverse e _⁻¹ _∙_ → + ∀ x y → (x ∙ y) ≈ e → y ≈ (x ⁻¹) + assoc∧id∧invˡ⇒invʳ-unique assoc (idˡ , idʳ) invˡ x y eq = begin + y ≈⟨ sym (idˡ y) ⟩ + e ∙ y ≈⟨ cong (sym (invˡ x)) refl ⟩ + ((x ⁻¹) ∙ x) ∙ y ≈⟨ assoc (x ⁻¹) x y ⟩ + (x ⁻¹) ∙ (x ∙ y) ≈⟨ cong refl eq ⟩ + (x ⁻¹) ∙ e ≈⟨ idʳ (x ⁻¹) ⟩ + x ⁻¹ ∎ + +------------------------------------------------------------------------ +-- Bisemigroup-like structures + +module _ {_∙_ _◦_ : Op₂ A} + (◦-cong : Congruent₂ _◦_) + (∙-comm : Commutative _∙_) + where + + comm∧distrˡ⇒distrʳ : _∙_ DistributesOverˡ _◦_ → _∙_ DistributesOverʳ _◦_ + comm∧distrˡ⇒distrʳ distrˡ x y z = begin + (y ◦ z) ∙ x ≈⟨ ∙-comm (y ◦ z) x ⟩ + x ∙ (y ◦ z) ≈⟨ distrˡ x y z ⟩ + (x ∙ y) ◦ (x ∙ z) ≈⟨ ◦-cong (∙-comm x y) (∙-comm x z) ⟩ + (y ∙ x) ◦ (z ∙ x) ∎ + + comm∧distrʳ⇒distrˡ : _∙_ DistributesOverʳ _◦_ → _∙_ DistributesOverˡ _◦_ + comm∧distrʳ⇒distrˡ distrˡ x y z = begin + x ∙ (y ◦ z) ≈⟨ ∙-comm x (y ◦ z) ⟩ + (y ◦ z) ∙ x ≈⟨ distrˡ x y z ⟩ + (y ∙ x) ◦ (z ∙ x) ≈⟨ ◦-cong (∙-comm y x) (∙-comm z x) ⟩ + (x ∙ y) ◦ (x ∙ z) ∎ + + comm∧distrˡ⇒distr : _∙_ DistributesOverˡ _◦_ → _∙_ DistributesOver _◦_ + comm∧distrˡ⇒distr distrˡ = distrˡ , comm∧distrˡ⇒distrʳ distrˡ + + comm∧distrʳ⇒distr : _∙_ DistributesOverʳ _◦_ → _∙_ DistributesOver _◦_ + comm∧distrʳ⇒distr distrʳ = comm∧distrʳ⇒distrˡ distrʳ , distrʳ + + comm⇒sym[distribˡ] : ∀ x → Symmetric (λ y z → (x ◦ (y ∙ z)) ≈ ((x ◦ y) ∙ (x ◦ z))) + comm⇒sym[distribˡ] x {y} {z} prf = begin + x ◦ (z ∙ y) ≈⟨ ◦-cong refl (∙-comm z y) ⟩ + x ◦ (y ∙ z) ≈⟨ prf ⟩ + (x ◦ y) ∙ (x ◦ z) ≈⟨ ∙-comm (x ◦ y) (x ◦ z) ⟩ + (x ◦ z) ∙ (x ◦ y) ∎ + + +module _ {_∙_ _◦_ : Op₂ A} + (∙-cong : Congruent₂ _∙_) + (∙-assoc : Associative _∙_) + (◦-comm : Commutative _◦_) + where + + distrib∧absorbs⇒distribˡ : _∙_ Absorbs _◦_ → + _◦_ Absorbs _∙_ → + _◦_ DistributesOver _∙_ → + _∙_ DistributesOverˡ _◦_ + distrib∧absorbs⇒distribˡ ∙-absorbs-◦ ◦-absorbs-∙ (◦-distribˡ-∙ , ◦-distribʳ-∙) x y z = begin + x ∙ (y ◦ z) ≈⟨ ∙-cong (∙-absorbs-◦ _ _) refl ⟨ + (x ∙ (x ◦ y)) ∙ (y ◦ z) ≈⟨ ∙-cong (∙-cong refl (◦-comm _ _)) refl ⟩ + (x ∙ (y ◦ x)) ∙ (y ◦ z) ≈⟨ ∙-assoc _ _ _ ⟩ + x ∙ ((y ◦ x) ∙ (y ◦ z)) ≈⟨ ∙-cong refl (◦-distribˡ-∙ _ _ _) ⟨ + x ∙ (y ◦ (x ∙ z)) ≈⟨ ∙-cong (◦-absorbs-∙ _ _) refl ⟨ + (x ◦ (x ∙ z)) ∙ (y ◦ (x ∙ z)) ≈⟨ ◦-distribʳ-∙ _ _ _ ⟨ + (x ∙ y) ◦ (x ∙ z) ∎ + +------------------------------------------------------------------------ +-- Ring-like structures + +module _ {_+_ _*_ : Op₂ A} + {_⁻¹ : Op₁ A} {0# : A} + (+-cong : Congruent₂ _+_) + (*-cong : Congruent₂ _*_) + where + + assoc∧distribʳ∧idʳ∧invʳ⇒zeˡ : Associative _+_ → _*_ DistributesOverʳ _+_ → + RightIdentity 0# _+_ → RightInverse 0# _⁻¹ _+_ → + LeftZero 0# _*_ + assoc∧distribʳ∧idʳ∧invʳ⇒zeˡ +-assoc distribʳ idʳ invʳ x = begin + 0# * x ≈⟨ sym (idʳ _) ⟩ + (0# * x) + 0# ≈⟨ +-cong refl (sym (invʳ _)) ⟩ + (0# * x) + ((0# * x) + ((0# * x)⁻¹)) ≈⟨ sym (+-assoc _ _ _) ⟩ + ((0# * x) + (0# * x)) + ((0# * x)⁻¹) ≈⟨ +-cong (sym (distribʳ _ _ _)) refl ⟩ + ((0# + 0#) * x) + ((0# * x)⁻¹) ≈⟨ +-cong (*-cong (idʳ _) refl) refl ⟩ + (0# * x) + ((0# * x)⁻¹) ≈⟨ invʳ _ ⟩ + 0# ∎ + + assoc∧distribˡ∧idʳ∧invʳ⇒zeʳ : Associative _+_ → _*_ DistributesOverˡ _+_ → + RightIdentity 0# _+_ → RightInverse 0# _⁻¹ _+_ → + RightZero 0# _*_ + assoc∧distribˡ∧idʳ∧invʳ⇒zeʳ +-assoc distribˡ idʳ invʳ x = begin + x * 0# ≈⟨ sym (idʳ _) ⟩ + (x * 0#) + 0# ≈⟨ +-cong refl (sym (invʳ _)) ⟩ + (x * 0#) + ((x * 0#) + ((x * 0#)⁻¹)) ≈⟨ sym (+-assoc _ _ _) ⟩ + ((x * 0#) + (x * 0#)) + ((x * 0#)⁻¹) ≈⟨ +-cong (sym (distribˡ _ _ _)) refl ⟩ + (x * (0# + 0#)) + ((x * 0#)⁻¹) ≈⟨ +-cong (*-cong refl (idʳ _)) refl ⟩ + ((x * 0#) + ((x * 0#)⁻¹)) ≈⟨ invʳ _ ⟩ + 0# ∎ + +------------------------------------------------------------------------ +-- Without Loss of Generality + +module _ {p} {f : Op₂ A} {P : Pred A p} + (≈-subst : Substitutive _≈_ p) + (comm : Commutative f) + where + + subst∧comm⇒sym : Symmetric (λ a b → P (f a b)) + subst∧comm⇒sym = ≈-subst P (comm _ _) + + wlog : ∀ {r} {_R_ : Rel _ r} → Total _R_ → + (∀ a b → a R b → P (f a b)) → + ∀ a b → P (f a b) + wlog r-total = Bin.wlog r-total subst∧comm⇒sym + + +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 2.0 + +comm+assoc⇒middleFour = comm∧assoc⇒middleFour +{-# WARNING_ON_USAGE comm+assoc⇒middleFour +"Warning: comm+assoc⇒middleFour was deprecated in v2.0. +Please use comm∧assoc⇒middleFour instead." +#-} +identity+middleFour⇒assoc = identity∧middleFour⇒assoc +{-# WARNING_ON_USAGE identity+middleFour⇒assoc +"Warning: identity+middleFour⇒assoc was deprecated in v2.0. +Please use identity∧middleFour⇒assoc instead." +#-} +identity+middleFour⇒comm = identity∧middleFour⇒comm +{-# WARNING_ON_USAGE identity+middleFour⇒comm +"Warning: identity+middleFour⇒comm was deprecated in v2.0. +Please use identity∧middleFour⇒comm instead." +#-} +comm+cancelˡ⇒cancelʳ = comm∧cancelˡ⇒cancelʳ +{-# WARNING_ON_USAGE comm+cancelˡ⇒cancelʳ +"Warning: comm+cancelˡ⇒cancelʳ was deprecated in v2.0. +Please use comm∧cancelˡ⇒cancelʳ instead." +#-} +comm+cancelʳ⇒cancelˡ = comm∧cancelʳ⇒cancelˡ +{-# WARNING_ON_USAGE comm+cancelʳ⇒cancelˡ +"Warning: comm+cancelʳ⇒cancelˡ was deprecated in v2.0. +Please use comm∧cancelʳ⇒cancelˡ instead." +#-} +comm+idˡ⇒idʳ = comm∧idˡ⇒idʳ +{-# WARNING_ON_USAGE comm+idˡ⇒idʳ +"Warning: comm+idˡ⇒idʳ was deprecated in v2.0. +Please use comm∧idˡ⇒idʳ instead." +#-} +comm+idʳ⇒idˡ = comm∧idʳ⇒idˡ +{-# WARNING_ON_USAGE comm+idʳ⇒idˡ +"Warning: comm+idʳ⇒idˡ was deprecated in v2.0. +Please use comm∧idʳ⇒idˡ instead." +#-} +comm+zeˡ⇒zeʳ = comm∧zeˡ⇒zeʳ +{-# WARNING_ON_USAGE comm+zeˡ⇒zeʳ +"Warning: comm+zeˡ⇒zeʳ was deprecated in v2.0. +Please use comm∧zeˡ⇒zeʳ instead." +#-} +comm+zeʳ⇒zeˡ = comm∧zeʳ⇒zeˡ +{-# WARNING_ON_USAGE comm+zeʳ⇒zeˡ +"Warning: comm+zeʳ⇒zeˡ was deprecated in v2.0. +Please use comm∧zeʳ⇒zeˡ instead." +#-} +comm+almostCancelˡ⇒almostCancelʳ = comm∧almostCancelˡ⇒almostCancelʳ +{-# WARNING_ON_USAGE comm+almostCancelˡ⇒almostCancelʳ +"Warning: comm+almostCancelˡ⇒almostCancelʳ was deprecated in v2.0. +Please use comm∧almostCancelˡ⇒almostCancelʳ instead." +#-} +comm+almostCancelʳ⇒almostCancelˡ = comm∧almostCancelʳ⇒almostCancelˡ +{-# WARNING_ON_USAGE comm+almostCancelʳ⇒almostCancelˡ +"Warning: comm+almostCancelʳ⇒almostCancelˡ was deprecated in v2.0. +Please use comm∧almostCancelʳ⇒almostCancelˡ instead." +#-} +comm+invˡ⇒invʳ = comm∧invˡ⇒invʳ +{-# WARNING_ON_USAGE comm+invˡ⇒invʳ +"Warning: comm+invˡ⇒invʳ was deprecated in v2.0. +Please use comm∧invˡ⇒invʳ instead." +#-} +comm+invʳ⇒invˡ = comm∧invʳ⇒invˡ +{-# WARNING_ON_USAGE comm+invʳ⇒invˡ +"Warning: comm+invʳ⇒invˡ was deprecated in v2.0. +Please use comm∧invʳ⇒invˡ instead." +#-} +comm+invˡ⇒inv = comm∧invˡ⇒inv +{-# WARNING_ON_USAGE comm+invˡ⇒inv +"Warning: comm+invˡ⇒inv was deprecated in v2.0. +Please use comm∧invˡ⇒inv instead." +#-} +comm+invʳ⇒inv = comm∧invʳ⇒inv +{-# WARNING_ON_USAGE comm+invʳ⇒inv +"Warning: comm+invʳ⇒inv was deprecated in v2.0. +Please use comm∧invʳ⇒inv instead." +#-} +comm+distrˡ⇒distrʳ = comm∧distrˡ⇒distrʳ +{-# WARNING_ON_USAGE comm+distrˡ⇒distrʳ +"Warning: comm+distrˡ⇒distrʳ was deprecated in v2.0. +Please use comm∧distrˡ⇒distrʳ instead." +#-} +comm+distrʳ⇒distrˡ = comm∧distrʳ⇒distrˡ +{-# WARNING_ON_USAGE comm+distrʳ⇒distrˡ +"Warning: comm+distrʳ⇒distrˡ was deprecated in v2.0. +Please use comm∧distrʳ⇒distrˡ instead." +#-} +assoc+distribʳ+idʳ+invʳ⇒zeˡ = assoc∧distribʳ∧idʳ∧invʳ⇒zeˡ +{-# WARNING_ON_USAGE assoc+distribʳ+idʳ+invʳ⇒zeˡ +"Warning: assoc+distribʳ+idʳ+invʳ⇒zeˡ was deprecated in v2.0. +Please use assoc∧distribʳ∧idʳ∧invʳ⇒zeˡ instead." +#-} +assoc+distribˡ+idʳ+invʳ⇒zeʳ = assoc∧distribˡ∧idʳ∧invʳ⇒zeʳ +{-# WARNING_ON_USAGE assoc+distribˡ+idʳ+invʳ⇒zeʳ +"Warning: assoc+distribˡ+idʳ+invʳ⇒zeʳ was deprecated in v2.0. +Please use assoc∧distribˡ∧idʳ∧invʳ⇒zeʳ instead." +#-} +assoc+id+invʳ⇒invˡ-unique = assoc∧id∧invʳ⇒invˡ-unique +{-# WARNING_ON_USAGE assoc+id+invʳ⇒invˡ-unique +"Warning: assoc+id+invʳ⇒invˡ-unique was deprecated in v2.0. +Please use assoc∧id∧invʳ⇒invˡ-unique instead." +#-} +assoc+id+invˡ⇒invʳ-unique = assoc∧id∧invˡ⇒invʳ-unique +{-# WARNING_ON_USAGE assoc+id+invˡ⇒invʳ-unique +"Warning: assoc+id+invˡ⇒invʳ-unique was deprecated in v2.0. +Please use assoc∧id∧invˡ⇒invʳ-unique instead." +#-} +subst+comm⇒sym = subst∧comm⇒sym +{-# WARNING_ON_USAGE subst+comm⇒sym +"Warning: subst+comm⇒sym was deprecated in v2.0. +Please use subst∧comm⇒sym instead." +#-} \ No newline at end of file diff --git a/Algebra.Construct.LiftedChoice.html b/Algebra.Construct.LiftedChoice.html deleted file mode 100644 index b5e4873b..00000000 --- a/Algebra.Construct.LiftedChoice.html +++ /dev/null @@ -1,189 +0,0 @@ - -Algebra.Construct.LiftedChoice
------------------------------------------------------------------------
--- The Agda standard library
---
--- Choosing between elements based on the result of applying a function
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-open import Algebra
-
-module Algebra.Construct.LiftedChoice where
-
-open import Algebra.Consequences.Base
-open import Relation.Binary
-open import Relation.Nullary using (¬_; yes; no)
-open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂; [_,_])
-open import Data.Product using (_×_; _,_)
-open import Level using (Level; _⊔_)
-open import Relation.Binary.PropositionalEquality as P using (_≡_)
-open import Relation.Unary using (Pred)
-
-import Relation.Binary.Reasoning.Setoid as EqReasoning
-
-private
-  variable
-    a b p ℓ : Level
-    A : Set a
-    B : Set b
-
-------------------------------------------------------------------------
--- Definition
-
-module _ (_≈_ : Rel B ℓ) (_•_ : Op₂ B) where
-
-  Lift : Selective _≈_ _•_ → (A → B) → Op₂ A
-  Lift ∙-sel f x y with ∙-sel (f x) (f y)
-  ... | inj₁ _ = x
-  ... | inj₂ _ = y
-
-------------------------------------------------------------------------
--- Algebraic properties
-
-module _ {_≈_ : Rel B ℓ} {_∙_ : Op₂ B}
-         (∙-isSelectiveMagma : IsSelectiveMagma _≈_ _∙_) where
-
-  private module M = IsSelectiveMagma ∙-isSelectiveMagma
-  open M hiding (sel; isMagma)
-  open EqReasoning setoid
-
-  module _ (f : A → B) where
-
-    private
-      _◦_ = Lift _≈_ _∙_ M.sel f
-
-    sel-≡ : Selective _≡_ _◦_
-    sel-≡ x y with M.sel (f x) (f y)
-    ... | inj₁ _ = inj₁ P.refl
-    ... | inj₂ _ = inj₂ P.refl
-
-    distrib : ∀ x y → ((f x) ∙ (f y)) ≈ f (x ◦ y)
-    distrib x y with M.sel (f x) (f y)
-    ... | inj₁ fx∙fy≈fx = fx∙fy≈fx
-    ... | inj₂ fx∙fy≈fy = fx∙fy≈fy
-
-  module _ (f : A → B) {_≈′_ : Rel A ℓ}
-           (≈-reflexive : _≡_ ⇒ _≈′_) where
-
-    private
-      _◦_ = Lift _≈_ _∙_ M.sel f
-
-    sel : Selective _≈′_ _◦_
-    sel x y = Sum.map ≈-reflexive ≈-reflexive (sel-≡ f x y)
-
-    idem : Idempotent _≈′_ _◦_
-    idem = sel⇒idem _≈′_ sel
-
-  module _ {f : A → B} {_≈′_ : Rel A ℓ}
-           (f-injective : ∀ {x y} → f x ≈ f y → x ≈′ y)
-           where
-
-    private
-      _◦_ = Lift _≈_ _∙_ M.sel f
-
-    cong : f Preserves _≈′_ ⟶ _≈_ → Congruent₂ _≈′_ _◦_
-    cong f-cong {x} {y} {u} {v} x≈y u≈v
-      with M.sel (f x) (f u) | M.sel (f y) (f v)
-    ... | inj₁ fx∙fu≈fx | inj₁ fy∙fv≈fy = x≈y
-    ... | inj₂ fx∙fu≈fu | inj₂ fy∙fv≈fv = u≈v
-    ... | inj₁ fx∙fu≈fx | inj₂ fy∙fv≈fv = f-injective (begin
-      f x       ≈⟨ sym fx∙fu≈fx ⟩
-      f x ∙ f u ≈⟨ ∙-cong (f-cong x≈y) (f-cong u≈v) ⟩
-      f y ∙ f v ≈⟨ fy∙fv≈fv ⟩
-      f v       ∎)
-    ... | inj₂ fx∙fu≈fu | inj₁ fy∙fv≈fy = f-injective (begin
-      f u       ≈⟨ sym fx∙fu≈fu ⟩
-      f x ∙ f u ≈⟨ ∙-cong (f-cong x≈y) (f-cong u≈v) ⟩
-      f y ∙ f v ≈⟨ fy∙fv≈fy ⟩
-      f y       ∎)
-
-    assoc : Associative _≈_ _∙_ → Associative _≈′_ _◦_
-    assoc ∙-assoc x y z = f-injective (begin
-      f ((x ◦ y) ◦ z)   ≈˘⟨ distrib f (x ◦ y) z ⟩
-      f (x ◦ y) ∙ f z   ≈˘⟨ ∙-congʳ (distrib f x y) ⟩
-      (f x ∙ f y) ∙ f z ≈⟨  ∙-assoc (f x) (f y) (f z) ⟩
-      f x ∙ (f y ∙ f z) ≈⟨  ∙-congˡ (distrib f y z) ⟩
-      f x ∙ f (y ◦ z)   ≈⟨  distrib f x (y ◦ z) ⟩
-      f (x ◦ (y ◦ z))   ∎)
-
-    comm : Commutative _≈_ _∙_ → Commutative _≈′_ _◦_
-    comm ∙-comm x y = f-injective (begin
-      f (x ◦ y) ≈˘⟨ distrib f x y ⟩
-      f x ∙ f y ≈⟨  ∙-comm (f x) (f y) ⟩
-      f y ∙ f x ≈⟨  distrib f y x ⟩
-      f (y ◦ x) ∎)
-
-------------------------------------------------------------------------
--- Algebraic structures
-
-  module _ {_≈′_ : Rel A ℓ} {f : A → B}
-           (f-injective : ∀ {x y} → f x ≈ f y → x ≈′ y)
-           (f-cong : f Preserves _≈′_ ⟶ _≈_)
-           (≈′-isEquivalence : IsEquivalence _≈′_)
-           where
-
-    private
-      module E = IsEquivalence ≈′-isEquivalence
-      _◦_ = Lift _≈_ _∙_ M.sel f
-
-    isMagma : IsMagma _≈′_ _◦_
-    isMagma = record
-      { isEquivalence = ≈′-isEquivalence
-      ; ∙-cong        = cong (λ {x} → f-injective {x}) f-cong
-      }
-
-    isSemigroup : Associative _≈_ _∙_ → IsSemigroup _≈′_ _◦_
-    isSemigroup ∙-assoc = record
-      { isMagma = isMagma
-      ; assoc   = assoc (λ {x} → f-injective {x}) ∙-assoc
-      }
-
-    isBand : Associative _≈_ _∙_ → IsBand _≈′_ _◦_
-    isBand ∙-assoc = record
-      { isSemigroup = isSemigroup ∙-assoc
-      ; idem        = idem f E.reflexive
-      }
-
-    isSelectiveMagma : IsSelectiveMagma _≈′_ _◦_
-    isSelectiveMagma = record
-      { isMagma = isMagma
-      ; sel     = sel f E.reflexive
-      }
-
-------------------------------------------------------------------------
--- Other properties
-
-  module _ {P : Pred A p} (f : A → B) where
-
-    private
-      _◦_ = Lift _≈_ _∙_ M.sel f
-
-    preservesᵒ : (∀ {x y} → P x → (f x ∙ f y) ≈ f y → P y) →
-                 (∀ {x y} → P y → (f x ∙ f y) ≈ f x → P x) →
-                 ∀ x y → P x ⊎ P y → P (x ◦ y)
-    preservesᵒ left right x y (inj₁ px) with M.sel (f x) (f y)
-    ... | inj₁ _        = px
-    ... | inj₂ fx∙fy≈fx = left px fx∙fy≈fx
-    preservesᵒ left right x y (inj₂ py) with M.sel (f x) (f y)
-    ... | inj₁ fx∙fy≈fy = right py fx∙fy≈fy
-    ... | inj₂ _        = py
-
-    preservesʳ : (∀ {x y} → P y → (f x ∙ f y) ≈ f x → P x) →
-                 ∀ x {y} → P y → P (x ◦ y)
-    preservesʳ right x {y} Py with M.sel (f x) (f y)
-    ... | inj₁ fx∙fy≈fx = right Py fx∙fy≈fx
-    ... | inj₂ fx∙fy≈fy = Py
-
-    preservesᵇ : ∀ {x y} → P x → P y → P (x ◦ y)
-    preservesᵇ {x} {y} Px Py with M.sel (f x) (f y)
-    ... | inj₁ _ = Px
-    ... | inj₂ _ = Py
-
-    forcesᵇ : (∀ {x y} → P x → (f x ∙ f y) ≈ f x → P y) →
-              (∀ {x y} → P y → (f x ∙ f y) ≈ f y → P x) →
-              ∀ x y → P (x ◦ y) → P x × P y
-    forcesᵇ presˡ presʳ x y P[x∙y] with M.sel (f x) (f y)
-    ... | inj₁ fx∙fy≈fx = P[x∙y] , presˡ P[x∙y] fx∙fy≈fx
-    ... | inj₂ fx∙fy≈fy = presʳ P[x∙y] fx∙fy≈fy , P[x∙y]
-
\ No newline at end of file diff --git a/Algebra.Construct.NaturalChoice.Base.html b/Algebra.Construct.NaturalChoice.Base.html index d3c24818..27607cc7 100644 --- a/Algebra.Construct.NaturalChoice.Base.html +++ b/Algebra.Construct.NaturalChoice.Base.html @@ -11,53 +11,53 @@ open import Algebra.Core open import Level as L hiding (_⊔_) open import Function.Base using (flip) -open import Relation.Binary -open import Relation.Binary.Construct.Converse using () - renaming (totalPreorder to flipOrder) -import Relation.Binary.Properties.TotalOrder as TotalOrderProperties - -module Algebra.Construct.NaturalChoice.Base where - -private - variable - a ℓ₁ ℓ₂ : Level - O : TotalPreorder a ℓ₁ ℓ₂ - ------------------------------------------------------------------------- --- Definition - -module _ (O : TotalPreorder a ℓ₁ ℓ₂) where - open TotalPreorder O renaming (_≲_ to _≤_) - private _≥_ = flip _≤_ - - record MinOperator : Set (a L.⊔ ℓ₁ L.⊔ ℓ₂) where - infixl 7 _⊓_ - field - _⊓_ : Op₂ Carrier - x≤y⇒x⊓y≈x : ∀ {x y} → x ≤ y → x ⊓ y ≈ x - x≥y⇒x⊓y≈y : ∀ {x y} → x ≥ y → x ⊓ y ≈ y - - record MaxOperator : Set (a L.⊔ ℓ₁ L.⊔ ℓ₂) where - infixl 6 _⊔_ - field - _⊔_ : Op₂ Carrier - x≤y⇒x⊔y≈y : ∀ {x y} → x ≤ y → x ⊔ y ≈ y - x≥y⇒x⊔y≈x : ∀ {x y} → x ≥ y → x ⊔ y ≈ x - ------------------------------------------------------------------------- --- Properties - -MinOp⇒MaxOp : MinOperator O → MaxOperator (flipOrder O) -MinOp⇒MaxOp minOp = record - { _⊔_ = _⊓_ - ; x≤y⇒x⊔y≈y = x≥y⇒x⊓y≈y - ; x≥y⇒x⊔y≈x = x≤y⇒x⊓y≈x - } where open MinOperator minOp - -MaxOp⇒MinOp : MaxOperator O → MinOperator (flipOrder O) -MaxOp⇒MinOp maxOp = record - { _⊓_ = _⊔_ - ; x≤y⇒x⊓y≈x = x≥y⇒x⊔y≈x - ; x≥y⇒x⊓y≈y = x≤y⇒x⊔y≈y - } where open MaxOperator maxOp +open import Relation.Binary.Bundles using (TotalPreorder) +open import Relation.Binary.Construct.Flip.EqAndOrd using () + renaming (totalPreorder to flipOrder) +import Relation.Binary.Properties.TotalOrder as TotalOrderProperties + +module Algebra.Construct.NaturalChoice.Base where + +private + variable + a ℓ₁ ℓ₂ : Level + O : TotalPreorder a ℓ₁ ℓ₂ + +------------------------------------------------------------------------ +-- Definition + +module _ (O : TotalPreorder a ℓ₁ ℓ₂) where + open TotalPreorder O renaming (_≲_ to _≤_) + private _≥_ = flip _≤_ + + record MinOperator : Set (a L.⊔ ℓ₁ L.⊔ ℓ₂) where + infixl 7 _⊓_ + field + _⊓_ : Op₂ Carrier + x≤y⇒x⊓y≈x : ∀ {x y} → x ≤ y → x ⊓ y ≈ x + x≥y⇒x⊓y≈y : ∀ {x y} → x ≥ y → x ⊓ y ≈ y + + record MaxOperator : Set (a L.⊔ ℓ₁ L.⊔ ℓ₂) where + infixl 6 _⊔_ + field + _⊔_ : Op₂ Carrier + x≤y⇒x⊔y≈y : ∀ {x y} → x ≤ y → x ⊔ y ≈ y + x≥y⇒x⊔y≈x : ∀ {x y} → x ≥ y → x ⊔ y ≈ x + +------------------------------------------------------------------------ +-- Properties + +MinOp⇒MaxOp : MinOperator O → MaxOperator (flipOrder O) +MinOp⇒MaxOp minOp = record + { _⊔_ = _⊓_ + ; x≤y⇒x⊔y≈y = x≥y⇒x⊓y≈y + ; x≥y⇒x⊔y≈x = x≤y⇒x⊓y≈x + } where open MinOperator minOp + +MaxOp⇒MinOp : MaxOperator O → MinOperator (flipOrder O) +MaxOp⇒MinOp maxOp = record + { _⊓_ = _⊔_ + ; x≤y⇒x⊓y≈x = x≥y⇒x⊔y≈x + ; x≥y⇒x⊓y≈y = x≤y⇒x⊔y≈y + } where open MaxOperator maxOp \ No newline at end of file diff --git a/Algebra.Construct.NaturalChoice.Max.html b/Algebra.Construct.NaturalChoice.Max.html deleted file mode 100644 index e3e2bda1..00000000 --- a/Algebra.Construct.NaturalChoice.Max.html +++ /dev/null @@ -1,49 +0,0 @@ - -Algebra.Construct.NaturalChoice.Max
------------------------------------------------------------------------
--- The Agda standard library
---
--- The max operator derived from an arbitrary total preorder.
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-open import Relation.Binary
-
-module Algebra.Construct.NaturalChoice.Max
-  {a ℓ₁ ℓ₂} (totalOrder : TotalOrder a ℓ₁ ℓ₂) where
-
-open import Algebra.Core
-open import Algebra.Definitions
-open import Algebra.Construct.NaturalChoice.Base
-open import Relation.Binary.Construct.Converse using ()
-  renaming (totalOrder to flip)
-
-open TotalOrder totalOrder renaming (Carrier to A)
-
-------------------------------------------------------------------------
--- Max is just min with a flipped order
-
-import Algebra.Construct.NaturalChoice.Min (flip totalOrder) as Min
-
-infixl 6 _⊔_
-
-_⊔_ : Op₂ A
-_⊔_ = Min._⊓_
-
-------------------------------------------------------------------------
--- Properties
-
-open Min public using ()
-  renaming
-  ( x≤y⇒x⊓y≈x to x≤y⇒y⊔x≈y
-  ; x≤y⇒y⊓x≈x to x≤y⇒x⊔y≈y
-  )
-
-maxOperator : MaxOperator totalPreorder
-maxOperator = record
-  { x≤y⇒x⊔y≈y = x≤y⇒x⊔y≈y
-  ; x≥y⇒x⊔y≈x = x≤y⇒y⊔x≈y
-  }
-
-open import Algebra.Construct.NaturalChoice.MaxOp maxOperator public
-
\ No newline at end of file diff --git a/Algebra.Construct.NaturalChoice.MaxOp.html b/Algebra.Construct.NaturalChoice.MaxOp.html index c9dc6e55..1b6a7fa5 100644 --- a/Algebra.Construct.NaturalChoice.MaxOp.html +++ b/Algebra.Construct.NaturalChoice.MaxOp.html @@ -12,71 +12,72 @@ open import Algebra.Construct.NaturalChoice.Base import Algebra.Construct.NaturalChoice.MinOp as MinOp open import Function.Base using (flip) -open import Relation.Binary -open import Relation.Binary.Construct.Converse using () - renaming (totalPreorder to flipOrder) +open import Relation.Binary.Core using (_Preserves_⟶_) +open import Relation.Binary.Bundles using (TotalPreorder) +open import Relation.Binary.Construct.Flip.EqAndOrd using () + renaming (totalPreorder to flipOrder) -module Algebra.Construct.NaturalChoice.MaxOp - {a ℓ₁ ℓ₂} {O : TotalPreorder a ℓ₁ ℓ₂} (maxOp : MaxOperator O) - where +module Algebra.Construct.NaturalChoice.MaxOp + {a ℓ₁ ℓ₂} {O : TotalPreorder a ℓ₁ ℓ₂} (maxOp : MaxOperator O) + where -open TotalPreorder O renaming (Carrier to A; _≲_ to _≤_) -open MaxOperator maxOp +open TotalPreorder O renaming (Carrier to A; _≲_ to _≤_) +open MaxOperator maxOp --- Max is just min with a flipped order +-- Max is just min with a flipped order -private - module Min = MinOp (MaxOp⇒MinOp maxOp) +private + module Min = MinOp (MaxOp⇒MinOp maxOp) -open Min public - using () - renaming - ( ⊓-cong to ⊔-cong - ; ⊓-congʳ to ⊔-congʳ - ; ⊓-congˡ to ⊔-congˡ - ; ⊓-idem to ⊔-idem - ; ⊓-sel to ⊔-sel - ; ⊓-assoc to ⊔-assoc - ; ⊓-comm to ⊔-comm +open Min public + using () + renaming + ( ⊓-cong to ⊔-cong + ; ⊓-congʳ to ⊔-congʳ + ; ⊓-congˡ to ⊔-congˡ + ; ⊓-idem to ⊔-idem + ; ⊓-sel to ⊔-sel + ; ⊓-assoc to ⊔-assoc + ; ⊓-comm to ⊔-comm - ; ⊓-identityˡ to ⊔-identityˡ - ; ⊓-identityʳ to ⊔-identityʳ - ; ⊓-identity to ⊔-identity - ; ⊓-zeroˡ to ⊔-zeroˡ - ; ⊓-zeroʳ to ⊔-zeroʳ - ; ⊓-zero to ⊔-zero + ; ⊓-identityˡ to ⊔-identityˡ + ; ⊓-identityʳ to ⊔-identityʳ + ; ⊓-identity to ⊔-identity + ; ⊓-zeroˡ to ⊔-zeroˡ + ; ⊓-zeroʳ to ⊔-zeroʳ + ; ⊓-zero to ⊔-zero - ; ⊓-isMagma to ⊔-isMagma - ; ⊓-isSemigroup to ⊔-isSemigroup - ; ⊓-isCommutativeSemigroup to ⊔-isCommutativeSemigroup - ; ⊓-isBand to ⊔-isBand - ; ⊓-isMonoid to ⊔-isMonoid - ; ⊓-isSelectiveMagma to ⊔-isSelectiveMagma + ; ⊓-isMagma to ⊔-isMagma + ; ⊓-isSemigroup to ⊔-isSemigroup + ; ⊓-isCommutativeSemigroup to ⊔-isCommutativeSemigroup + ; ⊓-isBand to ⊔-isBand + ; ⊓-isMonoid to ⊔-isMonoid + ; ⊓-isSelectiveMagma to ⊔-isSelectiveMagma - ; ⊓-magma to ⊔-magma - ; ⊓-semigroup to ⊔-semigroup - ; ⊓-commutativeSemigroup to ⊔-commutativeSemigroup - ; ⊓-band to ⊔-band - ; ⊓-monoid to ⊔-monoid - ; ⊓-selectiveMagma to ⊔-selectiveMagma + ; ⊓-magma to ⊔-magma + ; ⊓-semigroup to ⊔-semigroup + ; ⊓-commutativeSemigroup to ⊔-commutativeSemigroup + ; ⊓-band to ⊔-band + ; ⊓-monoid to ⊔-monoid + ; ⊓-selectiveMagma to ⊔-selectiveMagma - ; x⊓y≈y⇒y≤x to x⊔y≈y⇒x≤y - ; x⊓y≈x⇒x≤y to x⊔y≈x⇒y≤x - ; x⊓y≤x to x≤x⊔y - ; x⊓y≤y to x≤y⊔x - ; x≤y⇒x⊓z≤y to x≤y⇒x≤y⊔z - ; x≤y⇒z⊓x≤y to x≤y⇒x≤z⊔y - ; x≤y⊓z⇒x≤y to x⊔y≤z⇒x≤z - ; x≤y⊓z⇒x≤z to x⊔y≤z⇒y≤z + ; x⊓y≈y⇒y≤x to x⊔y≈y⇒x≤y + ; x⊓y≈x⇒x≤y to x⊔y≈x⇒y≤x + ; x⊓y≤x to x≤x⊔y + ; x⊓y≤y to x≤y⊔x + ; x≤y⇒x⊓z≤y to x≤y⇒x≤y⊔z + ; x≤y⇒z⊓x≤y to x≤y⇒x≤z⊔y + ; x≤y⊓z⇒x≤y to x⊔y≤z⇒x≤z + ; x≤y⊓z⇒x≤z to x⊔y≤z⇒y≤z - ; ⊓-glb to ⊔-lub - ; ⊓-triangulate to ⊔-triangulate - ; ⊓-mono-≤ to ⊔-mono-≤ - ; ⊓-monoˡ-≤ to ⊔-monoˡ-≤ - ; ⊓-monoʳ-≤ to ⊔-monoʳ-≤ - ) + ; ⊓-glb to ⊔-lub + ; ⊓-triangulate to ⊔-triangulate + ; ⊓-mono-≤ to ⊔-mono-≤ + ; ⊓-monoˡ-≤ to ⊔-monoˡ-≤ + ; ⊓-monoʳ-≤ to ⊔-monoʳ-≤ + ) -mono-≤-distrib-⊔ : ∀ {f} → f Preserves _≈_ ⟶ _≈_ → f Preserves _≤_ ⟶ _≤_ → - ∀ x y → f (x ⊔ y) ≈ f x ⊔ f y -mono-≤-distrib-⊔ cong pres = Min.mono-≤-distrib-⊓ cong pres +mono-≤-distrib-⊔ : ∀ {f} → f Preserves _≈_ ⟶ _≈_ → f Preserves _≤_ ⟶ _≤_ → + ∀ x y → f (x ⊔ y) ≈ f x ⊔ f y +mono-≤-distrib-⊔ cong pres = Min.mono-≤-distrib-⊓ cong pres \ No newline at end of file diff --git a/Algebra.Construct.NaturalChoice.Min.html b/Algebra.Construct.NaturalChoice.Min.html deleted file mode 100644 index 02f32bf7..00000000 --- a/Algebra.Construct.NaturalChoice.Min.html +++ /dev/null @@ -1,55 +0,0 @@ - -Algebra.Construct.NaturalChoice.Min
------------------------------------------------------------------------
--- The Agda standard library
---
--- The min operator derived from an arbitrary total preorder.
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-open import Algebra.Core
-open import Algebra.Bundles
-open import Algebra.Construct.NaturalChoice.Base
-open import Data.Sum using (inj₁; inj₂; [_,_])
-open import Data.Product using (_,_)
-open import Function using (id)
-open import Relation.Binary
-import Algebra.Construct.NaturalChoice.MinOp as MinOp
-
-module Algebra.Construct.NaturalChoice.Min
-  {a ℓ₁ ℓ₂} (O : TotalOrder a ℓ₁ ℓ₂)
-  where
-
-open TotalOrder O renaming (Carrier to A)
-
-------------------------------------------------------------------------
--- Definition
-
-infixl 7 _⊓_
-
-_⊓_ : Op₂ A
-x ⊓ y with total x y
-... | inj₁ x≤y = x
-... | inj₂ y≤x = y
-
-------------------------------------------------------------------------
--- Properties
-
-x≤y⇒x⊓y≈x : ∀ {x y} → x ≤ y → x ⊓ y ≈ x
-x≤y⇒x⊓y≈x {x} {y} x≤y with total x y
-... | inj₁ _   = Eq.refl
-... | inj₂ y≤x = antisym y≤x x≤y
-
-x≤y⇒y⊓x≈x : ∀ {x y} → x ≤ y → y ⊓ x ≈ x
-x≤y⇒y⊓x≈x {x} {y} x≤y with total y x
-... | inj₁ y≤x = antisym y≤x x≤y
-... | inj₂ _   = Eq.refl
-
-minOperator : MinOperator totalPreorder
-minOperator = record
-  { x≤y⇒x⊓y≈x = x≤y⇒x⊓y≈x
-  ; x≥y⇒x⊓y≈y = x≤y⇒y⊓x≈x
-  }
-
-open MinOp minOperator public
-
\ No newline at end of file diff --git a/Algebra.Construct.NaturalChoice.MinMaxOp.html b/Algebra.Construct.NaturalChoice.MinMaxOp.html index 5bacb02f..bece1941 100644 --- a/Algebra.Construct.NaturalChoice.MinMaxOp.html +++ b/Algebra.Construct.NaturalChoice.MinMaxOp.html @@ -12,135 +12,136 @@ open import Algebra.Bundles open import Algebra.Construct.NaturalChoice.Base open import Data.Sum.Base as Sum using (inj₁; inj₂; [_,_]) -open import Data.Product using (_,_) -open import Function.Base using (id; _∘_; flip) -open import Relation.Binary -open import Relation.Binary.Consequences - -module Algebra.Construct.NaturalChoice.MinMaxOp - {a ℓ₁ ℓ₂} {O : TotalPreorder a ℓ₁ ℓ₂} - (minOp : MinOperator O) - (maxOp : MaxOperator O) - where - -open TotalPreorder O renaming - ( Carrier to A - ; _≲_ to _≤_ - ; ≲-resp-≈ to ≤-resp-≈ - ; ≲-respʳ-≈ to ≤-respʳ-≈ - ; ≲-respˡ-≈ to ≤-respˡ-≈ - ) -open MinOperator minOp -open MaxOperator maxOp - -open import Algebra.Definitions _≈_ -open import Algebra.Structures _≈_ -open import Algebra.Consequences.Setoid Eq.setoid -open import Relation.Binary.Reasoning.Preorder preorder - ------------------------------------------------------------------------- --- Re-export properties of individual operators - -open import Algebra.Construct.NaturalChoice.MinOp minOp public -open import Algebra.Construct.NaturalChoice.MaxOp maxOp public - ------------------------------------------------------------------------- --- Joint algebraic structures - -⊓-distribˡ-⊔ : _⊓_ DistributesOverˡ _⊔_ -⊓-distribˡ-⊔ x y z with total y z -... | inj₁ y≤z = begin-equality - x ⊓ (y ⊔ z) ≈⟨ ⊓-congˡ x (x≤y⇒x⊔y≈y y≤z) ⟩ - x ⊓ z ≈˘⟨ x≤y⇒x⊔y≈y (⊓-monoʳ-≤ x y≤z) ⟩ - (x ⊓ y) ⊔ (x ⊓ z) ∎ -... | inj₂ y≥z = begin-equality - x ⊓ (y ⊔ z) ≈⟨ ⊓-congˡ x (x≥y⇒x⊔y≈x y≥z) ⟩ - x ⊓ y ≈˘⟨ x≥y⇒x⊔y≈x (⊓-monoʳ-≤ x y≥z) ⟩ - (x ⊓ y) ⊔ (x ⊓ z) ∎ - -⊓-distribʳ-⊔ : _⊓_ DistributesOverʳ _⊔_ -⊓-distribʳ-⊔ = comm+distrˡ⇒distrʳ ⊔-cong ⊓-comm ⊓-distribˡ-⊔ - -⊓-distrib-⊔ : _⊓_ DistributesOver _⊔_ -⊓-distrib-⊔ = ⊓-distribˡ-⊔ , ⊓-distribʳ-⊔ - -⊔-distribˡ-⊓ : _⊔_ DistributesOverˡ _⊓_ -⊔-distribˡ-⊓ x y z with total y z -... | inj₁ y≤z = begin-equality - x ⊔ (y ⊓ z) ≈⟨ ⊔-congˡ x (x≤y⇒x⊓y≈x y≤z) ⟩ - x ⊔ y ≈˘⟨ x≤y⇒x⊓y≈x (⊔-monoʳ-≤ x y≤z) ⟩ - (x ⊔ y) ⊓ (x ⊔ z) ∎ -... | inj₂ y≥z = begin-equality - x ⊔ (y ⊓ z) ≈⟨ ⊔-congˡ x (x≥y⇒x⊓y≈y y≥z) ⟩ - x ⊔ z ≈˘⟨ x≥y⇒x⊓y≈y (⊔-monoʳ-≤ x y≥z) ⟩ - (x ⊔ y) ⊓ (x ⊔ z) ∎ - -⊔-distribʳ-⊓ : _⊔_ DistributesOverʳ _⊓_ -⊔-distribʳ-⊓ = comm+distrˡ⇒distrʳ ⊓-cong ⊔-comm ⊔-distribˡ-⊓ - -⊔-distrib-⊓ : _⊔_ DistributesOver _⊓_ -⊔-distrib-⊓ = ⊔-distribˡ-⊓ , ⊔-distribʳ-⊓ - -⊓-absorbs-⊔ : _⊓_ Absorbs _⊔_ -⊓-absorbs-⊔ x y with total x y -... | inj₁ x≤y = begin-equality - x ⊓ (x ⊔ y) ≈⟨ ⊓-congˡ x (x≤y⇒x⊔y≈y x≤y) ⟩ - x ⊓ y ≈⟨ x≤y⇒x⊓y≈x x≤y ⟩ - x ∎ -... | inj₂ y≤x = begin-equality - x ⊓ (x ⊔ y) ≈⟨ ⊓-congˡ x (x≥y⇒x⊔y≈x y≤x) ⟩ - x ⊓ x ≈⟨ ⊓-idem x ⟩ - x ∎ - -⊔-absorbs-⊓ : _⊔_ Absorbs _⊓_ -⊔-absorbs-⊓ x y with total x y -... | inj₁ x≤y = begin-equality - x ⊔ (x ⊓ y) ≈⟨ ⊔-congˡ x (x≤y⇒x⊓y≈x x≤y) ⟩ - x ⊔ x ≈⟨ ⊔-idem x ⟩ - x ∎ -... | inj₂ y≤x = begin-equality - x ⊔ (x ⊓ y) ≈⟨ ⊔-congˡ x (x≥y⇒x⊓y≈y y≤x) ⟩ - x ⊔ y ≈⟨ x≥y⇒x⊔y≈x y≤x ⟩ - x ∎ - -⊔-⊓-absorptive : Absorptive _⊔_ _⊓_ -⊔-⊓-absorptive = ⊔-absorbs-⊓ , ⊓-absorbs-⊔ - -⊓-⊔-absorptive : Absorptive _⊓_ _⊔_ -⊓-⊔-absorptive = ⊓-absorbs-⊔ , ⊔-absorbs-⊓ - ------------------------------------------------------------------------- --- Other joint properties - -private _≥_ = flip _≤_ - -antimono-≤-distrib-⊓ : ∀ {f} → f Preserves _≈_ ⟶ _≈_ → f Preserves _≤_ ⟶ _≥_ → - ∀ x y → f (x ⊓ y) ≈ f x ⊔ f y -antimono-≤-distrib-⊓ {f} cong antimono x y with total x y -... | inj₁ x≤y = begin-equality - f (x ⊓ y) ≈⟨ cong (x≤y⇒x⊓y≈x x≤y) ⟩ - f x ≈˘⟨ x≥y⇒x⊔y≈x (antimono x≤y) ⟩ - f x ⊔ f y ∎ -... | inj₂ y≤x = begin-equality - f (x ⊓ y) ≈⟨ cong (x≥y⇒x⊓y≈y y≤x) ⟩ - f y ≈˘⟨ x≤y⇒x⊔y≈y (antimono y≤x) ⟩ - f x ⊔ f y ∎ - -antimono-≤-distrib-⊔ : ∀ {f} → f Preserves _≈_ ⟶ _≈_ → f Preserves _≤_ ⟶ _≥_ → - ∀ x y → f (x ⊔ y) ≈ f x ⊓ f y -antimono-≤-distrib-⊔ {f} cong antimono x y with total x y -... | inj₁ x≤y = begin-equality - f (x ⊔ y) ≈⟨ cong (x≤y⇒x⊔y≈y x≤y) ⟩ - f y ≈˘⟨ x≥y⇒x⊓y≈y (antimono x≤y) ⟩ - f x ⊓ f y ∎ -... | inj₂ y≤x = begin-equality - f (x ⊔ y) ≈⟨ cong (x≥y⇒x⊔y≈x y≤x) ⟩ - f x ≈˘⟨ x≤y⇒x⊓y≈x (antimono y≤x) ⟩ - f x ⊓ f y ∎ - -x⊓y≤x⊔y : ∀ x y → x ⊓ y ≤ x ⊔ y -x⊓y≤x⊔y x y = begin - x ⊓ y ∼⟨ x⊓y≤x x y ⟩ - x ∼⟨ x≤x⊔y x y ⟩ - x ⊔ y ∎ +open import Data.Product.Base using (_,_) +open import Function.Base using (id; _∘_; flip) +open import Relation.Binary.Core using (_Preserves_⟶_) +open import Relation.Binary.Bundles using (TotalPreorder) +open import Relation.Binary.Consequences + +module Algebra.Construct.NaturalChoice.MinMaxOp + {a ℓ₁ ℓ₂} {O : TotalPreorder a ℓ₁ ℓ₂} + (minOp : MinOperator O) + (maxOp : MaxOperator O) + where + +open TotalPreorder O renaming + ( Carrier to A + ; _≲_ to _≤_ + ; ≲-resp-≈ to ≤-resp-≈ + ; ≲-respʳ-≈ to ≤-respʳ-≈ + ; ≲-respˡ-≈ to ≤-respˡ-≈ + ) +open MinOperator minOp +open MaxOperator maxOp + +open import Algebra.Definitions _≈_ +open import Algebra.Structures _≈_ +open import Algebra.Consequences.Setoid Eq.setoid +open import Relation.Binary.Reasoning.Preorder preorder + +------------------------------------------------------------------------ +-- Re-export properties of individual operators + +open import Algebra.Construct.NaturalChoice.MinOp minOp public +open import Algebra.Construct.NaturalChoice.MaxOp maxOp public + +------------------------------------------------------------------------ +-- Joint algebraic structures + +⊓-distribˡ-⊔ : _⊓_ DistributesOverˡ _⊔_ +⊓-distribˡ-⊔ x y z with total y z +... | inj₁ y≤z = begin-equality + x ⊓ (y ⊔ z) ≈⟨ ⊓-congˡ x (x≤y⇒x⊔y≈y y≤z) ⟩ + x ⊓ z ≈⟨ x≤y⇒x⊔y≈y (⊓-monoʳ-≤ x y≤z) ⟨ + (x ⊓ y) ⊔ (x ⊓ z) ∎ +... | inj₂ y≥z = begin-equality + x ⊓ (y ⊔ z) ≈⟨ ⊓-congˡ x (x≥y⇒x⊔y≈x y≥z) ⟩ + x ⊓ y ≈⟨ x≥y⇒x⊔y≈x (⊓-monoʳ-≤ x y≥z) ⟨ + (x ⊓ y) ⊔ (x ⊓ z) ∎ + +⊓-distribʳ-⊔ : _⊓_ DistributesOverʳ _⊔_ +⊓-distribʳ-⊔ = comm+distrˡ⇒distrʳ ⊔-cong ⊓-comm ⊓-distribˡ-⊔ + +⊓-distrib-⊔ : _⊓_ DistributesOver _⊔_ +⊓-distrib-⊔ = ⊓-distribˡ-⊔ , ⊓-distribʳ-⊔ + +⊔-distribˡ-⊓ : _⊔_ DistributesOverˡ _⊓_ +⊔-distribˡ-⊓ x y z with total y z +... | inj₁ y≤z = begin-equality + x ⊔ (y ⊓ z) ≈⟨ ⊔-congˡ x (x≤y⇒x⊓y≈x y≤z) ⟩ + x ⊔ y ≈⟨ x≤y⇒x⊓y≈x (⊔-monoʳ-≤ x y≤z) ⟨ + (x ⊔ y) ⊓ (x ⊔ z) ∎ +... | inj₂ y≥z = begin-equality + x ⊔ (y ⊓ z) ≈⟨ ⊔-congˡ x (x≥y⇒x⊓y≈y y≥z) ⟩ + x ⊔ z ≈⟨ x≥y⇒x⊓y≈y (⊔-monoʳ-≤ x y≥z) ⟨ + (x ⊔ y) ⊓ (x ⊔ z) ∎ + +⊔-distribʳ-⊓ : _⊔_ DistributesOverʳ _⊓_ +⊔-distribʳ-⊓ = comm+distrˡ⇒distrʳ ⊓-cong ⊔-comm ⊔-distribˡ-⊓ + +⊔-distrib-⊓ : _⊔_ DistributesOver _⊓_ +⊔-distrib-⊓ = ⊔-distribˡ-⊓ , ⊔-distribʳ-⊓ + +⊓-absorbs-⊔ : _⊓_ Absorbs _⊔_ +⊓-absorbs-⊔ x y with total x y +... | inj₁ x≤y = begin-equality + x ⊓ (x ⊔ y) ≈⟨ ⊓-congˡ x (x≤y⇒x⊔y≈y x≤y) ⟩ + x ⊓ y ≈⟨ x≤y⇒x⊓y≈x x≤y ⟩ + x ∎ +... | inj₂ y≤x = begin-equality + x ⊓ (x ⊔ y) ≈⟨ ⊓-congˡ x (x≥y⇒x⊔y≈x y≤x) ⟩ + x ⊓ x ≈⟨ ⊓-idem x ⟩ + x ∎ + +⊔-absorbs-⊓ : _⊔_ Absorbs _⊓_ +⊔-absorbs-⊓ x y with total x y +... | inj₁ x≤y = begin-equality + x ⊔ (x ⊓ y) ≈⟨ ⊔-congˡ x (x≤y⇒x⊓y≈x x≤y) ⟩ + x ⊔ x ≈⟨ ⊔-idem x ⟩ + x ∎ +... | inj₂ y≤x = begin-equality + x ⊔ (x ⊓ y) ≈⟨ ⊔-congˡ x (x≥y⇒x⊓y≈y y≤x) ⟩ + x ⊔ y ≈⟨ x≥y⇒x⊔y≈x y≤x ⟩ + x ∎ + +⊔-⊓-absorptive : Absorptive _⊔_ _⊓_ +⊔-⊓-absorptive = ⊔-absorbs-⊓ , ⊓-absorbs-⊔ + +⊓-⊔-absorptive : Absorptive _⊓_ _⊔_ +⊓-⊔-absorptive = ⊓-absorbs-⊔ , ⊔-absorbs-⊓ + +------------------------------------------------------------------------ +-- Other joint properties + +private _≥_ = flip _≤_ + +antimono-≤-distrib-⊓ : ∀ {f} → f Preserves _≈_ ⟶ _≈_ → f Preserves _≤_ ⟶ _≥_ → + ∀ x y → f (x ⊓ y) ≈ f x ⊔ f y +antimono-≤-distrib-⊓ {f} cong antimono x y with total x y +... | inj₁ x≤y = begin-equality + f (x ⊓ y) ≈⟨ cong (x≤y⇒x⊓y≈x x≤y) ⟩ + f x ≈⟨ x≥y⇒x⊔y≈x (antimono x≤y) ⟨ + f x ⊔ f y ∎ +... | inj₂ y≤x = begin-equality + f (x ⊓ y) ≈⟨ cong (x≥y⇒x⊓y≈y y≤x) ⟩ + f y ≈⟨ x≤y⇒x⊔y≈y (antimono y≤x) ⟨ + f x ⊔ f y ∎ + +antimono-≤-distrib-⊔ : ∀ {f} → f Preserves _≈_ ⟶ _≈_ → f Preserves _≤_ ⟶ _≥_ → + ∀ x y → f (x ⊔ y) ≈ f x ⊓ f y +antimono-≤-distrib-⊔ {f} cong antimono x y with total x y +... | inj₁ x≤y = begin-equality + f (x ⊔ y) ≈⟨ cong (x≤y⇒x⊔y≈y x≤y) ⟩ + f y ≈⟨ x≥y⇒x⊓y≈y (antimono x≤y) ⟨ + f x ⊓ f y ∎ +... | inj₂ y≤x = begin-equality + f (x ⊔ y) ≈⟨ cong (x≥y⇒x⊔y≈x y≤x) ⟩ + f x ≈⟨ x≤y⇒x⊓y≈x (antimono y≤x) ⟨ + f x ⊓ f y ∎ + +x⊓y≤x⊔y : ∀ x y → x ⊓ y ≤ x ⊔ y +x⊓y≤x⊔y x y = begin + x ⊓ y ∼⟨ x⊓y≤x x y ⟩ + x ∼⟨ x≤x⊔y x y ⟩ + x ⊔ y ∎ \ No newline at end of file diff --git a/Algebra.Construct.NaturalChoice.MinOp.html b/Algebra.Construct.NaturalChoice.MinOp.html index 6859951c..8656fcdd 100644 --- a/Algebra.Construct.NaturalChoice.MinOp.html +++ b/Algebra.Construct.NaturalChoice.MinOp.html @@ -12,246 +12,248 @@ open import Algebra.Bundles open import Algebra.Construct.NaturalChoice.Base open import Data.Sum.Base as Sum using (inj₁; inj₂; [_,_]) -open import Data.Product using (_,_) -open import Function.Base using (id; _∘_) -open import Relation.Binary -open import Relation.Binary.Consequences - -module Algebra.Construct.NaturalChoice.MinOp - {a ℓ₁ ℓ₂} {O : TotalPreorder a ℓ₁ ℓ₂} (minOp : MinOperator O) where - -open TotalPreorder O renaming - ( Carrier to A - ; _≲_ to _≤_ - ; ≲-resp-≈ to ≤-resp-≈ - ; ≲-respʳ-≈ to ≤-respʳ-≈ - ; ≲-respˡ-≈ to ≤-respˡ-≈ - ) -open MinOperator minOp - -open import Algebra.Definitions _≈_ -open import Algebra.Structures _≈_ -open import Relation.Binary.Reasoning.Preorder preorder - ------------------------------------------------------------------------- --- Helpful properties - -x⊓y≤x : ∀ x y → x ⊓ y ≤ x -x⊓y≤x x y with total x y -... | inj₁ x≤y = ≤-respˡ-≈ (Eq.sym (x≤y⇒x⊓y≈x x≤y)) refl -... | inj₂ y≤x = ≤-respˡ-≈ (Eq.sym (x≥y⇒x⊓y≈y y≤x)) y≤x - -x⊓y≤y : ∀ x y → x ⊓ y ≤ y -x⊓y≤y x y with total x y -... | inj₁ x≤y = ≤-respˡ-≈ (Eq.sym (x≤y⇒x⊓y≈x x≤y)) x≤y -... | inj₂ y≤x = ≤-respˡ-≈ (Eq.sym (x≥y⇒x⊓y≈y y≤x)) refl - ------------------------------------------------------------------------- --- Algebraic properties - -⊓-comm : Commutative _⊓_ -⊓-comm x y with total x y -... | inj₁ x≤y = Eq.trans (x≤y⇒x⊓y≈x x≤y) (Eq.sym (x≥y⇒x⊓y≈y x≤y)) -... | inj₂ y≤x = Eq.trans (x≥y⇒x⊓y≈y y≤x) (Eq.sym (x≤y⇒x⊓y≈x y≤x)) - -⊓-congˡ : ∀ x → Congruent₁ (x ⊓_) -⊓-congˡ x {y} {r} y≈r with total x y -... | inj₁ x≤y = begin-equality - x ⊓ y ≈⟨ x≤y⇒x⊓y≈x x≤y ⟩ - x ≈˘⟨ x≤y⇒x⊓y≈x (≤-respʳ-≈ y≈r x≤y) ⟩ - x ⊓ r ∎ -... | inj₂ y≤x = begin-equality - x ⊓ y ≈⟨ x≥y⇒x⊓y≈y y≤x ⟩ - y ≈⟨ y≈r ⟩ - r ≈˘⟨ x≥y⇒x⊓y≈y (≤-respˡ-≈ y≈r y≤x) ⟩ - x ⊓ r ∎ - -⊓-congʳ : ∀ x → Congruent₁ (_⊓ x) -⊓-congʳ x {y₁} {y₂} y₁≈y₂ = begin-equality - y₁ ⊓ x ≈˘⟨ ⊓-comm x y₁ ⟩ - x ⊓ y₁ ≈⟨ ⊓-congˡ x y₁≈y₂ ⟩ - x ⊓ y₂ ≈⟨ ⊓-comm x y₂ ⟩ - y₂ ⊓ x ∎ - -⊓-cong : Congruent₂ _⊓_ -⊓-cong {x₁} {x₂} {y₁} {y₂} x₁≈x₂ y₁≈y₂ = Eq.trans (⊓-congˡ x₁ y₁≈y₂) (⊓-congʳ y₂ x₁≈x₂) - -⊓-assoc : Associative _⊓_ -⊓-assoc x y r with total x y | total y r -⊓-assoc x y r | inj₁ x≤y | inj₁ y≤r = begin-equality - (x ⊓ y) ⊓ r ≈⟨ ⊓-congʳ r (x≤y⇒x⊓y≈x x≤y) ⟩ - x ⊓ r ≈⟨ x≤y⇒x⊓y≈x (trans x≤y y≤r) ⟩ - x ≈˘⟨ x≤y⇒x⊓y≈x x≤y ⟩ - x ⊓ y ≈˘⟨ ⊓-congˡ x (x≤y⇒x⊓y≈x y≤r) ⟩ - x ⊓ (y ⊓ r) ∎ -⊓-assoc x y r | inj₁ x≤y | inj₂ r≤y = begin-equality - (x ⊓ y) ⊓ r ≈⟨ ⊓-congʳ r (x≤y⇒x⊓y≈x x≤y) ⟩ - x ⊓ r ≈˘⟨ ⊓-congˡ x (x≥y⇒x⊓y≈y r≤y) ⟩ - x ⊓ (y ⊓ r) ∎ -⊓-assoc x y r | inj₂ y≤x | _ = begin-equality - (x ⊓ y) ⊓ r ≈⟨ ⊓-congʳ r (x≥y⇒x⊓y≈y y≤x) ⟩ - y ⊓ r ≈˘⟨ x≥y⇒x⊓y≈y (trans (x⊓y≤x y r) y≤x) ⟩ - x ⊓ (y ⊓ r) ∎ - -⊓-idem : Idempotent _⊓_ -⊓-idem x = x≤y⇒x⊓y≈x (refl {x}) - -⊓-sel : Selective _⊓_ -⊓-sel x y = Sum.map x≤y⇒x⊓y≈x x≥y⇒x⊓y≈y (total x y) - -⊓-identityˡ : ∀ {⊤} → Maximum _≤_ ⊤ → LeftIdentity ⊤ _⊓_ -⊓-identityˡ max = x≥y⇒x⊓y≈y ∘ max - -⊓-identityʳ : ∀ {⊤} → Maximum _≤_ ⊤ → RightIdentity ⊤ _⊓_ -⊓-identityʳ max = x≤y⇒x⊓y≈x ∘ max - -⊓-identity : ∀ {⊤} → Maximum _≤_ ⊤ → Identity ⊤ _⊓_ -⊓-identity max = ⊓-identityˡ max , ⊓-identityʳ max - -⊓-zeroˡ : ∀ {⊥} → Minimum _≤_ ⊥ → LeftZero ⊥ _⊓_ -⊓-zeroˡ min = x≤y⇒x⊓y≈x ∘ min - -⊓-zeroʳ : ∀ {⊥} → Minimum _≤_ ⊥ → RightZero ⊥ _⊓_ -⊓-zeroʳ min = x≥y⇒x⊓y≈y ∘ min - -⊓-zero : ∀ {⊥} → Minimum _≤_ ⊥ → Zero ⊥ _⊓_ -⊓-zero min = ⊓-zeroˡ min , ⊓-zeroʳ min - ------------------------------------------------------------------------- --- Structures - -⊓-isMagma : IsMagma _⊓_ -⊓-isMagma = record - { isEquivalence = isEquivalence - ; ∙-cong = ⊓-cong - } - -⊓-isSemigroup : IsSemigroup _⊓_ -⊓-isSemigroup = record - { isMagma = ⊓-isMagma - ; assoc = ⊓-assoc - } - -⊓-isBand : IsBand _⊓_ -⊓-isBand = record - { isSemigroup = ⊓-isSemigroup - ; idem = ⊓-idem - } - -⊓-isCommutativeSemigroup : IsCommutativeSemigroup _⊓_ -⊓-isCommutativeSemigroup = record - { isSemigroup = ⊓-isSemigroup - ; comm = ⊓-comm - } - -⊓-isSelectiveMagma : IsSelectiveMagma _⊓_ -⊓-isSelectiveMagma = record - { isMagma = ⊓-isMagma - ; sel = ⊓-sel - } - -⊓-isMonoid : ∀ {⊤} → Maximum _≤_ ⊤ → IsMonoid _⊓_ ⊤ -⊓-isMonoid max = record - { isSemigroup = ⊓-isSemigroup - ; identity = ⊓-identity max - } - ------------------------------------------------------------------------- --- Raw bundles - -⊓-rawMagma : RawMagma _ _ -⊓-rawMagma = record { _≈_ = _≈_ ; _∙_ = _⊓_ } - ------------------------------------------------------------------------- --- Bundles - -⊓-magma : Magma _ _ -⊓-magma = record - { isMagma = ⊓-isMagma - } - -⊓-semigroup : Semigroup _ _ -⊓-semigroup = record - { isSemigroup = ⊓-isSemigroup - } - -⊓-band : Band _ _ -⊓-band = record - { isBand = ⊓-isBand - } - -⊓-commutativeSemigroup : CommutativeSemigroup _ _ -⊓-commutativeSemigroup = record - { isCommutativeSemigroup = ⊓-isCommutativeSemigroup - } - -⊓-selectiveMagma : SelectiveMagma _ _ -⊓-selectiveMagma = record - { isSelectiveMagma = ⊓-isSelectiveMagma - } - -⊓-monoid : ∀ {⊤} → Maximum _≤_ ⊤ → Monoid a ℓ₁ -⊓-monoid max = record - { isMonoid = ⊓-isMonoid max - } - ------------------------------------------------------------------------- --- Other properties - -x⊓y≈x⇒x≤y : ∀ {x y} → x ⊓ y ≈ x → x ≤ y -x⊓y≈x⇒x≤y {x} {y} x⊓y≈x with total x y -... | inj₁ x≤y = x≤y -... | inj₂ y≤x = reflexive (Eq.trans (Eq.sym x⊓y≈x) (x≥y⇒x⊓y≈y y≤x)) - -x⊓y≈y⇒y≤x : ∀ {x y} → x ⊓ y ≈ y → y ≤ x -x⊓y≈y⇒y≤x {x} {y} x⊓y≈y = x⊓y≈x⇒x≤y (begin-equality - y ⊓ x ≈⟨ ⊓-comm y x ⟩ - x ⊓ y ≈⟨ x⊓y≈y ⟩ - y ∎) - -mono-≤-distrib-⊓ : ∀ {f} → f Preserves _≈_ ⟶ _≈_ → f Preserves _≤_ ⟶ _≤_ → - ∀ x y → f (x ⊓ y) ≈ f x ⊓ f y -mono-≤-distrib-⊓ {f} cong mono x y with total x y -... | inj₁ x≤y = begin-equality - f (x ⊓ y) ≈⟨ cong (x≤y⇒x⊓y≈x x≤y) ⟩ - f x ≈˘⟨ x≤y⇒x⊓y≈x (mono x≤y) ⟩ - f x ⊓ f y ∎ -... | inj₂ y≤x = begin-equality - f (x ⊓ y) ≈⟨ cong (x≥y⇒x⊓y≈y y≤x) ⟩ - f y ≈˘⟨ x≥y⇒x⊓y≈y (mono y≤x) ⟩ - f x ⊓ f y ∎ - -x≤y⇒x⊓z≤y : ∀ {x y} z → x ≤ y → x ⊓ z ≤ y -x≤y⇒x⊓z≤y z x≤y = trans (x⊓y≤x _ z) x≤y - -x≤y⇒z⊓x≤y : ∀ {x y} z → x ≤ y → z ⊓ x ≤ y -x≤y⇒z⊓x≤y y x≤y = trans (x⊓y≤y y _) x≤y - -x≤y⊓z⇒x≤y : ∀ {x} y z → x ≤ y ⊓ z → x ≤ y -x≤y⊓z⇒x≤y y z x≤y⊓z = trans x≤y⊓z (x⊓y≤x y z) - -x≤y⊓z⇒x≤z : ∀ {x} y z → x ≤ y ⊓ z → x ≤ z -x≤y⊓z⇒x≤z y z x≤y⊓z = trans x≤y⊓z (x⊓y≤y y z) - -⊓-mono-≤ : _⊓_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ -⊓-mono-≤ {x} {y} {u} {v} x≤y u≤v with ⊓-sel y v -... | inj₁ y⊓v≈y = ≤-respʳ-≈ (Eq.sym y⊓v≈y) (trans (x⊓y≤x x u) x≤y) -... | inj₂ y⊓v≈v = ≤-respʳ-≈ (Eq.sym y⊓v≈v) (trans (x⊓y≤y x u) u≤v) - -⊓-monoˡ-≤ : ∀ x → (_⊓ x) Preserves _≤_ ⟶ _≤_ -⊓-monoˡ-≤ x y≤z = ⊓-mono-≤ y≤z (refl {x}) - -⊓-monoʳ-≤ : ∀ x → (x ⊓_) Preserves _≤_ ⟶ _≤_ -⊓-monoʳ-≤ x y≤z = ⊓-mono-≤ (refl {x}) y≤z - -⊓-glb : ∀ {x y z} → x ≤ y → x ≤ z → x ≤ y ⊓ z -⊓-glb {x} x≤y x≤z = ≤-respˡ-≈ (⊓-idem x) (⊓-mono-≤ x≤y x≤z) - -⊓-triangulate : ∀ x y z → x ⊓ y ⊓ z ≈ (x ⊓ y) ⊓ (y ⊓ z) -⊓-triangulate x y z = begin-equality - x ⊓ y ⊓ z ≈˘⟨ ⊓-congʳ z (⊓-congˡ x (⊓-idem y)) ⟩ - x ⊓ (y ⊓ y) ⊓ z ≈⟨ ⊓-assoc x _ _ ⟩ - x ⊓ ((y ⊓ y) ⊓ z) ≈⟨ ⊓-congˡ x (⊓-assoc y y z) ⟩ - x ⊓ (y ⊓ (y ⊓ z)) ≈˘⟨ ⊓-assoc x y (y ⊓ z) ⟩ - (x ⊓ y) ⊓ (y ⊓ z) ∎ +open import Data.Product.Base using (_,_) +open import Function.Base using (id; _∘_) +open import Relation.Binary.Core using (_Preserves_⟶_; _Preserves₂_⟶_⟶_) +open import Relation.Binary.Bundles using (TotalPreorder) +open import Relation.Binary.Definitions using (Maximum; Minimum) +open import Relation.Binary.Consequences + +module Algebra.Construct.NaturalChoice.MinOp + {a ℓ₁ ℓ₂} {O : TotalPreorder a ℓ₁ ℓ₂} (minOp : MinOperator O) where + +open TotalPreorder O renaming + ( Carrier to A + ; _≲_ to _≤_ + ; ≲-resp-≈ to ≤-resp-≈ + ; ≲-respʳ-≈ to ≤-respʳ-≈ + ; ≲-respˡ-≈ to ≤-respˡ-≈ + ) +open MinOperator minOp + +open import Algebra.Definitions _≈_ +open import Algebra.Structures _≈_ +open import Relation.Binary.Reasoning.Preorder preorder + +------------------------------------------------------------------------ +-- Helpful properties + +x⊓y≤x : ∀ x y → x ⊓ y ≤ x +x⊓y≤x x y with total x y +... | inj₁ x≤y = ≤-respˡ-≈ (Eq.sym (x≤y⇒x⊓y≈x x≤y)) refl +... | inj₂ y≤x = ≤-respˡ-≈ (Eq.sym (x≥y⇒x⊓y≈y y≤x)) y≤x + +x⊓y≤y : ∀ x y → x ⊓ y ≤ y +x⊓y≤y x y with total x y +... | inj₁ x≤y = ≤-respˡ-≈ (Eq.sym (x≤y⇒x⊓y≈x x≤y)) x≤y +... | inj₂ y≤x = ≤-respˡ-≈ (Eq.sym (x≥y⇒x⊓y≈y y≤x)) refl + +------------------------------------------------------------------------ +-- Algebraic properties + +⊓-comm : Commutative _⊓_ +⊓-comm x y with total x y +... | inj₁ x≤y = Eq.trans (x≤y⇒x⊓y≈x x≤y) (Eq.sym (x≥y⇒x⊓y≈y x≤y)) +... | inj₂ y≤x = Eq.trans (x≥y⇒x⊓y≈y y≤x) (Eq.sym (x≤y⇒x⊓y≈x y≤x)) + +⊓-congˡ : ∀ x → Congruent₁ (x ⊓_) +⊓-congˡ x {y} {r} y≈r with total x y +... | inj₁ x≤y = begin-equality + x ⊓ y ≈⟨ x≤y⇒x⊓y≈x x≤y ⟩ + x ≈⟨ x≤y⇒x⊓y≈x (≤-respʳ-≈ y≈r x≤y) ⟨ + x ⊓ r ∎ +... | inj₂ y≤x = begin-equality + x ⊓ y ≈⟨ x≥y⇒x⊓y≈y y≤x ⟩ + y ≈⟨ y≈r ⟩ + r ≈⟨ x≥y⇒x⊓y≈y (≤-respˡ-≈ y≈r y≤x) ⟨ + x ⊓ r ∎ + +⊓-congʳ : ∀ x → Congruent₁ (_⊓ x) +⊓-congʳ x {y₁} {y₂} y₁≈y₂ = begin-equality + y₁ ⊓ x ≈⟨ ⊓-comm x y₁ ⟨ + x ⊓ y₁ ≈⟨ ⊓-congˡ x y₁≈y₂ ⟩ + x ⊓ y₂ ≈⟨ ⊓-comm x y₂ ⟩ + y₂ ⊓ x ∎ + +⊓-cong : Congruent₂ _⊓_ +⊓-cong {x₁} {x₂} {y₁} {y₂} x₁≈x₂ y₁≈y₂ = Eq.trans (⊓-congˡ x₁ y₁≈y₂) (⊓-congʳ y₂ x₁≈x₂) + +⊓-assoc : Associative _⊓_ +⊓-assoc x y r with total x y | total y r +⊓-assoc x y r | inj₁ x≤y | inj₁ y≤r = begin-equality + (x ⊓ y) ⊓ r ≈⟨ ⊓-congʳ r (x≤y⇒x⊓y≈x x≤y) ⟩ + x ⊓ r ≈⟨ x≤y⇒x⊓y≈x (trans x≤y y≤r) ⟩ + x ≈⟨ x≤y⇒x⊓y≈x x≤y ⟨ + x ⊓ y ≈⟨ ⊓-congˡ x (x≤y⇒x⊓y≈x y≤r) ⟨ + x ⊓ (y ⊓ r) ∎ +⊓-assoc x y r | inj₁ x≤y | inj₂ r≤y = begin-equality + (x ⊓ y) ⊓ r ≈⟨ ⊓-congʳ r (x≤y⇒x⊓y≈x x≤y) ⟩ + x ⊓ r ≈⟨ ⊓-congˡ x (x≥y⇒x⊓y≈y r≤y) ⟨ + x ⊓ (y ⊓ r) ∎ +⊓-assoc x y r | inj₂ y≤x | _ = begin-equality + (x ⊓ y) ⊓ r ≈⟨ ⊓-congʳ r (x≥y⇒x⊓y≈y y≤x) ⟩ + y ⊓ r ≈⟨ x≥y⇒x⊓y≈y (trans (x⊓y≤x y r) y≤x) ⟨ + x ⊓ (y ⊓ r) ∎ + +⊓-idem : Idempotent _⊓_ +⊓-idem x = x≤y⇒x⊓y≈x (refl {x}) + +⊓-sel : Selective _⊓_ +⊓-sel x y = Sum.map x≤y⇒x⊓y≈x x≥y⇒x⊓y≈y (total x y) + +⊓-identityˡ : ∀ {⊤} → Maximum _≤_ ⊤ → LeftIdentity ⊤ _⊓_ +⊓-identityˡ max = x≥y⇒x⊓y≈y ∘ max + +⊓-identityʳ : ∀ {⊤} → Maximum _≤_ ⊤ → RightIdentity ⊤ _⊓_ +⊓-identityʳ max = x≤y⇒x⊓y≈x ∘ max + +⊓-identity : ∀ {⊤} → Maximum _≤_ ⊤ → Identity ⊤ _⊓_ +⊓-identity max = ⊓-identityˡ max , ⊓-identityʳ max + +⊓-zeroˡ : ∀ {⊥} → Minimum _≤_ ⊥ → LeftZero ⊥ _⊓_ +⊓-zeroˡ min = x≤y⇒x⊓y≈x ∘ min + +⊓-zeroʳ : ∀ {⊥} → Minimum _≤_ ⊥ → RightZero ⊥ _⊓_ +⊓-zeroʳ min = x≥y⇒x⊓y≈y ∘ min + +⊓-zero : ∀ {⊥} → Minimum _≤_ ⊥ → Zero ⊥ _⊓_ +⊓-zero min = ⊓-zeroˡ min , ⊓-zeroʳ min + +------------------------------------------------------------------------ +-- Structures + +⊓-isMagma : IsMagma _⊓_ +⊓-isMagma = record + { isEquivalence = isEquivalence + ; ∙-cong = ⊓-cong + } + +⊓-isSemigroup : IsSemigroup _⊓_ +⊓-isSemigroup = record + { isMagma = ⊓-isMagma + ; assoc = ⊓-assoc + } + +⊓-isBand : IsBand _⊓_ +⊓-isBand = record + { isSemigroup = ⊓-isSemigroup + ; idem = ⊓-idem + } + +⊓-isCommutativeSemigroup : IsCommutativeSemigroup _⊓_ +⊓-isCommutativeSemigroup = record + { isSemigroup = ⊓-isSemigroup + ; comm = ⊓-comm + } + +⊓-isSelectiveMagma : IsSelectiveMagma _⊓_ +⊓-isSelectiveMagma = record + { isMagma = ⊓-isMagma + ; sel = ⊓-sel + } + +⊓-isMonoid : ∀ {⊤} → Maximum _≤_ ⊤ → IsMonoid _⊓_ ⊤ +⊓-isMonoid max = record + { isSemigroup = ⊓-isSemigroup + ; identity = ⊓-identity max + } + +------------------------------------------------------------------------ +-- Raw bundles + +⊓-rawMagma : RawMagma _ _ +⊓-rawMagma = record { _≈_ = _≈_ ; _∙_ = _⊓_ } + +------------------------------------------------------------------------ +-- Bundles + +⊓-magma : Magma _ _ +⊓-magma = record + { isMagma = ⊓-isMagma + } + +⊓-semigroup : Semigroup _ _ +⊓-semigroup = record + { isSemigroup = ⊓-isSemigroup + } + +⊓-band : Band _ _ +⊓-band = record + { isBand = ⊓-isBand + } + +⊓-commutativeSemigroup : CommutativeSemigroup _ _ +⊓-commutativeSemigroup = record + { isCommutativeSemigroup = ⊓-isCommutativeSemigroup + } + +⊓-selectiveMagma : SelectiveMagma _ _ +⊓-selectiveMagma = record + { isSelectiveMagma = ⊓-isSelectiveMagma + } + +⊓-monoid : ∀ {⊤} → Maximum _≤_ ⊤ → Monoid a ℓ₁ +⊓-monoid max = record + { isMonoid = ⊓-isMonoid max + } + +------------------------------------------------------------------------ +-- Other properties + +x⊓y≈x⇒x≤y : ∀ {x y} → x ⊓ y ≈ x → x ≤ y +x⊓y≈x⇒x≤y {x} {y} x⊓y≈x with total x y +... | inj₁ x≤y = x≤y +... | inj₂ y≤x = reflexive (Eq.trans (Eq.sym x⊓y≈x) (x≥y⇒x⊓y≈y y≤x)) + +x⊓y≈y⇒y≤x : ∀ {x y} → x ⊓ y ≈ y → y ≤ x +x⊓y≈y⇒y≤x {x} {y} x⊓y≈y = x⊓y≈x⇒x≤y (begin-equality + y ⊓ x ≈⟨ ⊓-comm y x ⟩ + x ⊓ y ≈⟨ x⊓y≈y ⟩ + y ∎) + +mono-≤-distrib-⊓ : ∀ {f} → f Preserves _≈_ ⟶ _≈_ → f Preserves _≤_ ⟶ _≤_ → + ∀ x y → f (x ⊓ y) ≈ f x ⊓ f y +mono-≤-distrib-⊓ {f} cong mono x y with total x y +... | inj₁ x≤y = begin-equality + f (x ⊓ y) ≈⟨ cong (x≤y⇒x⊓y≈x x≤y) ⟩ + f x ≈⟨ x≤y⇒x⊓y≈x (mono x≤y) ⟨ + f x ⊓ f y ∎ +... | inj₂ y≤x = begin-equality + f (x ⊓ y) ≈⟨ cong (x≥y⇒x⊓y≈y y≤x) ⟩ + f y ≈⟨ x≥y⇒x⊓y≈y (mono y≤x) ⟨ + f x ⊓ f y ∎ + +x≤y⇒x⊓z≤y : ∀ {x y} z → x ≤ y → x ⊓ z ≤ y +x≤y⇒x⊓z≤y z x≤y = trans (x⊓y≤x _ z) x≤y + +x≤y⇒z⊓x≤y : ∀ {x y} z → x ≤ y → z ⊓ x ≤ y +x≤y⇒z⊓x≤y y x≤y = trans (x⊓y≤y y _) x≤y + +x≤y⊓z⇒x≤y : ∀ {x} y z → x ≤ y ⊓ z → x ≤ y +x≤y⊓z⇒x≤y y z x≤y⊓z = trans x≤y⊓z (x⊓y≤x y z) + +x≤y⊓z⇒x≤z : ∀ {x} y z → x ≤ y ⊓ z → x ≤ z +x≤y⊓z⇒x≤z y z x≤y⊓z = trans x≤y⊓z (x⊓y≤y y z) + +⊓-mono-≤ : _⊓_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ +⊓-mono-≤ {x} {y} {u} {v} x≤y u≤v with ⊓-sel y v +... | inj₁ y⊓v≈y = ≤-respʳ-≈ (Eq.sym y⊓v≈y) (trans (x⊓y≤x x u) x≤y) +... | inj₂ y⊓v≈v = ≤-respʳ-≈ (Eq.sym y⊓v≈v) (trans (x⊓y≤y x u) u≤v) + +⊓-monoˡ-≤ : ∀ x → (_⊓ x) Preserves _≤_ ⟶ _≤_ +⊓-monoˡ-≤ x y≤z = ⊓-mono-≤ y≤z (refl {x}) + +⊓-monoʳ-≤ : ∀ x → (x ⊓_) Preserves _≤_ ⟶ _≤_ +⊓-monoʳ-≤ x y≤z = ⊓-mono-≤ (refl {x}) y≤z + +⊓-glb : ∀ {x y z} → x ≤ y → x ≤ z → x ≤ y ⊓ z +⊓-glb {x} x≤y x≤z = ≤-respˡ-≈ (⊓-idem x) (⊓-mono-≤ x≤y x≤z) + +⊓-triangulate : ∀ x y z → x ⊓ y ⊓ z ≈ (x ⊓ y) ⊓ (y ⊓ z) +⊓-triangulate x y z = begin-equality + x ⊓ y ⊓ z ≈⟨ ⊓-congʳ z (⊓-congˡ x (⊓-idem y)) ⟨ + x ⊓ (y ⊓ y) ⊓ z ≈⟨ ⊓-assoc x _ _ ⟩ + x ⊓ ((y ⊓ y) ⊓ z) ≈⟨ ⊓-congˡ x (⊓-assoc y y z) ⟩ + x ⊓ (y ⊓ (y ⊓ z)) ≈⟨ ⊓-assoc x y (y ⊓ z) ⟨ + (x ⊓ y) ⊓ (y ⊓ z) ∎ \ No newline at end of file diff --git a/Algebra.Cost.Bundles.html b/Algebra.Cost.Bundles.html index 09e9f491..64b7c045 100644 --- a/Algebra.Cost.Bundles.html +++ b/Algebra.Cost.Bundles.html @@ -5,70 +5,66 @@ open import Algebra.Core open import Algebra.Cost.Structures -open import Relation.Binary using (Rel; _Preserves_⟶_; _Preserves₂_⟶_⟶_) -open import Relation.Binary.PropositionalEquality using (_≡_; resp₂) -open import Level using (0ℓ) +open import Relation.Binary using (Rel; Preorder; _Preserves_⟶_; _Preserves₂_⟶_⟶_) +open import Relation.Binary.PropositionalEquality using (_≡_; resp₂) +open import Level using (0ℓ) -record CostMonoid : Set₁ where - infixl 6 _+_ +record CostMonoid : Set₁ where + infixl 6 _+_ - field - ℂ : Set - zero : ℂ - _+_ : Op₂ ℂ - _≤_ : Rel ℂ 0ℓ - isCostMonoid : IsCostMonoid ℂ zero _+_ _≤_ + field + ℂ : Set + zero : ℂ + _+_ : Op₂ ℂ + _≤_ : Rel ℂ 0ℓ + isCostMonoid : IsCostMonoid ℂ zero _+_ _≤_ - open IsCostMonoid isCostMonoid public + open IsCostMonoid isCostMonoid public - module ≤-Reasoning where - open import Relation.Binary.Reasoning.Base.Triple - isPreorder - ≤-trans - (resp₂ _≤_) - (λ h → h) - ≤-trans - ≤-trans - public - hiding (step-≈; step-≈˘; step-<) + ≤-preorder : Preorder 0ℓ 0ℓ 0ℓ + Preorder.Carrier ≤-preorder = ℂ + Preorder._≈_ ≤-preorder = _≡_ + Preorder._≲_ ≤-preorder = _≤_ + Preorder.isPreorder ≤-preorder = isPreorder + module ≤-Reasoning where + open import Relation.Binary.Reasoning.Preorder ≤-preorder public -record ParCostMonoid : Set₁ where - infixl 7 _⊗_ - infixl 6 _⊕_ - field - ℂ : Set - 𝟘 : ℂ - _⊕_ : Op₂ ℂ - _⊗_ : Op₂ ℂ - _≤_ : Rel ℂ 0ℓ - isParCostMonoid : IsParCostMonoid ℂ 𝟘 _⊕_ _⊗_ _≤_ +record ParCostMonoid : Set₁ where + infixl 7 _⊗_ + infixl 6 _⊕_ - open IsParCostMonoid isParCostMonoid public + field + ℂ : Set + 𝟘 : ℂ + _⊕_ : Op₂ ℂ + _⊗_ : Op₂ ℂ + _≤_ : Rel ℂ 0ℓ + isParCostMonoid : IsParCostMonoid ℂ 𝟘 _⊕_ _⊗_ _≤_ - costMonoid : CostMonoid - costMonoid = record - { ℂ = ℂ - ; _+_ = _⊕_ - ; zero = 𝟘 - ; _≤_ = _≤_ - ; isCostMonoid = record - { isMonoid = isMonoid - ; isPreorder = isPreorder - ; isMonotone = isMonotone-⊕ - } - } + open IsParCostMonoid isParCostMonoid public - module ≤-Reasoning where - open import Relation.Binary.Reasoning.Base.Triple - isPreorder - ≤-trans - (resp₂ _≤_) - (λ h → h) - ≤-trans - ≤-trans - public - hiding (step-≈; step-≈˘; step-<) + costMonoid : CostMonoid + costMonoid = record + { ℂ = ℂ + ; _+_ = _⊕_ + ; zero = 𝟘 + ; _≤_ = _≤_ + ; isCostMonoid = record + { isMonoid = isMonoid + ; isPreorder = isPreorder + ; isMonotone = isMonotone-⊕ + } + } + + ≤-preorder : Preorder 0ℓ 0ℓ 0ℓ + Preorder.Carrier ≤-preorder = ℂ + Preorder._≈_ ≤-preorder = _≡_ + Preorder._≲_ ≤-preorder = _≤_ + Preorder.isPreorder ≤-preorder = isPreorder + + module ≤-Reasoning where + open import Relation.Binary.Reasoning.Preorder ≤-preorder public \ No newline at end of file diff --git a/Algebra.Cost.Instances.html b/Algebra.Cost.Instances.html index dc95793e..fdbfd757 100644 --- a/Algebra.Cost.Instances.html +++ b/Algebra.Cost.Instances.html @@ -10,94 +10,94 @@ open import Data.Product open import Function open import Relation.Nullary.Negation -open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; module ≡-Reasoning) +open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; module ≡-Reasoning) -ℕ-CostMonoid : CostMonoid +ℕ-CostMonoid : CostMonoid ℕ-CostMonoid = record - { ℂ = ℕ - ; zero = zero - ; _+_ = _+_ - ; _≤_ = _≤_ - ; isCostMonoid = record - { isMonoid = +-0-isMonoid - ; isPreorder = ≤-isPreorder - ; isMonotone = record { ∙-mono-≤ = +-mono-≤ } + { ℂ = ℕ + ; zero = zero + ; _+_ = _+_ + ; _≤_ = _≤_ + ; isCostMonoid = record + { isMonoid = +-0-isMonoid + ; isPreorder = ≤-isPreorder + ; isMonotone = record { ∙-mono-≤ = +-mono-≤ } } } where open import Data.Nat open import Data.Nat.Properties -ℕ⊔-CostMonoid : CostMonoid +ℕ⊔-CostMonoid : CostMonoid ℕ⊔-CostMonoid = record - { ℂ = ℕ - ; zero = zero - ; _+_ = _⊔_ - ; _≤_ = _≤_ - ; isCostMonoid = record - { isMonoid = ⊔-0-isMonoid - ; isPreorder = ≤-isPreorder - ; isMonotone = record { ∙-mono-≤ = ⊔-mono-≤ } + { ℂ = ℕ + ; zero = zero + ; _+_ = _⊔_ + ; _≤_ = _≤_ + ; isCostMonoid = record + { isMonoid = ⊔-0-isMonoid + ; isPreorder = ≤-isPreorder + ; isMonotone = record { ∙-mono-≤ = ⊔-mono-≤ } } } where open import Data.Nat open import Data.Nat.Properties -ℤ-CostMonoid : CostMonoid +ℤ-CostMonoid : CostMonoid ℤ-CostMonoid = record - { ℂ = ℤ - ; zero = 0ℤ - ; _+_ = _+_ - ; _≤_ = _≤_ - ; isCostMonoid = record - { isMonoid = +-0-isMonoid - ; isPreorder = ≤-isPreorder - ; isMonotone = record { ∙-mono-≤ = +-mono-≤ } + { ℂ = ℤ + ; zero = 0ℤ + ; _+_ = _+_ + ; _≤_ = _≤_ + ; isCostMonoid = record + { isMonoid = +-0-isMonoid + ; isPreorder = ≤-isPreorder + ; isMonotone = record { ∙-mono-≤ = +-mono-≤ } } } where open import Data.Integer open import Data.Integer.Properties -ℚ-CostMonoid : CostMonoid +ℚ-CostMonoid : CostMonoid ℚ-CostMonoid = record - { ℂ = ℚ - ; zero = 0ℚ - ; _+_ = _+_ - ; _≤_ = _≤_ - ; isCostMonoid = record - { isMonoid = +-0-isMonoid - ; isPreorder = ≤-isPreorder - ; isMonotone = record { ∙-mono-≤ = +-mono-≤ } + { ℂ = ℚ + ; zero = 0ℚ + ; _+_ = _+_ + ; _≤_ = _≤_ + ; isCostMonoid = record + { isMonoid = +-0-isMonoid + ; isPreorder = ≤-isPreorder + ; isMonotone = record { ∙-mono-≤ = +-mono-≤ } } } where open import Data.Rational open import Data.Rational.Properties -ResourceMonoid : CostMonoid +ResourceMonoid : CostMonoid ResourceMonoid = record - { ℂ = ℕ × ℕ - ; zero = 0 , 0 - ; _+_ = _·_ - ; _≤_ = _≤ᵣ_ - ; isCostMonoid = record + { ℂ = ℕ × ℕ + ; zero = 0 , 0 + ; _+_ = _·_ + ; _≤_ = _≤ᵣ_ + ; isCostMonoid = record { isMonoid = record - { isSemigroup = record - { isMagma = record - { isEquivalence = Eq.isEquivalence - ; ∙-cong = Eq.cong₂ _·_ + { isSemigroup = record + { isMagma = record + { isEquivalence = Eq.isEquivalence + ; ∙-cong = Eq.cong₂ _·_ } - ; assoc = assoc + ; assoc = assoc } - ; identity = identityˡ , identityʳ + ; identity = identityˡ , identityʳ } ; isPreorder = record - { isEquivalence = Eq.isEquivalence - ; reflexive = λ { refl → (≤-refl , ≤-refl) } - ; trans = λ (h₁ , h₂) (h₁' , h₂') → ≤-trans h₁ h₁' , ≤-trans h₂' h₂ + { isEquivalence = Eq.isEquivalence + ; reflexive = λ { refl → (≤-refl , ≤-refl) } + ; trans = λ (h₁ , h₂) (h₁' , h₂') → ≤-trans h₁ h₁' , ≤-trans h₂' h₂ } ; isMonotone = record { ∙-mono-≤ = ∙-mono-≤ᵣ } } @@ -107,171 +107,171 @@ open import Data.Nat.Properties open import Data.Sum - open ≤-Reasoning + open ≤-Reasoning - open import Algebra.Definitions {A = ℕ × ℕ} _≡_ + open import Algebra.Definitions {A = ℕ × ℕ} _≡_ open import Relation.Binary - _·_ : ℕ × ℕ → ℕ × ℕ → ℕ × ℕ - (p , p') · (q , q') = p + (q ∸ p') , q' + (p' ∸ q) + _·_ : ℕ × ℕ → ℕ × ℕ → ℕ × ℕ + (p , p') · (q , q') = p + (q ∸ p') , q' + (p' ∸ q) - _≤ᵣ_ : ℕ × ℕ → ℕ × ℕ → Set - (p , p') ≤ᵣ (q , q') = (p ≤ q) × (q' ≤ p') + _≤ᵣ_ : ℕ × ℕ → ℕ × ℕ → Set + (p , p') ≤ᵣ (q , q') = (p ≤ q) × (q' ≤ p') - +-∸-comm′ : (m : ℕ) {n o : ℕ} → n ≤ o → (m + n) ∸ o ≡ m ∸ (o ∸ n) - +-∸-comm′ m {n} {o} z≤n = Eq.cong (_∸ o) (+-identityʳ m) - +-∸-comm′ m {suc n} {suc o} (s≤s n≤o) = begin-equality - (m + suc n) ∸ suc o ≡⟨ Eq.cong (_∸ suc o) (+-suc m n) ⟩ - suc (m + n) ∸ suc o ≡⟨ +-∸-comm′ m n≤o ⟩ - m ∸ (o ∸ n) ∎ + +-∸-comm′ : (m : ℕ) {n o : ℕ} → n ≤ o → (m + n) ∸ o ≡ m ∸ (o ∸ n) + +-∸-comm′ m {n} {o} z≤n = Eq.cong (_∸ o) (+-identityʳ m) + +-∸-comm′ m {suc n} {suc o} (s≤s n≤o) = begin-equality + (m + suc n) ∸ suc o ≡⟨ Eq.cong (_∸ suc o) (+-suc m n) ⟩ + suc (m + n) ∸ suc o ≡⟨ +-∸-comm′ m n≤o ⟩ + m ∸ (o ∸ n) ∎ - assoc : Associative _·_ - assoc (p , p') (q , q') (r , r') with ≤-total p' q | ≤-total q' r + assoc : Associative _·_ + assoc (p , p') (q , q') (r , r') with ≤-total p' q | ≤-total q' r ... | inj₁ p'≤q | inj₁ q'≤r = - Eq.cong₂ _,_ - (begin-equality - (p + (q ∸ p')) + (r ∸ (q' + (p' ∸ q))) - ≡⟨ Eq.cong (λ x → (p + (q ∸ p')) + (r ∸ (q' + x))) (m≤n⇒m∸n≡0 p'≤q) ⟩ - (p + (q ∸ p')) + (r ∸ (q' + 0)) - ≡⟨ Eq.cong (λ x → (p + (q ∸ p')) + (r ∸ x)) (+-identityʳ q') ⟩ - (p + (q ∸ p')) + (r ∸ q') - ≡⟨ +-assoc p (q ∸ p') (r ∸ q') ⟩ - p + ((q ∸ p') + (r ∸ q')) - ≡˘⟨ Eq.cong (p +_) (+-∸-comm (r ∸ q') p'≤q) ⟩ - p + ((q + (r ∸ q')) ∸ p') - ∎) - (begin-equality - r' + ((q' + (p' ∸ q)) ∸ r) - ≡⟨ Eq.cong (λ x → r' + ((q' + x) ∸ r)) (m≤n⇒m∸n≡0 p'≤q) ⟩ - r' + ((q' + 0) ∸ r) - ≡⟨ Eq.cong (λ x → r' + (x ∸ r)) (+-identityʳ q') ⟩ - r' + (q' ∸ r) - ≡˘⟨ +-identityʳ (r' + (q' ∸ r)) ⟩ - (r' + (q' ∸ r)) + 0 - ≡˘⟨ Eq.cong (λ x → (r' + (q' ∸ r)) + x) (m≤n⇒m∸n≡0 (≤-trans p'≤q (m≤m+n q (r ∸ q')))) ⟩ - (r' + (q' ∸ r)) + (p' ∸ (q + (r ∸ q'))) - ∎) + Eq.cong₂ _,_ + (begin-equality + (p + (q ∸ p')) + (r ∸ (q' + (p' ∸ q))) + ≡⟨ Eq.cong (λ x → (p + (q ∸ p')) + (r ∸ (q' + x))) (m≤n⇒m∸n≡0 p'≤q) ⟩ + (p + (q ∸ p')) + (r ∸ (q' + 0)) + ≡⟨ Eq.cong (λ x → (p + (q ∸ p')) + (r ∸ x)) (+-identityʳ q') ⟩ + (p + (q ∸ p')) + (r ∸ q') + ≡⟨ +-assoc p (q ∸ p') (r ∸ q') ⟩ + p + ((q ∸ p') + (r ∸ q')) + ≡˘⟨ Eq.cong (p +_) (+-∸-comm (r ∸ q') p'≤q) ⟩ + p + ((q + (r ∸ q')) ∸ p') + ∎) + (begin-equality + r' + ((q' + (p' ∸ q)) ∸ r) + ≡⟨ Eq.cong (λ x → r' + ((q' + x) ∸ r)) (m≤n⇒m∸n≡0 p'≤q) ⟩ + r' + ((q' + 0) ∸ r) + ≡⟨ Eq.cong (λ x → r' + (x ∸ r)) (+-identityʳ q') ⟩ + r' + (q' ∸ r) + ≡˘⟨ +-identityʳ (r' + (q' ∸ r)) ⟩ + (r' + (q' ∸ r)) + 0 + ≡˘⟨ Eq.cong (λ x → (r' + (q' ∸ r)) + x) (m≤n⇒m∸n≡0 (≤-trans p'≤q (m≤m+n q (r ∸ q')))) ⟩ + (r' + (q' ∸ r)) + (p' ∸ (q + (r ∸ q'))) + ∎) ... | inj₁ p'≤q | inj₂ r≤q' = - Eq.cong₂ _,_ - (begin-equality - (p + (q ∸ p')) + (r ∸ (q' + (p' ∸ q))) - ≡⟨ Eq.cong ((p + (q ∸ p')) +_) (m≤n⇒m∸n≡0 (≤-trans r≤q' (m≤m+n q' (p' ∸ q)))) ⟩ - (p + (q ∸ p')) + 0 - ≡⟨ +-identityʳ (p + (q ∸ p')) ⟩ - p + (q ∸ p') - ≡˘⟨ Eq.cong (λ x → p + (x ∸ p')) (+-identityʳ q) ⟩ - p + ((q + 0) ∸ p') - ≡˘⟨ Eq.cong (λ x → p + ((q + x) ∸ p')) (m≤n⇒m∸n≡0 r≤q') ⟩ - p + ((q + (r ∸ q')) ∸ p') - ∎) - (begin-equality - r' + ((q' + (p' ∸ q)) ∸ r) - ≡⟨ Eq.cong (λ x → r' + ((q' + x) ∸ r)) (m≤n⇒m∸n≡0 p'≤q) ⟩ - r' + ((q' + 0) ∸ r) - ≡⟨ Eq.cong (λ x → r' + (x ∸ r)) (+-identityʳ q') ⟩ - r' + (q' ∸ r) - ≡˘⟨ +-identityʳ (r' + (q' ∸ r)) ⟩ - (r' + (q' ∸ r)) + 0 - ≡˘⟨ Eq.cong ((r' + (q' ∸ r)) +_) (m≤n⇒m∸n≡0 (≤-trans p'≤q (m≤m+n q (r ∸ q')))) ⟩ - (r' + (q' ∸ r)) + (p' ∸ (q + (r ∸ q'))) - ∎) + Eq.cong₂ _,_ + (begin-equality + (p + (q ∸ p')) + (r ∸ (q' + (p' ∸ q))) + ≡⟨ Eq.cong ((p + (q ∸ p')) +_) (m≤n⇒m∸n≡0 (≤-trans r≤q' (m≤m+n q' (p' ∸ q)))) ⟩ + (p + (q ∸ p')) + 0 + ≡⟨ +-identityʳ (p + (q ∸ p')) ⟩ + p + (q ∸ p') + ≡˘⟨ Eq.cong (λ x → p + (x ∸ p')) (+-identityʳ q) ⟩ + p + ((q + 0) ∸ p') + ≡˘⟨ Eq.cong (λ x → p + ((q + x) ∸ p')) (m≤n⇒m∸n≡0 r≤q') ⟩ + p + ((q + (r ∸ q')) ∸ p') + ∎) + (begin-equality + r' + ((q' + (p' ∸ q)) ∸ r) + ≡⟨ Eq.cong (λ x → r' + ((q' + x) ∸ r)) (m≤n⇒m∸n≡0 p'≤q) ⟩ + r' + ((q' + 0) ∸ r) + ≡⟨ Eq.cong (λ x → r' + (x ∸ r)) (+-identityʳ q') ⟩ + r' + (q' ∸ r) + ≡˘⟨ +-identityʳ (r' + (q' ∸ r)) ⟩ + (r' + (q' ∸ r)) + 0 + ≡˘⟨ Eq.cong ((r' + (q' ∸ r)) +_) (m≤n⇒m∸n≡0 (≤-trans p'≤q (m≤m+n q (r ∸ q')))) ⟩ + (r' + (q' ∸ r)) + (p' ∸ (q + (r ∸ q'))) + ∎) ... | inj₂ q≤p' | inj₁ q'≤r = - Eq.cong₂ _,_ - (begin-equality - (p + (q ∸ p')) + (r ∸ (q' + (p' ∸ q))) - ≡⟨ Eq.cong (λ x → (p + x) + (r ∸ (q' + (p' ∸ q)))) (m≤n⇒m∸n≡0 q≤p') ⟩ - (p + 0) + (r ∸ (q' + (p' ∸ q))) - ≡⟨ Eq.cong (_+ (r ∸ (q' + (p' ∸ q)))) (+-identityʳ p) ⟩ - p + (r ∸ (q' + (p' ∸ q))) - ≡⟨ Eq.cong (p +_) (arithmetic p' q q' r q≤p' q'≤r) ⟩ - p + ((q + (r ∸ q')) ∸ p') - ∎) - (begin-equality - r' + ((q' + (p' ∸ q)) ∸ r) - ≡˘⟨ Eq.cong (r' +_) (arithmetic r q' q p' q'≤r q≤p') ⟩ - r' + (p' ∸ (q + (r ∸ q'))) - ≡˘⟨ Eq.cong (_+ (p' ∸ (q + (r ∸ q')))) (+-identityʳ r') ⟩ - (r' + 0) + (p' ∸ (q + (r ∸ q'))) - ≡˘⟨ Eq.cong (λ x → (r' + x) + (p' ∸ (q + (r ∸ q')))) (m≤n⇒m∸n≡0 q'≤r) ⟩ - (r' + (q' ∸ r)) + (p' ∸ (q + (r ∸ q'))) - ∎) + Eq.cong₂ _,_ + (begin-equality + (p + (q ∸ p')) + (r ∸ (q' + (p' ∸ q))) + ≡⟨ Eq.cong (λ x → (p + x) + (r ∸ (q' + (p' ∸ q)))) (m≤n⇒m∸n≡0 q≤p') ⟩ + (p + 0) + (r ∸ (q' + (p' ∸ q))) + ≡⟨ Eq.cong (_+ (r ∸ (q' + (p' ∸ q)))) (+-identityʳ p) ⟩ + p + (r ∸ (q' + (p' ∸ q))) + ≡⟨ Eq.cong (p +_) (arithmetic p' q q' r q≤p' q'≤r) ⟩ + p + ((q + (r ∸ q')) ∸ p') + ∎) + (begin-equality + r' + ((q' + (p' ∸ q)) ∸ r) + ≡˘⟨ Eq.cong (r' +_) (arithmetic r q' q p' q'≤r q≤p') ⟩ + r' + (p' ∸ (q + (r ∸ q'))) + ≡˘⟨ Eq.cong (_+ (p' ∸ (q + (r ∸ q')))) (+-identityʳ r') ⟩ + (r' + 0) + (p' ∸ (q + (r ∸ q'))) + ≡˘⟨ Eq.cong (λ x → (r' + x) + (p' ∸ (q + (r ∸ q')))) (m≤n⇒m∸n≡0 q'≤r) ⟩ + (r' + (q' ∸ r)) + (p' ∸ (q + (r ∸ q'))) + ∎) where - arithmetic : (p' q q' r : ℕ) → q ≤ p' → q' ≤ r → r ∸ (q' + (p' ∸ q)) ≡ ((q + (r ∸ q')) ∸ p') + arithmetic : (p' q q' r : ℕ) → q ≤ p' → q' ≤ r → r ∸ (q' + (p' ∸ q)) ≡ ((q + (r ∸ q')) ∸ p') arithmetic p' q q' r q≤p' q'≤r = - begin-equality - r ∸ (q' + (p' ∸ q)) - ≡˘⟨ ∸-+-assoc r q' (p' ∸ q) ⟩ - (r ∸ q') ∸ (p' ∸ q) - ≡˘⟨ +-∸-comm′ (r ∸ q') q≤p' ⟩ - ((r ∸ q') + q) ∸ p' - ≡⟨ Eq.cong (_∸ p') (+-comm (r ∸ q') q) ⟩ - (q + (r ∸ q')) ∸ p' - ∎ + begin-equality + r ∸ (q' + (p' ∸ q)) + ≡˘⟨ ∸-+-assoc r q' (p' ∸ q) ⟩ + (r ∸ q') ∸ (p' ∸ q) + ≡˘⟨ +-∸-comm′ (r ∸ q') q≤p' ⟩ + ((r ∸ q') + q) ∸ p' + ≡⟨ Eq.cong (_∸ p') (+-comm (r ∸ q') q) ⟩ + (q + (r ∸ q')) ∸ p' + ∎ ... | inj₂ q≤p' | inj₂ r≤q' = - Eq.cong₂ _,_ - (begin-equality - (p + (q ∸ p')) + (r ∸ (q' + (p' ∸ q))) - ≡⟨ Eq.cong ((p + (q ∸ p')) +_) (m≤n⇒m∸n≡0 (≤-trans r≤q' (m≤m+n q' (p' ∸ q)))) ⟩ - (p + (q ∸ p')) + 0 - ≡⟨ +-identityʳ (p + (q ∸ p')) ⟩ - p + (q ∸ p') - ≡˘⟨ Eq.cong (λ x → p + (x ∸ p')) (+-identityʳ q) ⟩ - p + ((q + 0) ∸ p') - ≡˘⟨ Eq.cong (λ x → p + ((q + x) ∸ p')) (m≤n⇒m∸n≡0 r≤q') ⟩ - p + ((q + (r ∸ q')) ∸ p') - ∎) - (begin-equality - r' + ((q' + (p' ∸ q)) ∸ r) - ≡⟨ Eq.cong (r' +_) (+-∸-comm (p' ∸ q) r≤q') ⟩ - r' + ((q' ∸ r) + (p' ∸ q)) - ≡˘⟨ +-assoc r' (q' ∸ r) (p' ∸ q) ⟩ - (r' + (q' ∸ r)) + (p' ∸ q) - ≡˘⟨ Eq.cong (λ x → (r' + (q' ∸ r)) + (p' ∸ x)) (+-identityʳ q) ⟩ - (r' + (q' ∸ r)) + (p' ∸ (q + 0)) - ≡˘⟨ Eq.cong (λ x → (r' + (q' ∸ r)) + (p' ∸ (q + x))) (m≤n⇒m∸n≡0 r≤q') ⟩ - (r' + (q' ∸ r)) + (p' ∸ (q + (r ∸ q'))) - ∎) + Eq.cong₂ _,_ + (begin-equality + (p + (q ∸ p')) + (r ∸ (q' + (p' ∸ q))) + ≡⟨ Eq.cong ((p + (q ∸ p')) +_) (m≤n⇒m∸n≡0 (≤-trans r≤q' (m≤m+n q' (p' ∸ q)))) ⟩ + (p + (q ∸ p')) + 0 + ≡⟨ +-identityʳ (p + (q ∸ p')) ⟩ + p + (q ∸ p') + ≡˘⟨ Eq.cong (λ x → p + (x ∸ p')) (+-identityʳ q) ⟩ + p + ((q + 0) ∸ p') + ≡˘⟨ Eq.cong (λ x → p + ((q + x) ∸ p')) (m≤n⇒m∸n≡0 r≤q') ⟩ + p + ((q + (r ∸ q')) ∸ p') + ∎) + (begin-equality + r' + ((q' + (p' ∸ q)) ∸ r) + ≡⟨ Eq.cong (r' +_) (+-∸-comm (p' ∸ q) r≤q') ⟩ + r' + ((q' ∸ r) + (p' ∸ q)) + ≡˘⟨ +-assoc r' (q' ∸ r) (p' ∸ q) ⟩ + (r' + (q' ∸ r)) + (p' ∸ q) + ≡˘⟨ Eq.cong (λ x → (r' + (q' ∸ r)) + (p' ∸ x)) (+-identityʳ q) ⟩ + (r' + (q' ∸ r)) + (p' ∸ (q + 0)) + ≡˘⟨ Eq.cong (λ x → (r' + (q' ∸ r)) + (p' ∸ (q + x))) (m≤n⇒m∸n≡0 r≤q') ⟩ + (r' + (q' ∸ r)) + (p' ∸ (q + (r ∸ q'))) + ∎) - identityˡ : LeftIdentity (0 , 0) _·_ + identityˡ : LeftIdentity (0 , 0) _·_ identityˡ (q , q') = - Eq.cong + Eq.cong (q ,_) - (begin-equality - q' + (0 ∸ q) - ≡⟨ Eq.cong (q' +_) (0∸n≡0 q) ⟩ + (begin-equality + q' + (0 ∸ q) + ≡⟨ Eq.cong (q' +_) (0∸n≡0 q) ⟩ q' + 0 - ≡⟨ +-identityʳ q' ⟩ + ≡⟨ +-identityʳ q' ⟩ q' - ∎) + ∎) - identityʳ : RightIdentity (0 , 0) _·_ + identityʳ : RightIdentity (0 , 0) _·_ identityʳ (q , q') = - Eq.cong + Eq.cong (_, q') - (begin-equality - q + (0 ∸ q') - ≡⟨ Eq.cong (q +_) (0∸n≡0 q') ⟩ + (begin-equality + q + (0 ∸ q') + ≡⟨ Eq.cong (q +_) (0∸n≡0 q') ⟩ q + 0 - ≡⟨ +-identityʳ q ⟩ + ≡⟨ +-identityʳ q ⟩ q - ∎) + ∎) - ∙-mono-≤ᵣ : _·_ Preserves₂ _≤ᵣ_ ⟶ _≤ᵣ_ ⟶ _≤ᵣ_ + ∙-mono-≤ᵣ : _·_ Preserves₂ _≤ᵣ_ ⟶ _≤ᵣ_ ⟶ _≤ᵣ_ ∙-mono-≤ᵣ (h₁ , h₁') (h₂ , h₂') = - +-mono-≤ h₁ (∸-mono h₂ h₁') , - +-mono-≤ h₂' (∸-mono h₁' h₂) + +-mono-≤ h₁ (∸-mono h₂ h₁') , + +-mono-≤ h₂' (∸-mono h₁' h₂) -List-CostMonoid : Set → CostMonoid +List-CostMonoid : Set → CostMonoid List-CostMonoid A = record - { ℂ = List A - ; zero = [] - ; _+_ = _++_ - ; _≤_ = _⊆_ - ; isCostMonoid = record - { isMonoid = ++-isMonoid - ; isPreorder = ⊆-isPreorder - ; isMonotone = record { ∙-mono-≤ = ++⁺ } + { ℂ = List A + ; zero = [] + ; _+_ = _++_ + ; _≤_ = _⊆_ + ; isCostMonoid = record + { isMonoid = ++-isMonoid + ; isPreorder = ⊆-isPreorder + ; isMonotone = record { ∙-mono-≤ = ++⁺ } } } where @@ -280,31 +280,31 @@ open import Data.List.Relation.Binary.Sublist.Propositional open import Data.List.Relation.Binary.Sublist.Propositional.Properties -cm-× : CostMonoid → CostMonoid → CostMonoid +cm-× : CostMonoid → CostMonoid → CostMonoid cm-× cm₁ cm₂ = record - { ℂ = ℂ cm₁ × ℂ cm₂ - ; zero = zero cm₁ , zero cm₂ - ; _+_ = λ (a₁ , a₂) (b₁ , b₂) → _+_ cm₁ a₁ b₁ , _+_ cm₂ a₂ b₂ - ; _≤_ = λ (a₁ , a₂) (b₁ , b₂) → _≤_ cm₁ a₁ b₁ × _≤_ cm₂ a₂ b₂ - ; isCostMonoid = record + { ℂ = ℂ cm₁ × ℂ cm₂ + ; zero = zero cm₁ , zero cm₂ + ; _+_ = λ (a₁ , a₂) (b₁ , b₂) → _+_ cm₁ a₁ b₁ , _+_ cm₂ a₂ b₂ + ; _≤_ = λ (a₁ , a₂) (b₁ , b₂) → _≤_ cm₁ a₁ b₁ × _≤_ cm₂ a₂ b₂ + ; isCostMonoid = record { isMonoid = record - { isSemigroup = record - { isMagma = record - { isEquivalence = Eq.isEquivalence - ; ∙-cong = Eq.cong₂ _ + { isSemigroup = record + { isMagma = record + { isEquivalence = Eq.isEquivalence + ; ∙-cong = Eq.cong₂ _ } - ; assoc = + ; assoc = λ (a₁ , a₂) (b₁ , b₂) (c₁ , c₂) → - Eq.cong₂ _,_ (+-assoc cm₁ a₁ b₁ c₁) (+-assoc cm₂ a₂ b₂ c₂) + Eq.cong₂ _,_ (+-assoc cm₁ a₁ b₁ c₁) (+-assoc cm₂ a₂ b₂ c₂) } - ; identity = - (λ (a₁ , a₂) → Eq.cong₂ _,_ (+-identityˡ cm₁ a₁) (+-identityˡ cm₂ a₂)) , - (λ (a₁ , a₂) → Eq.cong₂ _,_ (+-identityʳ cm₁ a₁) (+-identityʳ cm₂ a₂)) + ; identity = + (λ (a₁ , a₂) → Eq.cong₂ _,_ (+-identityˡ cm₁ a₁) (+-identityˡ cm₂ a₂)) , + (λ (a₁ , a₂) → Eq.cong₂ _,_ (+-identityʳ cm₁ a₁) (+-identityʳ cm₂ a₂)) } ; isPreorder = record - { isEquivalence = Eq.isEquivalence - ; reflexive = λ { refl → ≤-refl cm₁ , ≤-refl cm₂ } - ; trans = λ (h₁ , h₂) (h₁' , h₂') → ≤-trans cm₁ h₁ h₁' , ≤-trans cm₂ h₂ h₂' + { isEquivalence = Eq.isEquivalence + ; reflexive = λ { refl → ≤-refl cm₁ , ≤-refl cm₂ } + ; trans = λ (h₁ , h₂) (h₁' , h₂') → ≤-trans cm₁ h₁ h₁' , ≤-trans cm₂ h₂ h₂' } ; isMonotone = record { ∙-mono-≤ = λ (h₁ , h₂) (h₁' , h₂') → +-mono-≤ cm₁ h₁ h₁' , +-mono-≤ cm₂ h₂ h₂' @@ -312,20 +312,20 @@ } } where - open CostMonoid + open CostMonoid sequentialParCostMonoid : - (cm : CostMonoid) - → IsCommutativeMonoid (CostMonoid.ℂ cm) (CostMonoid._+_ cm) (CostMonoid.zero cm) - → ParCostMonoid + (cm : CostMonoid) + → IsCommutativeMonoid (CostMonoid.ℂ cm) (CostMonoid._+_ cm) (CostMonoid.zero cm) + → ParCostMonoid sequentialParCostMonoid cm isCommutativeMonoid = record - { ℂ = ℂ - ; 𝟘 = zero - ; _⊕_ = _+_ - ; _⊗_ = _+_ - ; _≤_ = _≤_ - ; isParCostMonoid = record + { ℂ = ℂ + ; 𝟘 = zero + ; _⊕_ = _+_ + ; _⊗_ = _+_ + ; _≤_ = _≤_ + ; isParCostMonoid = record { isMonoid = isMonoid ; isCommutativeMonoid = isCommutativeMonoid ; isPreorder = isPreorder @@ -333,74 +333,74 @@ ; isMonotone-⊗ = isMonotone } } - where open CostMonoid cm + where open CostMonoid cm -ℕ-Work-ParCostMonoid : ParCostMonoid -ℕ-Work-ParCostMonoid = sequentialParCostMonoid ℕ-CostMonoid +-0-isCommutativeMonoid - where open import Data.Nat.Properties using (+-0-isCommutativeMonoid) +ℕ-Work-ParCostMonoid : ParCostMonoid +ℕ-Work-ParCostMonoid = sequentialParCostMonoid ℕ-CostMonoid +-0-isCommutativeMonoid + where open import Data.Nat.Properties using (+-0-isCommutativeMonoid) -ℕ-Span-ParCostMonoid : ParCostMonoid +ℕ-Span-ParCostMonoid : ParCostMonoid ℕ-Span-ParCostMonoid = record - { ℂ = ℕ - ; 𝟘 = 0 - ; _⊕_ = _+_ - ; _⊗_ = _⊔_ - ; _≤_ = _≤_ - ; isParCostMonoid = record - { isMonoid = +-0-isMonoid - ; isCommutativeMonoid = ⊔-0-isCommutativeMonoid - ; isPreorder = ≤-isPreorder - ; isMonotone-⊕ = record { ∙-mono-≤ = +-mono-≤ } - ; isMonotone-⊗ = record { ∙-mono-≤ = ⊔-mono-≤ } + { ℂ = ℕ + ; 𝟘 = 0 + ; _⊕_ = _+_ + ; _⊗_ = _⊔_ + ; _≤_ = _≤_ + ; isParCostMonoid = record + { isMonoid = +-0-isMonoid + ; isCommutativeMonoid = ⊔-0-isCommutativeMonoid + ; isPreorder = ≤-isPreorder + ; isMonotone-⊕ = record { ∙-mono-≤ = +-mono-≤ } + ; isMonotone-⊗ = record { ∙-mono-≤ = ⊔-mono-≤ } } } where open import Data.Nat open import Data.Nat.Properties -pcm-× : ParCostMonoid → ParCostMonoid → ParCostMonoid +pcm-× : ParCostMonoid → ParCostMonoid → ParCostMonoid pcm-× pcm₁ pcm₂ = record - { ℂ = ℂ pcm₁ × ℂ pcm₂ - ; 𝟘 = 𝟘 pcm₁ , 𝟘 pcm₂ - ; _⊕_ = λ (a₁ , a₂) (b₁ , b₂) → _⊕_ pcm₁ a₁ b₁ , _⊕_ pcm₂ a₂ b₂ - ; _⊗_ = λ (a₁ , a₂) (b₁ , b₂) → _⊗_ pcm₁ a₁ b₁ , _⊗_ pcm₂ a₂ b₂ - ; _≤_ = Pointwise (_≤_ pcm₁) (_≤_ pcm₂) - ; isParCostMonoid = record + { ℂ = ℂ pcm₁ × ℂ pcm₂ + ; 𝟘 = 𝟘 pcm₁ , 𝟘 pcm₂ + ; _⊕_ = λ (a₁ , a₂) (b₁ , b₂) → _⊕_ pcm₁ a₁ b₁ , _⊕_ pcm₂ a₂ b₂ + ; _⊗_ = λ (a₁ , a₂) (b₁ , b₂) → _⊗_ pcm₁ a₁ b₁ , _⊗_ pcm₂ a₂ b₂ + ; _≤_ = Pointwise (_≤_ pcm₁) (_≤_ pcm₂) + ; isParCostMonoid = record { isMonoid = record - { isSemigroup = record - { isMagma = record - { isEquivalence = Eq.isEquivalence - ; ∙-cong = Eq.cong₂ _ + { isSemigroup = record + { isMagma = record + { isEquivalence = Eq.isEquivalence + ; ∙-cong = Eq.cong₂ _ } - ; assoc = + ; assoc = λ (a₁ , a₂) (b₁ , b₂) (c₁ , c₂) → - Eq.cong₂ _,_ (⊕-assoc pcm₁ a₁ b₁ c₁) (⊕-assoc pcm₂ a₂ b₂ c₂) + Eq.cong₂ _,_ (⊕-assoc pcm₁ a₁ b₁ c₁) (⊕-assoc pcm₂ a₂ b₂ c₂) } - ; identity = - (λ (a₁ , a₂) → Eq.cong₂ _,_ (⊕-identityˡ pcm₁ a₁) (⊕-identityˡ pcm₂ a₂)) , - (λ (a₁ , a₂) → Eq.cong₂ _,_ (⊕-identityʳ pcm₁ a₁) (⊕-identityʳ pcm₂ a₂)) + ; identity = + (λ (a₁ , a₂) → Eq.cong₂ _,_ (⊕-identityˡ pcm₁ a₁) (⊕-identityˡ pcm₂ a₂)) , + (λ (a₁ , a₂) → Eq.cong₂ _,_ (⊕-identityʳ pcm₁ a₁) (⊕-identityʳ pcm₂ a₂)) } ; isCommutativeMonoid = record - { isMonoid = record - { isSemigroup = record - { isMagma = record - { isEquivalence = Eq.isEquivalence - ; ∙-cong = Eq.cong₂ _ + { isMonoid = record + { isSemigroup = record + { isMagma = record + { isEquivalence = Eq.isEquivalence + ; ∙-cong = Eq.cong₂ _ } - ; assoc = + ; assoc = λ (a₁ , a₂) (b₁ , b₂) (c₁ , c₂) → - Eq.cong₂ _,_ (⊗-assoc pcm₁ a₁ b₁ c₁) (⊗-assoc pcm₂ a₂ b₂ c₂) + Eq.cong₂ _,_ (⊗-assoc pcm₁ a₁ b₁ c₁) (⊗-assoc pcm₂ a₂ b₂ c₂) } - ; identity = - (λ (a₁ , a₂) → Eq.cong₂ _,_ (⊗-identityˡ pcm₁ a₁) (⊗-identityˡ pcm₂ a₂)) , - (λ (a₁ , a₂) → Eq.cong₂ _,_ (⊗-identityʳ pcm₁ a₁) (⊗-identityʳ pcm₂ a₂)) + ; identity = + (λ (a₁ , a₂) → Eq.cong₂ _,_ (⊗-identityˡ pcm₁ a₁) (⊗-identityˡ pcm₂ a₂)) , + (λ (a₁ , a₂) → Eq.cong₂ _,_ (⊗-identityʳ pcm₁ a₁) (⊗-identityʳ pcm₂ a₂)) } - ; comm = λ (a₁ , a₂) (b₁ , b₂) → Eq.cong₂ _,_ (⊗-comm pcm₁ a₁ b₁) (⊗-comm pcm₂ a₂ b₂) + ; comm = λ (a₁ , a₂) (b₁ , b₂) → Eq.cong₂ _,_ (⊗-comm pcm₁ a₁ b₁) (⊗-comm pcm₂ a₂ b₂) } ; isPreorder = record - { isEquivalence = Eq.isEquivalence - ; reflexive = λ { refl → ≤-refl pcm₁ , ≤-refl pcm₂ } - ; trans = λ (h₁ , h₂) (h₁' , h₂') → ≤-trans pcm₁ h₁ h₁' , ≤-trans pcm₂ h₂ h₂' + { isEquivalence = Eq.isEquivalence + ; reflexive = λ { refl → ≤-refl pcm₁ , ≤-refl pcm₂ } + ; trans = λ (h₁ , h₂) (h₁' , h₂') → ≤-trans pcm₁ h₁ h₁' , ≤-trans pcm₂ h₂ h₂' } ; isMonotone-⊕ = record { ∙-mono-≤ = λ (h₁ , h₂) (h₁' , h₂') → ⊕-mono-≤ pcm₁ h₁ h₁' , ⊕-mono-≤ pcm₂ h₂ h₂' @@ -411,9 +411,9 @@ } } where - open ParCostMonoid + open ParCostMonoid open import Data.Product.Relation.Binary.Pointwise.NonDependent -ℕ²-ParCostMonoid : ParCostMonoid +ℕ²-ParCostMonoid : ParCostMonoid ℕ²-ParCostMonoid = pcm-× ℕ-Work-ParCostMonoid ℕ-Span-ParCostMonoid \ No newline at end of file diff --git a/Algebra.Cost.Structures.html b/Algebra.Cost.Structures.html index 82ed180d..155855ee 100644 --- a/Algebra.Cost.Structures.html +++ b/Algebra.Cost.Structures.html @@ -1,7 +1,7 @@ Algebra.Cost.Structures
{-# OPTIONS --cubical-compatible --safe #-}
 
-open import Relation.Binary using (Rel; _Preserves_⟶_; _Preserves₂_⟶_⟶_)
+open import Relation.Binary using (Rel; _Preserves_⟶_; _Preserves₂_⟶_⟶_)
 
 module Algebra.Cost.Structures (ℂ : Set) where
 
@@ -14,38 +14,38 @@
 open import Level using (0ℓ)
 
 
-record IsMonotone (_∙_ : Op₂ ℂ) (_≤_ : Rel ℂ 0ℓ) (isPreorder : IsPreorder _≤_) : Set where
+record IsMonotone (_∙_ : Op₂ ℂ) (_≤_ : Rel ℂ 0ℓ) (isPreorder : IsPreorder _≤_) : Set where
   field
-    ∙-mono-≤ : _∙_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_
+    ∙-mono-≤ : _∙_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_
 
-  open IsPreorder isPreorder
+  open IsPreorder isPreorder
     using ()
-    renaming (reflexive to ≤-reflexive; refl to ≤-refl; trans to ≤-trans)
+    renaming (reflexive to ≤-reflexive; refl to ≤-refl; trans to ≤-trans)
 
-  ∙-monoˡ-≤ : ∀ n → (_∙ n) Preserves _≤_ ⟶ _≤_
+  ∙-monoˡ-≤ : ∀ n → (_∙ n) Preserves _≤_ ⟶ _≤_
   ∙-monoˡ-≤ n m≤o = ∙-mono-≤ m≤o (≤-refl {n})
 
-  ∙-monoʳ-≤ : ∀ n → (n ∙_) Preserves _≤_ ⟶ _≤_
+  ∙-monoʳ-≤ : ∀ n → (n ∙_) Preserves _≤_ ⟶ _≤_
   ∙-monoʳ-≤ n m≤o = ∙-mono-≤ (≤-refl {n}) m≤o
 
 
-record IsCostMonoid (zero : ℂ) (_+_ : Op₂ ℂ) (_≤_ : Rel ℂ 0ℓ) : Set where
+record IsCostMonoid (zero : ℂ) (_+_ : Op₂ ℂ) (_≤_ : Rel ℂ 0ℓ) : Set where
   field
-    isMonoid       : IsMonoid _+_ zero
-    isPreorder     : IsPreorder _≤_
+    isMonoid       : IsMonoid _+_ zero
+    isPreorder     : IsPreorder _≤_
     isMonotone     : IsMonotone _+_ _≤_ isPreorder
 
-  open IsMonoid isMonoid public
+  open IsMonoid isMonoid public
     using ()
     renaming (
-      identityˡ to +-identityˡ;
-      identityʳ to +-identityʳ;
-      assoc to +-assoc
+      identityˡ to +-identityˡ;
+      identityʳ to +-identityʳ;
+      assoc to +-assoc
     )
 
-  open IsPreorder isPreorder public
+  open IsPreorder isPreorder public
     using ()
-    renaming (reflexive to ≤-reflexive; refl to ≤-refl; trans to ≤-trans)
+    renaming (reflexive to ≤-reflexive; refl to ≤-refl; trans to ≤-trans)
 
   open IsMonotone isMonotone public
     renaming (
@@ -55,34 +55,34 @@
     )
 
 
-record IsParCostMonoid (𝟘 : ℂ) (_⊕_ : Op₂ ℂ) (_⊗_ : Op₂ ℂ) (_≤_ : Rel ℂ 0ℓ) : Set where
+record IsParCostMonoid (𝟘 : ℂ) (_⊕_ : Op₂ ℂ) (_⊗_ : Op₂ ℂ) (_≤_ : Rel ℂ 0ℓ) : Set where
   field
-    isMonoid            : IsMonoid _⊕_ 𝟘
-    isCommutativeMonoid : IsCommutativeMonoid _⊗_ 𝟘
-    isPreorder          : IsPreorder _≤_
+    isMonoid            : IsMonoid _⊕_ 𝟘
+    isCommutativeMonoid : IsCommutativeMonoid _⊗_ 𝟘
+    isPreorder          : IsPreorder _≤_
     isMonotone-⊕        : IsMonotone _⊕_ _≤_ isPreorder
     isMonotone-⊗        : IsMonotone _⊗_ _≤_ isPreorder
 
-  open IsMonoid isMonoid public
+  open IsMonoid isMonoid public
     using ()
     renaming (
-      identityˡ to ⊕-identityˡ;
-      identityʳ to ⊕-identityʳ;
-      assoc to ⊕-assoc
+      identityˡ to ⊕-identityˡ;
+      identityʳ to ⊕-identityʳ;
+      assoc to ⊕-assoc
     )
 
-  open IsCommutativeMonoid isCommutativeMonoid public
+  open IsCommutativeMonoid isCommutativeMonoid public
     using ()
     renaming (
-      identityˡ to ⊗-identityˡ;
-      identityʳ to ⊗-identityʳ;
-      assoc to ⊗-assoc;
-      comm to ⊗-comm
+      identityˡ to ⊗-identityˡ;
+      identityʳ to ⊗-identityʳ;
+      assoc to ⊗-assoc;
+      comm to ⊗-comm
     )
 
-  open IsPreorder isPreorder public
+  open IsPreorder isPreorder public
     using ()
-    renaming (reflexive to ≤-reflexive; refl to ≤-refl; trans to ≤-trans)
+    renaming (reflexive to ≤-reflexive; refl to ≤-refl; trans to ≤-trans)
 
   open IsMonotone isMonotone-⊕ public
     renaming (
diff --git a/Algebra.Definitions.RawMagma.html b/Algebra.Definitions.RawMagma.html
index 000a817b..c09d3654 100644
--- a/Algebra.Definitions.RawMagma.html
+++ b/Algebra.Definitions.RawMagma.html
@@ -12,64 +12,77 @@
 {-# OPTIONS --cubical-compatible --safe #-}
 
 open import Algebra.Bundles using (RawMagma)
-open import Data.Product using (_×_; ∃)
-open import Level using (_⊔_)
-open import Relation.Binary.Core
-open import Relation.Nullary.Negation using (¬_)
+open import Data.Product.Base using (_×_; ∃)
+open import Level using (_⊔_)
+open import Relation.Binary.Core
+open import Relation.Nullary.Negation using (¬_)
 
-module Algebra.Definitions.RawMagma
-  {a ℓ} (M : RawMagma a ℓ)
-  where
+module Algebra.Definitions.RawMagma
+  {a ℓ} (M : RawMagma a ℓ)
+  where
 
-open RawMagma M renaming (Carrier to A)
+open RawMagma M renaming (Carrier to A)
 
-------------------------------------------------------------------------
--- Divisibility
+------------------------------------------------------------------------
+-- Divisibility
 
-infix 5 _∣ˡ_ _∤ˡ_ _∣ʳ_ _∤ʳ_ _∣_ _∤_
+infix 5 _∣ˡ_ _∤ˡ_ _∣ʳ_ _∤ʳ_ _∣_ _∤_
 
--- Divisibility from the left
+-- Divisibility from the left.
+--
+-- This and, the definition of right divisibility below, are defined as
+-- records rather than in terms of the base product type in order to
+-- make the use of pattern synonyms more ergonomic (see #2216 for
+-- further details). The record field names are not designed to be
+-- used explicitly and indeed aren't re-exported publicly by
+-- `Algebra.X.Properties.Divisibility` modules.
 
-_∣ˡ_ : Rel A (a ⊔ ℓ)
-x ∣ˡ y = ∃ λ q → (x ∙ q) ≈ y
+record _∣ˡ_ (x y : A) : Set (a ⊔ ℓ) where
+  constructor _,_
+  field
+    quotient : A
+    equality : x ∙ quotient ≈ y
 
-_∤ˡ_ : Rel A (a ⊔ ℓ)
-x ∤ˡ y = ¬ x ∣ˡ y
+_∤ˡ_ : Rel A (a ⊔ ℓ)
+x ∤ˡ y = ¬ x ∣ˡ y
 
--- Divisibility from the right
+-- Divisibility from the right
 
-_∣ʳ_ : Rel A (a ⊔ ℓ)
-x ∣ʳ y = ∃ λ q → (q ∙ x) ≈ y
+record _∣ʳ_ (x y : A) : Set (a ⊔ ℓ) where
+  constructor _,_
+  field
+    quotient : A
+    equality : quotient ∙ x ≈ y
 
-_∤ʳ_ : Rel A (a ⊔ ℓ)
-x ∤ʳ y = ¬ x ∣ʳ y
+_∤ʳ_ : Rel A (a ⊔ ℓ)
+x ∤ʳ y = ¬ x ∣ʳ y
 
--- General divisibility
+-- General divisibility
 
--- The relations _∣ˡ_ and _∣ʳ_ are only equivalent when _∙_ is
--- commutative. When that is not the case we take `_∣ʳ_` to be the
--- primary one.
+-- The relations _∣ˡ_ and _∣ʳ_ are only equivalent when _∙_ is
+-- commutative. When that is not the case we take `_∣ʳ_` to be the
+-- primary one.
 
-_∣_ : Rel A (a ⊔ ℓ)
-_∣_ = _∣ʳ_
+_∣_ : Rel A (a ⊔ ℓ)
+_∣_ = _∣ʳ_
 
-_∤_ : Rel A (a ⊔ ℓ)
-x ∤ y = ¬ x ∣ y
+_∤_ : Rel A (a ⊔ ℓ)
+x ∤ y = ¬ x ∣ y
 
-------------------------------------------------------------------------
--- Mutual divisibility.
+------------------------------------------------------------------------
+-- Mutual divisibility.
 
--- In a  monoid, this is an equivalence relation extending _≈_.
--- When in a cancellative monoid,  elements related by _∣∣_ are called
--- associated, and `x ∣∣ y` means that `x` and `y` differ by some
--- invertible factor.
+-- In a  monoid, this is an equivalence relation extending _≈_.
+-- When in a cancellative monoid,  elements related by _∣∣_ are called
+-- associated, and `x ∣∣ y` means that `x` and `y` differ by some
+-- invertible factor.
 
--- Example: for ℕ  this is equivalent to x ≡ y,
---          for ℤ  this is equivalent to (x ≡ y or x ≡ - y).
+-- Example: for ℕ  this is equivalent to x ≡ y,
+--          for ℤ  this is equivalent to (x ≡ y or x ≡ - y).
 
-_∣∣_ : Rel A (a ⊔ ℓ)
-x ∣∣ y = x ∣ y × y ∣ x
+_∣∣_ : Rel A (a ⊔ ℓ)
+x ∣∣ y = x ∣ y × y ∣ x
 
-_∤∤_ : Rel A (a ⊔ ℓ)
-x ∤∤ y = ¬ x ∣∣ y
+_∤∤_ : Rel A (a ⊔ ℓ)
+x ∤∤ y = ¬ x ∣∣ y
\ No newline at end of file diff --git a/Algebra.Definitions.RawMonoid.html b/Algebra.Definitions.RawMonoid.html index 223661d6..223f829a 100644 --- a/Algebra.Definitions.RawMonoid.html +++ b/Algebra.Definitions.RawMonoid.html @@ -9,7 +9,7 @@ open import Algebra.Bundles using (RawMonoid) open import Data.Nat.Base as ℕ using (ℕ; zero; suc) -open import Data.Vec.Functional as Vector using (Vector) +open import Data.Vec.Functional as Vector using (Vector) module Algebra.Definitions.RawMonoid {a ℓ} (M : RawMonoid a ℓ) where @@ -64,6 +64,6 @@ -- Summation ------------------------------------------------------------------------ -sum : ∀ {n} → Vector Carrier n → Carrier -sum = Vector.foldr _+_ 0# +sum : ∀ {n} → Vector Carrier n → Carrier +sum = Vector.foldr _+_ 0# \ No newline at end of file diff --git a/Algebra.Definitions.RawSemiring.html b/Algebra.Definitions.RawSemiring.html index e3ec5f15..74a264e8 100644 --- a/Algebra.Definitions.RawSemiring.html +++ b/Algebra.Definitions.RawSemiring.html @@ -11,7 +11,7 @@ open import Data.Sum.Base using (_⊎_) open import Data.Nat using (ℕ; zero; suc) open import Level using (_⊔_) -open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Core using (Rel) module Algebra.Definitions.RawSemiring {a ℓ} (M : RawSemiring a ℓ) where @@ -32,8 +32,8 @@ open import Algebra.Definitions.RawMonoid *-rawMonoid as Mult public using - ( _∣_ - ; _∤_ + ( _∣_ + ; _∤_ ) renaming ( sum to product @@ -69,19 +69,19 @@ ------------------------------------------------------------------------ -- Primality -Coprime : Rel A (a ⊔ ℓ) -Coprime x y = ∀ {z} → z ∣ x → z ∣ y → z ∣ 1# +Coprime : Rel A (a ⊔ ℓ) +Coprime x y = ∀ {z} → z ∣ x → z ∣ y → z ∣ 1# record Irreducible (p : A) : Set (a ⊔ ℓ) where constructor mkIrred field - p∤1 : p ∤ 1# - split-∣1 : ∀ {x y} → p ≈ (x * y) → x ∣ 1# ⊎ y ∣ 1# + p∤1 : p ∤ 1# + split-∣1 : ∀ {x y} → p ≈ (x * y) → x ∣ 1# ⊎ y ∣ 1# record Prime (p : A) : Set (a ⊔ ℓ) where constructor mkPrime field p≉0 : p ≉ 0# - p∤1 : p ∤ 1# - split-∣ : ∀ {x y} → p ∣ x * y → p ∣ x ⊎ p ∣ y + p∤1 : p ∤ 1# + split-∣ : ∀ {x y} → p ∣ x * y → p ∣ x ⊎ p ∣ y \ No newline at end of file diff --git a/Algebra.Definitions.html b/Algebra.Definitions.html index 373334f6..da31987a 100644 --- a/Algebra.Definitions.html +++ b/Algebra.Definitions.html @@ -16,213 +16,217 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary.Core -open import Relation.Nullary.Negation using (¬_) +open import Relation.Binary.Core using (Rel; _Preserves_⟶_; _Preserves₂_⟶_⟶_) +open import Relation.Nullary.Negation.Core using (¬_) -module Algebra.Definitions - {a ℓ} {A : Set a} -- The underlying set - (_≈_ : Rel A ℓ) -- The underlying equality - where +module Algebra.Definitions + {a ℓ} {A : Set a} -- The underlying set + (_≈_ : Rel A ℓ) -- The underlying equality + where -open import Algebra.Core -open import Data.Product -open import Data.Sum.Base +open import Algebra.Core using (Op₁; Op₂) +open import Data.Product.Base using (_×_; ∃-syntax) +open import Data.Sum.Base using (_⊎_) ------------------------------------------------------------------------- --- Properties of operations +------------------------------------------------------------------------ +-- Properties of operations -Congruent₁ : Op₁ A → Set _ -Congruent₁ f = f Preserves _≈_ ⟶ _≈_ +Congruent₁ : Op₁ A → Set _ +Congruent₁ f = f Preserves _≈_ ⟶ _≈_ -Congruent₂ : Op₂ A → Set _ -Congruent₂ ∙ = ∙ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_ +Congruent₂ : Op₂ A → Set _ +Congruent₂ ∙ = ∙ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_ -LeftCongruent : Op₂ A → Set _ -LeftCongruent _∙_ = ∀ {x} → (x ∙_) Preserves _≈_ ⟶ _≈_ +LeftCongruent : Op₂ A → Set _ +LeftCongruent _∙_ = ∀ {x} → (x ∙_) Preserves _≈_ ⟶ _≈_ -RightCongruent : Op₂ A → Set _ -RightCongruent _∙_ = ∀ {x} → (_∙ x) Preserves _≈_ ⟶ _≈_ +RightCongruent : Op₂ A → Set _ +RightCongruent _∙_ = ∀ {x} → (_∙ x) Preserves _≈_ ⟶ _≈_ -Associative : Op₂ A → Set _ -Associative _∙_ = ∀ x y z → ((x ∙ y) ∙ z) ≈ (x ∙ (y ∙ z)) +Associative : Op₂ A → Set _ +Associative _∙_ = ∀ x y z → ((x ∙ y) ∙ z) ≈ (x ∙ (y ∙ z)) -Commutative : Op₂ A → Set _ -Commutative _∙_ = ∀ x y → (x ∙ y) ≈ (y ∙ x) +Commutative : Op₂ A → Set _ +Commutative _∙_ = ∀ x y → (x ∙ y) ≈ (y ∙ x) -LeftIdentity : A → Op₂ A → Set _ -LeftIdentity e _∙_ = ∀ x → (e ∙ x) ≈ x +LeftIdentity : A → Op₂ A → Set _ +LeftIdentity e _∙_ = ∀ x → (e ∙ x) ≈ x -RightIdentity : A → Op₂ A → Set _ -RightIdentity e _∙_ = ∀ x → (x ∙ e) ≈ x +RightIdentity : A → Op₂ A → Set _ +RightIdentity e _∙_ = ∀ x → (x ∙ e) ≈ x -Identity : A → Op₂ A → Set _ -Identity e ∙ = (LeftIdentity e ∙) × (RightIdentity e ∙) +Identity : A → Op₂ A → Set _ +Identity e ∙ = (LeftIdentity e ∙) × (RightIdentity e ∙) -LeftZero : A → Op₂ A → Set _ -LeftZero z _∙_ = ∀ x → (z ∙ x) ≈ z +LeftZero : A → Op₂ A → Set _ +LeftZero z _∙_ = ∀ x → (z ∙ x) ≈ z -RightZero : A → Op₂ A → Set _ -RightZero z _∙_ = ∀ x → (x ∙ z) ≈ z +RightZero : A → Op₂ A → Set _ +RightZero z _∙_ = ∀ x → (x ∙ z) ≈ z -Zero : A → Op₂ A → Set _ -Zero z ∙ = (LeftZero z ∙) × (RightZero z ∙) +Zero : A → Op₂ A → Set _ +Zero z ∙ = (LeftZero z ∙) × (RightZero z ∙) -LeftInverse : A → Op₁ A → Op₂ A → Set _ -LeftInverse e _⁻¹ _∙_ = ∀ x → ((x ⁻¹) ∙ x) ≈ e +LeftInverse : A → Op₁ A → Op₂ A → Set _ +LeftInverse e _⁻¹ _∙_ = ∀ x → ((x ⁻¹) ∙ x) ≈ e -RightInverse : A → Op₁ A → Op₂ A → Set _ -RightInverse e _⁻¹ _∙_ = ∀ x → (x ∙ (x ⁻¹)) ≈ e +RightInverse : A → Op₁ A → Op₂ A → Set _ +RightInverse e _⁻¹ _∙_ = ∀ x → (x ∙ (x ⁻¹)) ≈ e -Inverse : A → Op₁ A → Op₂ A → Set _ -Inverse e ⁻¹ ∙ = (LeftInverse e ⁻¹) ∙ × (RightInverse e ⁻¹ ∙) +Inverse : A → Op₁ A → Op₂ A → Set _ +Inverse e ⁻¹ ∙ = (LeftInverse e ⁻¹) ∙ × (RightInverse e ⁻¹ ∙) --- For structures in which not every element has an inverse (e.g. Fields) -LeftInvertible : A → Op₂ A → A → Set _ -LeftInvertible e _∙_ x = ∃[ x⁻¹ ] (x⁻¹ ∙ x) ≈ e +-- For structures in which not every element has an inverse (e.g. Fields) +LeftInvertible : A → Op₂ A → A → Set _ +LeftInvertible e _∙_ x = ∃[ x⁻¹ ] (x⁻¹ ∙ x) ≈ e -RightInvertible : A → Op₂ A → A → Set _ -RightInvertible e _∙_ x = ∃[ x⁻¹ ] (x ∙ x⁻¹) ≈ e +RightInvertible : A → Op₂ A → A → Set _ +RightInvertible e _∙_ x = ∃[ x⁻¹ ] (x ∙ x⁻¹) ≈ e --- NB: this is not quite the same as --- LeftInvertible e ∙ x × RightInvertible e ∙ x --- since the left and right inverses have to coincide. -Invertible : A → Op₂ A → A → Set _ -Invertible e _∙_ x = ∃[ x⁻¹ ] (x⁻¹ ∙ x) ≈ e × (x ∙ x⁻¹) ≈ e +-- NB: this is not quite the same as +-- LeftInvertible e ∙ x × RightInvertible e ∙ x +-- since the left and right inverses have to coincide. +Invertible : A → Op₂ A → A → Set _ +Invertible e _∙_ x = ∃[ x⁻¹ ] (x⁻¹ ∙ x) ≈ e × (x ∙ x⁻¹) ≈ e -LeftConical : A → Op₂ A → Set _ -LeftConical e _∙_ = ∀ x y → (x ∙ y) ≈ e → x ≈ e +LeftConical : A → Op₂ A → Set _ +LeftConical e _∙_ = ∀ x y → (x ∙ y) ≈ e → x ≈ e -RightConical : A → Op₂ A → Set _ -RightConical e _∙_ = ∀ x y → (x ∙ y) ≈ e → y ≈ e +RightConical : A → Op₂ A → Set _ +RightConical e _∙_ = ∀ x y → (x ∙ y) ≈ e → y ≈ e -Conical : A → Op₂ A → Set _ -Conical e ∙ = (LeftConical e ∙) × (RightConical e ∙) +Conical : A → Op₂ A → Set _ +Conical e ∙ = (LeftConical e ∙) × (RightConical e ∙) -_DistributesOverˡ_ : Op₂ A → Op₂ A → Set _ -_*_ DistributesOverˡ _+_ = - ∀ x y z → (x * (y + z)) ≈ ((x * y) + (x * z)) +_DistributesOverˡ_ : Op₂ A → Op₂ A → Set _ +_*_ DistributesOverˡ _+_ = + ∀ x y z → (x * (y + z)) ≈ ((x * y) + (x * z)) -_DistributesOverʳ_ : Op₂ A → Op₂ A → Set _ -_*_ DistributesOverʳ _+_ = - ∀ x y z → ((y + z) * x) ≈ ((y * x) + (z * x)) +_DistributesOverʳ_ : Op₂ A → Op₂ A → Set _ +_*_ DistributesOverʳ _+_ = + ∀ x y z → ((y + z) * x) ≈ ((y * x) + (z * x)) -_DistributesOver_ : Op₂ A → Op₂ A → Set _ -* DistributesOver + = (* DistributesOverˡ +) × (* DistributesOverʳ +) +_DistributesOver_ : Op₂ A → Op₂ A → Set _ +* DistributesOver + = (* DistributesOverˡ +) × (* DistributesOverʳ +) -_IdempotentOn_ : Op₂ A → A → Set _ -_∙_ IdempotentOn x = (x ∙ x) ≈ x +_MiddleFourExchange_ : Op₂ A → Op₂ A → Set _ +_*_ MiddleFourExchange _+_ = + ∀ w x y z → ((w + x) * (y + z)) ≈ ((w + y) * (x + z)) -Idempotent : Op₂ A → Set _ -Idempotent ∙ = ∀ x → ∙ IdempotentOn x +_IdempotentOn_ : Op₂ A → A → Set _ +_∙_ IdempotentOn x = (x ∙ x) ≈ x -IdempotentFun : Op₁ A → Set _ -IdempotentFun f = ∀ x → f (f x) ≈ f x +Idempotent : Op₂ A → Set _ +Idempotent ∙ = ∀ x → ∙ IdempotentOn x -Selective : Op₂ A → Set _ -Selective _∙_ = ∀ x y → (x ∙ y) ≈ x ⊎ (x ∙ y) ≈ y +IdempotentFun : Op₁ A → Set _ +IdempotentFun f = ∀ x → f (f x) ≈ f x -_Absorbs_ : Op₂ A → Op₂ A → Set _ -_∙_ Absorbs _∘_ = ∀ x y → (x ∙ (x ∘ y)) ≈ x +Selective : Op₂ A → Set _ +Selective _∙_ = ∀ x y → (x ∙ y) ≈ x ⊎ (x ∙ y) ≈ y -Absorptive : Op₂ A → Op₂ A → Set _ -Absorptive ∙ ∘ = (∙ Absorbs ∘) × (∘ Absorbs ∙) +_Absorbs_ : Op₂ A → Op₂ A → Set _ +_∙_ Absorbs _∘_ = ∀ x y → (x ∙ (x ∘ y)) ≈ x -SelfInverse : Op₁ A → Set _ -SelfInverse f = ∀ {x y} → f x ≈ y → f y ≈ x +Absorptive : Op₂ A → Op₂ A → Set _ +Absorptive ∙ ∘ = (∙ Absorbs ∘) × (∘ Absorbs ∙) -Involutive : Op₁ A → Set _ -Involutive f = ∀ x → f (f x) ≈ x +SelfInverse : Op₁ A → Set _ +SelfInverse f = ∀ {x y} → f x ≈ y → f y ≈ x -LeftCancellative : Op₂ A → Set _ -LeftCancellative _•_ = ∀ x y z → (x • y) ≈ (x • z) → y ≈ z +Involutive : Op₁ A → Set _ +Involutive f = ∀ x → f (f x) ≈ x -RightCancellative : Op₂ A → Set _ -RightCancellative _•_ = ∀ x y z → (y • x) ≈ (z • x) → y ≈ z +LeftCancellative : Op₂ A → Set _ +LeftCancellative _•_ = ∀ x y z → (x • y) ≈ (x • z) → y ≈ z -Cancellative : Op₂ A → Set _ -Cancellative _•_ = (LeftCancellative _•_) × (RightCancellative _•_) +RightCancellative : Op₂ A → Set _ +RightCancellative _•_ = ∀ x y z → (y • x) ≈ (z • x) → y ≈ z -AlmostLeftCancellative : A → Op₂ A → Set _ -AlmostLeftCancellative e _•_ = ∀ x y z → ¬ x ≈ e → (x • y) ≈ (x • z) → y ≈ z +Cancellative : Op₂ A → Set _ +Cancellative _•_ = (LeftCancellative _•_) × (RightCancellative _•_) -AlmostRightCancellative : A → Op₂ A → Set _ -AlmostRightCancellative e _•_ = ∀ x y z → ¬ x ≈ e → (y • x) ≈ (z • x) → y ≈ z +AlmostLeftCancellative : A → Op₂ A → Set _ +AlmostLeftCancellative e _•_ = ∀ x y z → ¬ x ≈ e → (x • y) ≈ (x • z) → y ≈ z -AlmostCancellative : A → Op₂ A → Set _ -AlmostCancellative e _•_ = AlmostLeftCancellative e _•_ × AlmostRightCancellative e _•_ +AlmostRightCancellative : A → Op₂ A → Set _ +AlmostRightCancellative e _•_ = ∀ x y z → ¬ x ≈ e → (y • x) ≈ (z • x) → y ≈ z -Interchangable : Op₂ A → Op₂ A → Set _ -Interchangable _∘_ _∙_ = ∀ w x y z → ((w ∙ x) ∘ (y ∙ z)) ≈ ((w ∘ y) ∙ (x ∘ z)) +AlmostCancellative : A → Op₂ A → Set _ +AlmostCancellative e _•_ = AlmostLeftCancellative e _•_ × AlmostRightCancellative e _•_ -LeftDividesˡ : Op₂ A → Op₂ A → Set _ -LeftDividesˡ _∙_ _\\_ = ∀ x y → (x ∙ (x \\ y)) ≈ y +Interchangable : Op₂ A → Op₂ A → Set _ +Interchangable _∘_ _∙_ = ∀ w x y z → ((w ∙ x) ∘ (y ∙ z)) ≈ ((w ∘ y) ∙ (x ∘ z)) -LeftDividesʳ : Op₂ A → Op₂ A → Set _ -LeftDividesʳ _∙_ _\\_ = ∀ x y → (x \\ (x ∙ y)) ≈ y +LeftDividesˡ : Op₂ A → Op₂ A → Set _ +LeftDividesˡ _∙_ _\\_ = ∀ x y → (x ∙ (x \\ y)) ≈ y -RightDividesˡ : Op₂ A → Op₂ A → Set _ -RightDividesˡ _∙_ _//_ = ∀ x y → ((y // x) ∙ x) ≈ y +LeftDividesʳ : Op₂ A → Op₂ A → Set _ +LeftDividesʳ _∙_ _\\_ = ∀ x y → (x \\ (x ∙ y)) ≈ y -RightDividesʳ : Op₂ A → Op₂ A → Set _ -RightDividesʳ _∙_ _//_ = ∀ x y → ((y ∙ x) // x) ≈ y +RightDividesˡ : Op₂ A → Op₂ A → Set _ +RightDividesˡ _∙_ _//_ = ∀ x y → ((y // x) ∙ x) ≈ y -LeftDivides : Op₂ A → Op₂ A → Set _ -LeftDivides ∙ \\ = (LeftDividesˡ ∙ \\) × (LeftDividesʳ ∙ \\) +RightDividesʳ : Op₂ A → Op₂ A → Set _ +RightDividesʳ _∙_ _//_ = ∀ x y → ((y ∙ x) // x) ≈ y -RightDivides : Op₂ A → Op₂ A → Set _ -RightDivides ∙ // = (RightDividesˡ ∙ //) × (RightDividesʳ ∙ //) +LeftDivides : Op₂ A → Op₂ A → Set _ +LeftDivides ∙ \\ = (LeftDividesˡ ∙ \\) × (LeftDividesʳ ∙ \\) -StarRightExpansive : A → Op₂ A → Op₂ A → Op₁ A → Set _ -StarRightExpansive e _+_ _∙_ _* = ∀ x → (e + (x ∙ (x *))) ≈ (x *) +RightDivides : Op₂ A → Op₂ A → Set _ +RightDivides ∙ // = (RightDividesˡ ∙ //) × (RightDividesʳ ∙ //) -StarLeftExpansive : A → Op₂ A → Op₂ A → Op₁ A → Set _ -StarLeftExpansive e _+_ _∙_ _* = ∀ x → (e + ((x *) ∙ x)) ≈ (x *) +StarRightExpansive : A → Op₂ A → Op₂ A → Op₁ A → Set _ +StarRightExpansive e _+_ _∙_ _* = ∀ x → (e + (x ∙ (x *))) ≈ (x *) -StarExpansive : A → Op₂ A → Op₂ A → Op₁ A → Set _ -StarExpansive e _+_ _∙_ _* = (StarLeftExpansive e _+_ _∙_ _*) × (StarRightExpansive e _+_ _∙_ _*) +StarLeftExpansive : A → Op₂ A → Op₂ A → Op₁ A → Set _ +StarLeftExpansive e _+_ _∙_ _* = ∀ x → (e + ((x *) ∙ x)) ≈ (x *) -StarLeftDestructive : Op₂ A → Op₂ A → Op₁ A → Set _ -StarLeftDestructive _+_ _∙_ _* = ∀ a b x → (b + (a ∙ x)) ≈ x → ((a *) ∙ b) ≈ x +StarExpansive : A → Op₂ A → Op₂ A → Op₁ A → Set _ +StarExpansive e _+_ _∙_ _* = (StarLeftExpansive e _+_ _∙_ _*) × (StarRightExpansive e _+_ _∙_ _*) -StarRightDestructive : Op₂ A → Op₂ A → Op₁ A → Set _ -StarRightDestructive _+_ _∙_ _* = ∀ a b x → (b + (x ∙ a)) ≈ x → (b ∙ (a *)) ≈ x +StarLeftDestructive : Op₂ A → Op₂ A → Op₁ A → Set _ +StarLeftDestructive _+_ _∙_ _* = ∀ a b x → (b + (a ∙ x)) ≈ x → ((a *) ∙ b) ≈ x -StarDestructive : Op₂ A → Op₂ A → Op₁ A → Set _ -StarDestructive _+_ _∙_ _* = (StarLeftDestructive _+_ _∙_ _*) × (StarRightDestructive _+_ _∙_ _*) +StarRightDestructive : Op₂ A → Op₂ A → Op₁ A → Set _ +StarRightDestructive _+_ _∙_ _* = ∀ a b x → (b + (x ∙ a)) ≈ x → (b ∙ (a *)) ≈ x -LeftAlternative : Op₂ A → Set _ -LeftAlternative _∙_ = ∀ x y → ((x ∙ x) ∙ y) ≈ (x ∙ (x ∙ y)) +StarDestructive : Op₂ A → Op₂ A → Op₁ A → Set _ +StarDestructive _+_ _∙_ _* = (StarLeftDestructive _+_ _∙_ _*) × (StarRightDestructive _+_ _∙_ _*) -RightAlternative : Op₂ A → Set _ -RightAlternative _∙_ = ∀ x y → (x ∙ (y ∙ y)) ≈ ((x ∙ y) ∙ y) +LeftAlternative : Op₂ A → Set _ +LeftAlternative _∙_ = ∀ x y → ((x ∙ x) ∙ y) ≈ (x ∙ (x ∙ y)) -Alternative : Op₂ A → Set _ -Alternative _∙_ = (LeftAlternative _∙_ ) × (RightAlternative _∙_) +RightAlternative : Op₂ A → Set _ +RightAlternative _∙_ = ∀ x y → (x ∙ (y ∙ y)) ≈ ((x ∙ y) ∙ y) -Flexible : Op₂ A → Set _ -Flexible _∙_ = ∀ x y → ((x ∙ y) ∙ x) ≈ (x ∙ (y ∙ x)) +Alternative : Op₂ A → Set _ +Alternative _∙_ = (LeftAlternative _∙_ ) × (RightAlternative _∙_) -Medial : Op₂ A → Set _ -Medial _∙_ = ∀ x y u z → ((x ∙ y) ∙ (u ∙ z)) ≈ ((x ∙ u) ∙ (y ∙ z)) +Flexible : Op₂ A → Set _ +Flexible _∙_ = ∀ x y → ((x ∙ y) ∙ x) ≈ (x ∙ (y ∙ x)) -LeftSemimedial : Op₂ A → Set _ -LeftSemimedial _∙_ = ∀ x y z → ((x ∙ x) ∙ (y ∙ z)) ≈ ((x ∙ y) ∙ (x ∙ z)) +Medial : Op₂ A → Set _ +Medial _∙_ = ∀ x y u z → ((x ∙ y) ∙ (u ∙ z)) ≈ ((x ∙ u) ∙ (y ∙ z)) -RightSemimedial : Op₂ A → Set _ -RightSemimedial _∙_ = ∀ x y z → ((y ∙ z) ∙ (x ∙ x)) ≈ ((y ∙ x) ∙ (z ∙ x)) +LeftSemimedial : Op₂ A → Set _ +LeftSemimedial _∙_ = ∀ x y z → ((x ∙ x) ∙ (y ∙ z)) ≈ ((x ∙ y) ∙ (x ∙ z)) -Semimedial : Op₂ A → Set _ -Semimedial _∙_ = (LeftSemimedial _∙_) × (RightSemimedial _∙_) +RightSemimedial : Op₂ A → Set _ +RightSemimedial _∙_ = ∀ x y z → ((y ∙ z) ∙ (x ∙ x)) ≈ ((y ∙ x) ∙ (z ∙ x)) -LeftBol : Op₂ A → Set _ -LeftBol _∙_ = ∀ x y z → (x ∙ (y ∙ (x ∙ z))) ≈ ((x ∙ (y ∙ x)) ∙ z ) +Semimedial : Op₂ A → Set _ +Semimedial _∙_ = (LeftSemimedial _∙_) × (RightSemimedial _∙_) -RightBol : Op₂ A → Set _ -RightBol _∙_ = ∀ x y z → (((z ∙ x) ∙ y) ∙ x) ≈ (z ∙ ((x ∙ y) ∙ x)) +LeftBol : Op₂ A → Set _ +LeftBol _∙_ = ∀ x y z → (x ∙ (y ∙ (x ∙ z))) ≈ ((x ∙ (y ∙ x)) ∙ z ) -MiddleBol : Op₂ A → Op₂ A → Op₂ A → Set _ -MiddleBol _∙_ _\\_ _//_ = ∀ x y z → (x ∙ ((y ∙ z) \\ x)) ≈ ((x // z) ∙ (y \\ x)) +RightBol : Op₂ A → Set _ +RightBol _∙_ = ∀ x y z → (((z ∙ x) ∙ y) ∙ x) ≈ (z ∙ ((x ∙ y) ∙ x)) -Identical : Op₂ A → Set _ -Identical _∙_ = ∀ x y z → ((z ∙ x) ∙ (y ∙ z)) ≈ (z ∙ ((x ∙ y) ∙ z)) +MiddleBol : Op₂ A → Op₂ A → Op₂ A → Set _ +MiddleBol _∙_ _\\_ _//_ = ∀ x y z → (x ∙ ((y ∙ z) \\ x)) ≈ ((x // z) ∙ (y \\ x)) + +Identical : Op₂ A → Set _ +Identical _∙_ = ∀ x y z → ((z ∙ x) ∙ (y ∙ z)) ≈ (z ∙ ((x ∙ y) ∙ z)) \ No newline at end of file diff --git a/Algebra.Lattice.Bundles.Raw.html b/Algebra.Lattice.Bundles.Raw.html index bc4ff7d2..5d23f161 100644 --- a/Algebra.Lattice.Bundles.Raw.html +++ b/Algebra.Lattice.Bundles.Raw.html @@ -12,24 +12,24 @@ open import Algebra.Core open import Algebra.Bundles.Raw using (RawMagma) open import Level using (suc; _⊔_) -open import Relation.Binary using (Rel) +open import Relation.Binary.Core using (Rel) -record RawLattice c ℓ : Set (suc (c ⊔ ℓ)) where - infixr 7 _∧_ - infixr 6 _∨_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∧_ : Op₂ Carrier - _∨_ : Op₂ Carrier +record RawLattice c ℓ : Set (suc (c ⊔ ℓ)) where + infixr 7 _∧_ + infixr 6 _∨_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∧_ : Op₂ Carrier + _∨_ : Op₂ Carrier - ∨-rawMagma : RawMagma c ℓ - ∨-rawMagma = record { _≈_ = _≈_; _∙_ = _∨_ } + ∨-rawMagma : RawMagma c ℓ + ∨-rawMagma = record { _≈_ = _≈_; _∙_ = _∨_ } - ∧-rawMagma : RawMagma c ℓ - ∧-rawMagma = record { _≈_ = _≈_; _∙_ = _∧_ } + ∧-rawMagma : RawMagma c ℓ + ∧-rawMagma = record { _≈_ = _≈_; _∙_ = _∧_ } - open RawMagma ∨-rawMagma public - using (_≉_) + open RawMagma ∨-rawMagma public + using (_≉_) \ No newline at end of file diff --git a/Algebra.Lattice.Bundles.html b/Algebra.Lattice.Bundles.html index 52d6c673..060a29ed 100644 --- a/Algebra.Lattice.Bundles.html +++ b/Algebra.Lattice.Bundles.html @@ -22,209 +22,210 @@ import Algebra.Lattice.Bundles.Raw as Raw open import Algebra.Lattice.Structures open import Level using (suc; _⊔_) -open import Relation.Binary +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Binary.Core using (Rel) ------------------------------------------------------------------------- --- Re-export definitions of 'raw' bundles +------------------------------------------------------------------------ +-- Re-export definitions of 'raw' bundles -open Raw public - using (RawLattice) +open Raw public + using (RawLattice) ------------------------------------------------------------------------- --- Bundles ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Bundles +------------------------------------------------------------------------ -record Semilattice c ℓ : Set (suc (c ⊔ ℓ)) where - infixr 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - isSemilattice : IsSemilattice _≈_ _∙_ +record Semilattice c ℓ : Set (suc (c ⊔ ℓ)) where + infixr 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + isSemilattice : IsSemilattice _≈_ _∙_ - open IsSemilattice isSemilattice public + open IsSemilattice isSemilattice public - band : Band c ℓ - band = record { isBand = isBand } + band : Band c ℓ + band = record { isBand = isBand } - open Band band public - using (_≉_; rawMagma; magma; isMagma; semigroup; isSemigroup; isBand) + open Band band public + using (_≉_; rawMagma; magma; isMagma; semigroup; isSemigroup; isBand) -record MeetSemilattice c ℓ : Set (suc (c ⊔ ℓ)) where - infixr 7 _∧_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∧_ : Op₂ Carrier - isMeetSemilattice : IsSemilattice _≈_ _∧_ +record MeetSemilattice c ℓ : Set (suc (c ⊔ ℓ)) where + infixr 7 _∧_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∧_ : Op₂ Carrier + isMeetSemilattice : IsSemilattice _≈_ _∧_ - open IsMeetSemilattice _≈_ isMeetSemilattice public + open IsMeetSemilattice _≈_ isMeetSemilattice public - semilattice : Semilattice c ℓ - semilattice = record { isSemilattice = isMeetSemilattice } + semilattice : Semilattice c ℓ + semilattice = record { isSemilattice = isMeetSemilattice } - open Semilattice semilattice public - using (rawMagma; magma; semigroup; band) + open Semilattice semilattice public + using (rawMagma; magma; semigroup; band) -record JoinSemilattice c ℓ : Set (suc (c ⊔ ℓ)) where - infixr 7 _∨_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∨_ : Op₂ Carrier - isJoinSemilattice : IsSemilattice _≈_ _∨_ +record JoinSemilattice c ℓ : Set (suc (c ⊔ ℓ)) where + infixr 7 _∨_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∨_ : Op₂ Carrier + isJoinSemilattice : IsSemilattice _≈_ _∨_ - open IsJoinSemilattice _≈_ isJoinSemilattice public + open IsJoinSemilattice _≈_ isJoinSemilattice public - semilattice : Semilattice c ℓ - semilattice = record { isSemilattice = isJoinSemilattice } + semilattice : Semilattice c ℓ + semilattice = record { isSemilattice = isJoinSemilattice } - open Semilattice semilattice public - using (rawMagma; magma; semigroup; band) + open Semilattice semilattice public + using (rawMagma; magma; semigroup; band) -record BoundedSemilattice c ℓ : Set (suc (c ⊔ ℓ)) where - infixr 7 _∙_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∙_ : Op₂ Carrier - ε : Carrier - isBoundedSemilattice : IsBoundedSemilattice _≈_ _∙_ ε +record BoundedSemilattice c ℓ : Set (suc (c ⊔ ℓ)) where + infixr 7 _∙_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∙_ : Op₂ Carrier + ε : Carrier + isBoundedSemilattice : IsBoundedSemilattice _≈_ _∙_ ε - open IsBoundedSemilattice _≈_ isBoundedSemilattice public + open IsBoundedSemilattice _≈_ isBoundedSemilattice public - semilattice : Semilattice c ℓ - semilattice = record { isSemilattice = isSemilattice } + semilattice : Semilattice c ℓ + semilattice = record { isSemilattice = isSemilattice } - open Semilattice semilattice public using (rawMagma; magma; semigroup; band) + open Semilattice semilattice public using (rawMagma; magma; semigroup; band) -record BoundedMeetSemilattice c ℓ : Set (suc (c ⊔ ℓ)) where - infixr 7 _∧_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∧_ : Op₂ Carrier - ⊤ : Carrier - isBoundedMeetSemilattice : IsBoundedSemilattice _≈_ _∧_ ⊤ +record BoundedMeetSemilattice c ℓ : Set (suc (c ⊔ ℓ)) where + infixr 7 _∧_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∧_ : Op₂ Carrier + ⊤ : Carrier + isBoundedMeetSemilattice : IsBoundedSemilattice _≈_ _∧_ ⊤ - open IsBoundedMeetSemilattice _≈_ isBoundedMeetSemilattice public - - boundedSemilattice : BoundedSemilattice c ℓ - boundedSemilattice = record - { isBoundedSemilattice = isBoundedMeetSemilattice } - - open BoundedSemilattice boundedSemilattice public - using (rawMagma; magma; semigroup; band; semilattice) - - -record BoundedJoinSemilattice c ℓ : Set (suc (c ⊔ ℓ)) where - infixr 7 _∨_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∨_ : Op₂ Carrier - ⊥ : Carrier - isBoundedJoinSemilattice : IsBoundedSemilattice _≈_ _∨_ ⊥ - - open IsBoundedJoinSemilattice _≈_ isBoundedJoinSemilattice public - - boundedSemilattice : BoundedSemilattice c ℓ - boundedSemilattice = record - { isBoundedSemilattice = isBoundedJoinSemilattice } - - open BoundedSemilattice boundedSemilattice public - using (rawMagma; magma; semigroup; band; semilattice) - - -record Lattice c ℓ : Set (suc (c ⊔ ℓ)) where - infixr 7 _∧_ - infixr 6 _∨_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∨_ : Op₂ Carrier - _∧_ : Op₂ Carrier - isLattice : IsLattice _≈_ _∨_ _∧_ - - open IsLattice isLattice public - - rawLattice : RawLattice c ℓ - rawLattice = record - { _≈_ = _≈_ - ; _∧_ = _∧_ - ; _∨_ = _∨_ - } - - open RawLattice rawLattice public - using (∨-rawMagma; ∧-rawMagma) - - setoid : Setoid c ℓ - setoid = record { isEquivalence = isEquivalence } - - open Setoid setoid public - using (_≉_) - - -record DistributiveLattice c ℓ : Set (suc (c ⊔ ℓ)) where - infixr 7 _∧_ - infixr 6 _∨_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∨_ : Op₂ Carrier - _∧_ : Op₂ Carrier - isDistributiveLattice : IsDistributiveLattice _≈_ _∨_ _∧_ - - open IsDistributiveLattice isDistributiveLattice public - - lattice : Lattice _ _ - lattice = record { isLattice = isLattice } - - open Lattice lattice public - using - ( _≉_; setoid; rawLattice - ; ∨-rawMagma; ∧-rawMagma - ) - - -record BooleanAlgebra c ℓ : Set (suc (c ⊔ ℓ)) where - infix 8 ¬_ - infixr 7 _∧_ - infixr 6 _∨_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _∨_ : Op₂ Carrier - _∧_ : Op₂ Carrier - ¬_ : Op₁ Carrier - ⊤ : Carrier - ⊥ : Carrier - isBooleanAlgebra : IsBooleanAlgebra _≈_ _∨_ _∧_ ¬_ ⊤ ⊥ - - open IsBooleanAlgebra isBooleanAlgebra public - - distributiveLattice : DistributiveLattice _ _ - distributiveLattice = record - { isDistributiveLattice = isDistributiveLattice - } - - open DistributiveLattice distributiveLattice public - using - ( _≉_; setoid; rawLattice - ; ∨-rawMagma; ∧-rawMagma - ; lattice - ) + open IsBoundedMeetSemilattice _≈_ isBoundedMeetSemilattice public + + boundedSemilattice : BoundedSemilattice c ℓ + boundedSemilattice = record + { isBoundedSemilattice = isBoundedMeetSemilattice } + + open BoundedSemilattice boundedSemilattice public + using (rawMagma; magma; semigroup; band; semilattice) + + +record BoundedJoinSemilattice c ℓ : Set (suc (c ⊔ ℓ)) where + infixr 7 _∨_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∨_ : Op₂ Carrier + ⊥ : Carrier + isBoundedJoinSemilattice : IsBoundedSemilattice _≈_ _∨_ ⊥ + + open IsBoundedJoinSemilattice _≈_ isBoundedJoinSemilattice public + + boundedSemilattice : BoundedSemilattice c ℓ + boundedSemilattice = record + { isBoundedSemilattice = isBoundedJoinSemilattice } + + open BoundedSemilattice boundedSemilattice public + using (rawMagma; magma; semigroup; band; semilattice) + + +record Lattice c ℓ : Set (suc (c ⊔ ℓ)) where + infixr 7 _∧_ + infixr 6 _∨_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∨_ : Op₂ Carrier + _∧_ : Op₂ Carrier + isLattice : IsLattice _≈_ _∨_ _∧_ + + open IsLattice isLattice public + + rawLattice : RawLattice c ℓ + rawLattice = record + { _≈_ = _≈_ + ; _∧_ = _∧_ + ; _∨_ = _∨_ + } + + open RawLattice rawLattice public + using (∨-rawMagma; ∧-rawMagma) + + setoid : Setoid c ℓ + setoid = record { isEquivalence = isEquivalence } + + open Setoid setoid public + using (_≉_) + + +record DistributiveLattice c ℓ : Set (suc (c ⊔ ℓ)) where + infixr 7 _∧_ + infixr 6 _∨_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∨_ : Op₂ Carrier + _∧_ : Op₂ Carrier + isDistributiveLattice : IsDistributiveLattice _≈_ _∨_ _∧_ + + open IsDistributiveLattice isDistributiveLattice public + + lattice : Lattice _ _ + lattice = record { isLattice = isLattice } + + open Lattice lattice public + using + ( _≉_; setoid; rawLattice + ; ∨-rawMagma; ∧-rawMagma + ) + + +record BooleanAlgebra c ℓ : Set (suc (c ⊔ ℓ)) where + infix 8 ¬_ + infixr 7 _∧_ + infixr 6 _∨_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _∨_ : Op₂ Carrier + _∧_ : Op₂ Carrier + ¬_ : Op₁ Carrier + ⊤ : Carrier + ⊥ : Carrier + isBooleanAlgebra : IsBooleanAlgebra _≈_ _∨_ _∧_ ¬_ ⊤ ⊥ + + open IsBooleanAlgebra isBooleanAlgebra public + + distributiveLattice : DistributiveLattice _ _ + distributiveLattice = record + { isDistributiveLattice = isDistributiveLattice + } + + open DistributiveLattice distributiveLattice public + using + ( _≉_; setoid; rawLattice + ; ∨-rawMagma; ∧-rawMagma + ; lattice + ) \ No newline at end of file diff --git a/Algebra.Lattice.Construct.NaturalChoice.MaxOp.html b/Algebra.Lattice.Construct.NaturalChoice.MaxOp.html index 504b6e14..00e78a58 100644 --- a/Algebra.Lattice.Construct.NaturalChoice.MaxOp.html +++ b/Algebra.Lattice.Construct.NaturalChoice.MaxOp.html @@ -10,19 +10,19 @@ open import Algebra.Construct.NaturalChoice.Base import Algebra.Lattice.Construct.NaturalChoice.MinOp as MinOp -open import Relation.Binary +open import Relation.Binary.Bundles using (TotalPreorder) -module Algebra.Lattice.Construct.NaturalChoice.MaxOp - {a ℓ₁ ℓ₂} {O : TotalPreorder a ℓ₁ ℓ₂} (maxOp : MaxOperator O) - where +module Algebra.Lattice.Construct.NaturalChoice.MaxOp + {a ℓ₁ ℓ₂} {O : TotalPreorder a ℓ₁ ℓ₂} (maxOp : MaxOperator O) + where -private - module Min = MinOp (MaxOp⇒MinOp maxOp) +private + module Min = MinOp (MaxOp⇒MinOp maxOp) -open Min public - using () - renaming - ( ⊓-isSemilattice to ⊔-isSemilattice - ; ⊓-semilattice to ⊔-semilattice - ) +open Min public + using () + renaming + ( ⊓-isSemilattice to ⊔-isSemilattice + ; ⊓-semilattice to ⊔-semilattice + ) \ No newline at end of file diff --git a/Algebra.Lattice.Construct.NaturalChoice.MinMaxOp.html b/Algebra.Lattice.Construct.NaturalChoice.MinMaxOp.html index 59a18755..464c6816 100644 --- a/Algebra.Lattice.Construct.NaturalChoice.MinMaxOp.html +++ b/Algebra.Lattice.Construct.NaturalChoice.MinMaxOp.html @@ -9,89 +9,89 @@ open import Algebra.Lattice.Bundles open import Algebra.Construct.NaturalChoice.Base -open import Relation.Binary - -module Algebra.Lattice.Construct.NaturalChoice.MinMaxOp - {a ℓ₁ ℓ₂} {O : TotalPreorder a ℓ₁ ℓ₂} - (minOp : MinOperator O) - (maxOp : MaxOperator O) - where - -open TotalPreorder O -open MinOperator minOp -open MaxOperator maxOp - -open import Algebra.Lattice.Structures _≈_ -open import Algebra.Construct.NaturalChoice.MinMaxOp minOp maxOp -open import Relation.Binary.Reasoning.Preorder preorder - ------------------------------------------------------------------------- --- Re-export properties of individual operators - -open import Algebra.Lattice.Construct.NaturalChoice.MinOp minOp public -open import Algebra.Lattice.Construct.NaturalChoice.MaxOp maxOp public - ------------------------------------------------------------------------- --- Structures - -⊔-⊓-isLattice : IsLattice _⊔_ _⊓_ -⊔-⊓-isLattice = record - { isEquivalence = isEquivalence - ; ∨-comm = ⊔-comm - ; ∨-assoc = ⊔-assoc - ; ∨-cong = ⊔-cong - ; ∧-comm = ⊓-comm - ; ∧-assoc = ⊓-assoc - ; ∧-cong = ⊓-cong - ; absorptive = ⊔-⊓-absorptive - } - -⊓-⊔-isLattice : IsLattice _⊓_ _⊔_ -⊓-⊔-isLattice = record - { isEquivalence = isEquivalence - ; ∨-comm = ⊓-comm - ; ∨-assoc = ⊓-assoc - ; ∨-cong = ⊓-cong - ; ∧-comm = ⊔-comm - ; ∧-assoc = ⊔-assoc - ; ∧-cong = ⊔-cong - ; absorptive = ⊓-⊔-absorptive - } - -⊓-⊔-isDistributiveLattice : IsDistributiveLattice _⊓_ _⊔_ -⊓-⊔-isDistributiveLattice = record - { isLattice = ⊓-⊔-isLattice - ; ∨-distrib-∧ = ⊓-distrib-⊔ - ; ∧-distrib-∨ = ⊔-distrib-⊓ - } - -⊔-⊓-isDistributiveLattice : IsDistributiveLattice _⊔_ _⊓_ -⊔-⊓-isDistributiveLattice = record - { isLattice = ⊔-⊓-isLattice - ; ∨-distrib-∧ = ⊔-distrib-⊓ - ; ∧-distrib-∨ = ⊓-distrib-⊔ - } - ------------------------------------------------------------------------- --- Bundles - -⊔-⊓-lattice : Lattice _ _ -⊔-⊓-lattice = record - { isLattice = ⊔-⊓-isLattice - } - -⊓-⊔-lattice : Lattice _ _ -⊓-⊔-lattice = record - { isLattice = ⊓-⊔-isLattice - } - -⊔-⊓-distributiveLattice : DistributiveLattice _ _ -⊔-⊓-distributiveLattice = record - { isDistributiveLattice = ⊔-⊓-isDistributiveLattice - } - -⊓-⊔-distributiveLattice : DistributiveLattice _ _ -⊓-⊔-distributiveLattice = record - { isDistributiveLattice = ⊓-⊔-isDistributiveLattice - } +open import Relation.Binary.Bundles using (TotalPreorder) + +module Algebra.Lattice.Construct.NaturalChoice.MinMaxOp + {a ℓ₁ ℓ₂} {O : TotalPreorder a ℓ₁ ℓ₂} + (minOp : MinOperator O) + (maxOp : MaxOperator O) + where + +open TotalPreorder O +open MinOperator minOp +open MaxOperator maxOp + +open import Algebra.Lattice.Structures _≈_ +open import Algebra.Construct.NaturalChoice.MinMaxOp minOp maxOp +open import Relation.Binary.Reasoning.Preorder preorder + +------------------------------------------------------------------------ +-- Re-export properties of individual operators + +open import Algebra.Lattice.Construct.NaturalChoice.MinOp minOp public +open import Algebra.Lattice.Construct.NaturalChoice.MaxOp maxOp public + +------------------------------------------------------------------------ +-- Structures + +⊔-⊓-isLattice : IsLattice _⊔_ _⊓_ +⊔-⊓-isLattice = record + { isEquivalence = isEquivalence + ; ∨-comm = ⊔-comm + ; ∨-assoc = ⊔-assoc + ; ∨-cong = ⊔-cong + ; ∧-comm = ⊓-comm + ; ∧-assoc = ⊓-assoc + ; ∧-cong = ⊓-cong + ; absorptive = ⊔-⊓-absorptive + } + +⊓-⊔-isLattice : IsLattice _⊓_ _⊔_ +⊓-⊔-isLattice = record + { isEquivalence = isEquivalence + ; ∨-comm = ⊓-comm + ; ∨-assoc = ⊓-assoc + ; ∨-cong = ⊓-cong + ; ∧-comm = ⊔-comm + ; ∧-assoc = ⊔-assoc + ; ∧-cong = ⊔-cong + ; absorptive = ⊓-⊔-absorptive + } + +⊓-⊔-isDistributiveLattice : IsDistributiveLattice _⊓_ _⊔_ +⊓-⊔-isDistributiveLattice = record + { isLattice = ⊓-⊔-isLattice + ; ∨-distrib-∧ = ⊓-distrib-⊔ + ; ∧-distrib-∨ = ⊔-distrib-⊓ + } + +⊔-⊓-isDistributiveLattice : IsDistributiveLattice _⊔_ _⊓_ +⊔-⊓-isDistributiveLattice = record + { isLattice = ⊔-⊓-isLattice + ; ∨-distrib-∧ = ⊔-distrib-⊓ + ; ∧-distrib-∨ = ⊓-distrib-⊔ + } + +------------------------------------------------------------------------ +-- Bundles + +⊔-⊓-lattice : Lattice _ _ +⊔-⊓-lattice = record + { isLattice = ⊔-⊓-isLattice + } + +⊓-⊔-lattice : Lattice _ _ +⊓-⊔-lattice = record + { isLattice = ⊓-⊔-isLattice + } + +⊔-⊓-distributiveLattice : DistributiveLattice _ _ +⊔-⊓-distributiveLattice = record + { isDistributiveLattice = ⊔-⊓-isDistributiveLattice + } + +⊓-⊔-distributiveLattice : DistributiveLattice _ _ +⊓-⊔-distributiveLattice = record + { isDistributiveLattice = ⊓-⊔-isDistributiveLattice + } \ No newline at end of file diff --git a/Algebra.Lattice.Construct.NaturalChoice.MinOp.html b/Algebra.Lattice.Construct.NaturalChoice.MinOp.html index 7315efab..404d7342 100644 --- a/Algebra.Lattice.Construct.NaturalChoice.MinOp.html +++ b/Algebra.Lattice.Construct.NaturalChoice.MinOp.html @@ -11,31 +11,31 @@ open import Algebra.Bundles open import Algebra.Lattice.Bundles open import Algebra.Construct.NaturalChoice.Base -open import Relation.Binary +open import Relation.Binary.Bundles using (TotalPreorder) -module Algebra.Lattice.Construct.NaturalChoice.MinOp - {a ℓ₁ ℓ₂} {O : TotalPreorder a ℓ₁ ℓ₂} (minOp : MinOperator O) where +module Algebra.Lattice.Construct.NaturalChoice.MinOp + {a ℓ₁ ℓ₂} {O : TotalPreorder a ℓ₁ ℓ₂} (minOp : MinOperator O) where -open TotalPreorder O -open MinOperator minOp +open TotalPreorder O +open MinOperator minOp -open import Algebra.Lattice.Structures _≈_ -open import Algebra.Construct.NaturalChoice.MinOp minOp +open import Algebra.Lattice.Structures _≈_ +open import Algebra.Construct.NaturalChoice.MinOp minOp ------------------------------------------------------------------------- --- Structures +------------------------------------------------------------------------ +-- Structures -⊓-isSemilattice : IsSemilattice _⊓_ -⊓-isSemilattice = record - { isBand = ⊓-isBand - ; comm = ⊓-comm - } +⊓-isSemilattice : IsSemilattice _⊓_ +⊓-isSemilattice = record + { isBand = ⊓-isBand + ; comm = ⊓-comm + } ------------------------------------------------------------------------- --- Bundles +------------------------------------------------------------------------ +-- Bundles -⊓-semilattice : Semilattice _ _ -⊓-semilattice = record - { isSemilattice = ⊓-isSemilattice - } +⊓-semilattice : Semilattice _ _ +⊓-semilattice = record + { isSemilattice = ⊓-isSemilattice + } \ No newline at end of file diff --git a/Algebra.Lattice.Morphism.LatticeMonomorphism.html b/Algebra.Lattice.Morphism.LatticeMonomorphism.html index d6b439f1..380e931e 100644 --- a/Algebra.Lattice.Morphism.LatticeMonomorphism.html +++ b/Algebra.Lattice.Morphism.LatticeMonomorphism.html @@ -16,110 +16,110 @@ import Algebra.Consequences.Setoid as Consequences import Algebra.Morphism.MagmaMonomorphism as MagmaMonomorphisms import Algebra.Lattice.Properties.Lattice as LatticeProperties -open import Data.Product using (_,_; map) -open import Relation.Binary -import Relation.Binary.Morphism.RelMonomorphism as RelMonomorphisms -import Relation.Binary.Reasoning.Setoid as SetoidReasoning - -module Algebra.Lattice.Morphism.LatticeMonomorphism - {a b ℓ₁ ℓ₂} {L₁ : RawLattice a ℓ₁} {L₂ : RawLattice b ℓ₂} {⟦_⟧} - (isLatticeMonomorphism : IsLatticeMonomorphism L₁ L₂ ⟦_⟧) - where - -open IsLatticeMonomorphism isLatticeMonomorphism -open RawLattice L₁ renaming (_≈_ to _≈₁_; _∨_ to _∨_; _∧_ to _∧_) -open RawLattice L₂ renaming (_≈_ to _≈₂_; _∨_ to _⊔_; _∧_ to _⊓_) - ------------------------------------------------------------------------- --- Re-export all properties of magma monomorphisms - -open MagmaMonomorphisms ∨-isMagmaMonomorphism public - using () renaming - ( cong to ∨-cong - ; assoc to ∨-assoc - ; comm to ∨-comm - ; idem to ∨-idem - ; sel to ∨-sel - ; cancelˡ to ∨-cancelˡ - ; cancelʳ to ∨-cancelʳ - ; cancel to ∨-cancel - ) - -open MagmaMonomorphisms ∧-isMagmaMonomorphism public - using () renaming - ( cong to ∧-cong - ; assoc to ∧-assoc - ; comm to ∧-comm - ; idem to ∧-idem - ; sel to ∧-sel - ; cancelˡ to ∧-cancelˡ - ; cancelʳ to ∧-cancelʳ - ; cancel to ∧-cancel - ) - ------------------------------------------------------------------------- --- Lattice-specific properties - -module _ (⊔-⊓-isLattice : IsLattice _≈₂_ _⊔_ _⊓_) where - - open IsLattice ⊔-⊓-isLattice using (isEquivalence) renaming - ( ∨-congˡ to ⊔-congˡ - ; ∨-congʳ to ⊔-congʳ - ; ∧-cong to ⊓-cong - ; ∧-congˡ to ⊓-congˡ - ; ∨-absorbs-∧ to ⊔-absorbs-⊓ - ; ∧-absorbs-∨ to ⊓-absorbs-⊔ - ) - - setoid : Setoid b ℓ₂ - setoid = record { isEquivalence = isEquivalence } - - open SetoidReasoning setoid - - ∨-absorbs-∧ : _Absorbs_ _≈₁_ _∨_ _∧_ - ∨-absorbs-∧ x y = injective (begin - ⟦ x ∨ x ∧ y ⟧ ≈⟨ ∨-homo x (x ∧ y) ⟩ - ⟦ x ⟧ ⊔ ⟦ x ∧ y ⟧ ≈⟨ ⊔-congˡ (∧-homo x y) ⟩ - ⟦ x ⟧ ⊔ ⟦ x ⟧ ⊓ ⟦ y ⟧ ≈⟨ ⊔-absorbs-⊓ ⟦ x ⟧ ⟦ y ⟧ ⟩ - ⟦ x ⟧ ∎) - - ∧-absorbs-∨ : _Absorbs_ _≈₁_ _∧_ _∨_ - ∧-absorbs-∨ x y = injective (begin - ⟦ x ∧ (x ∨ y) ⟧ ≈⟨ ∧-homo x (x ∨ y) ⟩ - ⟦ x ⟧ ⊓ ⟦ x ∨ y ⟧ ≈⟨ ⊓-congˡ (∨-homo x y) ⟩ - ⟦ x ⟧ ⊓ (⟦ x ⟧ ⊔ ⟦ y ⟧) ≈⟨ ⊓-absorbs-⊔ ⟦ x ⟧ ⟦ y ⟧ ⟩ - ⟦ x ⟧ ∎) - - absorptive : Absorptive _≈₁_ _∨_ _∧_ - absorptive = ∨-absorbs-∧ , ∧-absorbs-∨ - - distribʳ : _DistributesOverʳ_ _≈₂_ _⊔_ _⊓_ → _DistributesOverʳ_ _≈₁_ _∨_ _∧_ - distribʳ distribʳ x y z = injective (begin - ⟦ y ∧ z ∨ x ⟧ ≈⟨ ∨-homo (y ∧ z) x ⟩ - ⟦ y ∧ z ⟧ ⊔ ⟦ x ⟧ ≈⟨ ⊔-congʳ (∧-homo y z) ⟩ - ⟦ y ⟧ ⊓ ⟦ z ⟧ ⊔ ⟦ x ⟧ ≈⟨ distribʳ ⟦ x ⟧ ⟦ y ⟧ ⟦ z ⟧ ⟩ - (⟦ y ⟧ ⊔ ⟦ x ⟧) ⊓ (⟦ z ⟧ ⊔ ⟦ x ⟧) ≈˘⟨ ⊓-cong (∨-homo y x) (∨-homo z x) ⟩ - ⟦ y ∨ x ⟧ ⊓ ⟦ z ∨ x ⟧ ≈˘⟨ ∧-homo (y ∨ x) (z ∨ x) ⟩ - ⟦ (y ∨ x) ∧ (z ∨ x) ⟧ ∎) - -isLattice : IsLattice _≈₂_ _⊔_ _⊓_ → IsLattice _≈₁_ _∨_ _∧_ -isLattice isLattice = record - { isEquivalence = RelMonomorphisms.isEquivalence isRelMonomorphism L.isEquivalence - ; ∨-comm = ∨-comm LP.∨-isMagma L.∨-comm - ; ∨-assoc = ∨-assoc LP.∨-isMagma L.∨-assoc - ; ∨-cong = ∨-cong LP.∨-isMagma - ; ∧-comm = ∧-comm LP.∧-isMagma L.∧-comm - ; ∧-assoc = ∧-assoc LP.∧-isMagma L.∧-assoc - ; ∧-cong = ∧-cong LP.∧-isMagma - ; absorptive = absorptive isLattice - } where - module L = IsLattice isLattice - module LP = LatticeProperties (record { isLattice = isLattice }) - -isDistributiveLattice : IsDistributiveLattice _≈₂_ _⊔_ _⊓_ → - IsDistributiveLattice _≈₁_ _∨_ _∧_ -isDistributiveLattice isDL = isDistributiveLatticeʳʲᵐ (record - { isLattice = isLattice L.isLattice - ; ∨-distribʳ-∧ = distribʳ L.isLattice L.∨-distribʳ-∧ - }) where module L = IsDistributiveLattice isDL +open import Data.Product.Base using (_,_; map) +open import Relation.Binary.Bundles using (Setoid) +import Relation.Binary.Morphism.RelMonomorphism as RelMonomorphisms +import Relation.Binary.Reasoning.Setoid as SetoidReasoning + +module Algebra.Lattice.Morphism.LatticeMonomorphism + {a b ℓ₁ ℓ₂} {L₁ : RawLattice a ℓ₁} {L₂ : RawLattice b ℓ₂} {⟦_⟧} + (isLatticeMonomorphism : IsLatticeMonomorphism L₁ L₂ ⟦_⟧) + where + +open IsLatticeMonomorphism isLatticeMonomorphism +open RawLattice L₁ renaming (_≈_ to _≈₁_; _∨_ to _∨_; _∧_ to _∧_) +open RawLattice L₂ renaming (_≈_ to _≈₂_; _∨_ to _⊔_; _∧_ to _⊓_) + +------------------------------------------------------------------------ +-- Re-export all properties of magma monomorphisms + +open MagmaMonomorphisms ∨-isMagmaMonomorphism public + using () renaming + ( cong to ∨-cong + ; assoc to ∨-assoc + ; comm to ∨-comm + ; idem to ∨-idem + ; sel to ∨-sel + ; cancelˡ to ∨-cancelˡ + ; cancelʳ to ∨-cancelʳ + ; cancel to ∨-cancel + ) + +open MagmaMonomorphisms ∧-isMagmaMonomorphism public + using () renaming + ( cong to ∧-cong + ; assoc to ∧-assoc + ; comm to ∧-comm + ; idem to ∧-idem + ; sel to ∧-sel + ; cancelˡ to ∧-cancelˡ + ; cancelʳ to ∧-cancelʳ + ; cancel to ∧-cancel + ) + +------------------------------------------------------------------------ +-- Lattice-specific properties + +module _ (⊔-⊓-isLattice : IsLattice _≈₂_ _⊔_ _⊓_) where + + open IsLattice ⊔-⊓-isLattice using (isEquivalence) renaming + ( ∨-congˡ to ⊔-congˡ + ; ∨-congʳ to ⊔-congʳ + ; ∧-cong to ⊓-cong + ; ∧-congˡ to ⊓-congˡ + ; ∨-absorbs-∧ to ⊔-absorbs-⊓ + ; ∧-absorbs-∨ to ⊓-absorbs-⊔ + ) + + setoid : Setoid b ℓ₂ + setoid = record { isEquivalence = isEquivalence } + + open SetoidReasoning setoid + + ∨-absorbs-∧ : _Absorbs_ _≈₁_ _∨_ _∧_ + ∨-absorbs-∧ x y = injective (begin + ⟦ x ∨ x ∧ y ⟧ ≈⟨ ∨-homo x (x ∧ y) ⟩ + ⟦ x ⟧ ⊔ ⟦ x ∧ y ⟧ ≈⟨ ⊔-congˡ (∧-homo x y) ⟩ + ⟦ x ⟧ ⊔ ⟦ x ⟧ ⊓ ⟦ y ⟧ ≈⟨ ⊔-absorbs-⊓ ⟦ x ⟧ ⟦ y ⟧ ⟩ + ⟦ x ⟧ ∎) + + ∧-absorbs-∨ : _Absorbs_ _≈₁_ _∧_ _∨_ + ∧-absorbs-∨ x y = injective (begin + ⟦ x ∧ (x ∨ y) ⟧ ≈⟨ ∧-homo x (x ∨ y) ⟩ + ⟦ x ⟧ ⊓ ⟦ x ∨ y ⟧ ≈⟨ ⊓-congˡ (∨-homo x y) ⟩ + ⟦ x ⟧ ⊓ (⟦ x ⟧ ⊔ ⟦ y ⟧) ≈⟨ ⊓-absorbs-⊔ ⟦ x ⟧ ⟦ y ⟧ ⟩ + ⟦ x ⟧ ∎) + + absorptive : Absorptive _≈₁_ _∨_ _∧_ + absorptive = ∨-absorbs-∧ , ∧-absorbs-∨ + + distribʳ : _DistributesOverʳ_ _≈₂_ _⊔_ _⊓_ → _DistributesOverʳ_ _≈₁_ _∨_ _∧_ + distribʳ distribʳ x y z = injective (begin + ⟦ y ∧ z ∨ x ⟧ ≈⟨ ∨-homo (y ∧ z) x ⟩ + ⟦ y ∧ z ⟧ ⊔ ⟦ x ⟧ ≈⟨ ⊔-congʳ (∧-homo y z) ⟩ + ⟦ y ⟧ ⊓ ⟦ z ⟧ ⊔ ⟦ x ⟧ ≈⟨ distribʳ ⟦ x ⟧ ⟦ y ⟧ ⟦ z ⟧ ⟩ + (⟦ y ⟧ ⊔ ⟦ x ⟧) ⊓ (⟦ z ⟧ ⊔ ⟦ x ⟧) ≈⟨ ⊓-cong (∨-homo y x) (∨-homo z x) ⟨ + ⟦ y ∨ x ⟧ ⊓ ⟦ z ∨ x ⟧ ≈⟨ ∧-homo (y ∨ x) (z ∨ x) ⟨ + ⟦ (y ∨ x) ∧ (z ∨ x) ⟧ ∎) + +isLattice : IsLattice _≈₂_ _⊔_ _⊓_ → IsLattice _≈₁_ _∨_ _∧_ +isLattice isLattice = record + { isEquivalence = RelMonomorphisms.isEquivalence isRelMonomorphism L.isEquivalence + ; ∨-comm = ∨-comm LP.∨-isMagma L.∨-comm + ; ∨-assoc = ∨-assoc LP.∨-isMagma L.∨-assoc + ; ∨-cong = ∨-cong LP.∨-isMagma + ; ∧-comm = ∧-comm LP.∧-isMagma L.∧-comm + ; ∧-assoc = ∧-assoc LP.∧-isMagma L.∧-assoc + ; ∧-cong = ∧-cong LP.∧-isMagma + ; absorptive = absorptive isLattice + } where + module L = IsLattice isLattice + module LP = LatticeProperties (record { isLattice = isLattice }) + +isDistributiveLattice : IsDistributiveLattice _≈₂_ _⊔_ _⊓_ → + IsDistributiveLattice _≈₁_ _∨_ _∧_ +isDistributiveLattice isDL = isDistributiveLatticeʳʲᵐ (record + { isLattice = isLattice L.isLattice + ; ∨-distribʳ-∧ = distribʳ L.isLattice L.∨-distribʳ-∧ + }) where module L = IsDistributiveLattice isDL \ No newline at end of file diff --git a/Algebra.Lattice.Morphism.Structures.html b/Algebra.Lattice.Morphism.Structures.html index e76599d8..32fe9b83 100644 --- a/Algebra.Lattice.Morphism.Structures.html +++ b/Algebra.Lattice.Morphism.Structures.html @@ -13,109 +13,108 @@ open import Algebra.Lattice.Bundles import Algebra.Morphism.Definitions as MorphismDefinitions open import Level using (Level; _⊔_) -import Function.Definitions as FunctionDefinitions -open import Relation.Binary.Morphism.Structures -open import Relation.Binary.Core +open import Function.Definitions +open import Relation.Binary.Morphism.Structures +open import Relation.Binary.Core -module Algebra.Lattice.Morphism.Structures where +module Algebra.Lattice.Morphism.Structures where -private - variable - a b ℓ₁ ℓ₂ : Level +private + variable + a b ℓ₁ ℓ₂ : Level ------------------------------------------------------------------------- --- Morphisms over lattice-like structures ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Morphisms over lattice-like structures +------------------------------------------------------------------------ -module LatticeMorphisms (L₁ : RawLattice a ℓ₁) (L₂ : RawLattice b ℓ₂) where +module LatticeMorphisms (L₁ : RawLattice a ℓ₁) (L₂ : RawLattice b ℓ₂) where - open RawLattice L₁ renaming - ( Carrier to A; _≈_ to _≈₁_ - ; _∧_ to _∧₁_; _∨_ to _∨₁_ - ; ∧-rawMagma to ∧-rawMagma₁ - ; ∨-rawMagma to ∨-rawMagma₁) + open RawLattice L₁ renaming + ( Carrier to A; _≈_ to _≈₁_ + ; _∧_ to _∧₁_; _∨_ to _∨₁_ + ; ∧-rawMagma to ∧-rawMagma₁ + ; ∨-rawMagma to ∨-rawMagma₁) - open RawLattice L₂ renaming - ( Carrier to B; _≈_ to _≈₂_ - ; _∧_ to _∧₂_; _∨_ to _∨₂_ - ; ∧-rawMagma to ∧-rawMagma₂ - ; ∨-rawMagma to ∨-rawMagma₂) + open RawLattice L₂ renaming + ( Carrier to B; _≈_ to _≈₂_ + ; _∧_ to _∧₂_; _∨_ to _∨₂_ + ; ∧-rawMagma to ∧-rawMagma₂ + ; ∨-rawMagma to ∨-rawMagma₂) - module ∨ = MagmaMorphisms ∨-rawMagma₁ ∨-rawMagma₂ - module ∧ = MagmaMorphisms ∧-rawMagma₁ ∧-rawMagma₂ + module ∨ = MagmaMorphisms ∨-rawMagma₁ ∨-rawMagma₂ + module ∧ = MagmaMorphisms ∧-rawMagma₁ ∧-rawMagma₂ - open MorphismDefinitions A B _≈₂_ - open FunctionDefinitions _≈₁_ _≈₂_ + open MorphismDefinitions A B _≈₂_ - record IsLatticeHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isRelHomomorphism : IsRelHomomorphism _≈₁_ _≈₂_ ⟦_⟧ - ∧-homo : Homomorphic₂ ⟦_⟧ _∧₁_ _∧₂_ - ∨-homo : Homomorphic₂ ⟦_⟧ _∨₁_ _∨₂_ + record IsLatticeHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isRelHomomorphism : IsRelHomomorphism _≈₁_ _≈₂_ ⟦_⟧ + ∧-homo : Homomorphic₂ ⟦_⟧ _∧₁_ _∧₂_ + ∨-homo : Homomorphic₂ ⟦_⟧ _∨₁_ _∨₂_ - open IsRelHomomorphism isRelHomomorphism public - renaming (cong to ⟦⟧-cong) + open IsRelHomomorphism isRelHomomorphism public + renaming (cong to ⟦⟧-cong) - ∧-isMagmaHomomorphism : ∧.IsMagmaHomomorphism ⟦_⟧ - ∧-isMagmaHomomorphism = record - { isRelHomomorphism = isRelHomomorphism - ; homo = ∧-homo - } + ∧-isMagmaHomomorphism : ∧.IsMagmaHomomorphism ⟦_⟧ + ∧-isMagmaHomomorphism = record + { isRelHomomorphism = isRelHomomorphism + ; homo = ∧-homo + } - ∨-isMagmaHomomorphism : ∨.IsMagmaHomomorphism ⟦_⟧ - ∨-isMagmaHomomorphism = record - { isRelHomomorphism = isRelHomomorphism - ; homo = ∨-homo - } + ∨-isMagmaHomomorphism : ∨.IsMagmaHomomorphism ⟦_⟧ + ∨-isMagmaHomomorphism = record + { isRelHomomorphism = isRelHomomorphism + ; homo = ∨-homo + } - record IsLatticeMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isLatticeHomomorphism : IsLatticeHomomorphism ⟦_⟧ - injective : Injective ⟦_⟧ + record IsLatticeMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isLatticeHomomorphism : IsLatticeHomomorphism ⟦_⟧ + injective : Injective _≈₁_ _≈₂_ ⟦_⟧ - open IsLatticeHomomorphism isLatticeHomomorphism public + open IsLatticeHomomorphism isLatticeHomomorphism public - ∨-isMagmaMonomorphism : ∨.IsMagmaMonomorphism ⟦_⟧ - ∨-isMagmaMonomorphism = record - { isMagmaHomomorphism = ∨-isMagmaHomomorphism - ; injective = injective - } + ∨-isMagmaMonomorphism : ∨.IsMagmaMonomorphism ⟦_⟧ + ∨-isMagmaMonomorphism = record + { isMagmaHomomorphism = ∨-isMagmaHomomorphism + ; injective = injective + } - ∧-isMagmaMonomorphism : ∧.IsMagmaMonomorphism ⟦_⟧ - ∧-isMagmaMonomorphism = record - { isMagmaHomomorphism = ∧-isMagmaHomomorphism - ; injective = injective - } + ∧-isMagmaMonomorphism : ∧.IsMagmaMonomorphism ⟦_⟧ + ∧-isMagmaMonomorphism = record + { isMagmaHomomorphism = ∧-isMagmaHomomorphism + ; injective = injective + } - open ∧.IsMagmaMonomorphism ∧-isMagmaMonomorphism public - using (isRelMonomorphism) + open ∧.IsMagmaMonomorphism ∧-isMagmaMonomorphism public + using (isRelMonomorphism) - record IsLatticeIsomorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - isLatticeMonomorphism : IsLatticeMonomorphism ⟦_⟧ - surjective : Surjective ⟦_⟧ + record IsLatticeIsomorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + isLatticeMonomorphism : IsLatticeMonomorphism ⟦_⟧ + surjective : Surjective _≈₁_ _≈₂_ ⟦_⟧ - open IsLatticeMonomorphism isLatticeMonomorphism public + open IsLatticeMonomorphism isLatticeMonomorphism public - ∨-isMagmaIsomorphism : ∨.IsMagmaIsomorphism ⟦_⟧ - ∨-isMagmaIsomorphism = record - { isMagmaMonomorphism = ∨-isMagmaMonomorphism - ; surjective = surjective - } + ∨-isMagmaIsomorphism : ∨.IsMagmaIsomorphism ⟦_⟧ + ∨-isMagmaIsomorphism = record + { isMagmaMonomorphism = ∨-isMagmaMonomorphism + ; surjective = surjective + } - ∧-isMagmaIsomorphism : ∧.IsMagmaIsomorphism ⟦_⟧ - ∧-isMagmaIsomorphism = record - { isMagmaMonomorphism = ∧-isMagmaMonomorphism - ; surjective = surjective - } + ∧-isMagmaIsomorphism : ∧.IsMagmaIsomorphism ⟦_⟧ + ∧-isMagmaIsomorphism = record + { isMagmaMonomorphism = ∧-isMagmaMonomorphism + ; surjective = surjective + } - open ∧.IsMagmaIsomorphism ∧-isMagmaIsomorphism public - using (isRelIsomorphism) + open ∧.IsMagmaIsomorphism ∧-isMagmaIsomorphism public + using (isRelIsomorphism) ------------------------------------------------------------------------- --- Re-export contents of modules publicly +------------------------------------------------------------------------ +-- Re-export contents of modules publicly -open LatticeMorphisms public +open LatticeMorphisms public \ No newline at end of file diff --git a/Algebra.Lattice.Properties.BooleanAlgebra.html b/Algebra.Lattice.Properties.BooleanAlgebra.html index 866fd215..92d97dfb 100644 --- a/Algebra.Lattice.Properties.BooleanAlgebra.html +++ b/Algebra.Lattice.Properties.BooleanAlgebra.html @@ -10,533 +10,531 @@ open import Algebra.Lattice.Bundles module Algebra.Lattice.Properties.BooleanAlgebra - {b₁ b₂} (B : BooleanAlgebra b₁ b₂) + {b₁ b₂} (B : BooleanAlgebra b₁ b₂) where -open BooleanAlgebra B +open BooleanAlgebra B import Algebra.Lattice.Properties.DistributiveLattice as DistribLatticeProperties open import Algebra.Core -open import Algebra.Structures _≈_ -open import Algebra.Definitions _≈_ -open import Algebra.Consequences.Setoid setoid +open import Algebra.Structures _≈_ +open import Algebra.Definitions _≈_ +open import Algebra.Consequences.Setoid setoid open import Algebra.Bundles -open import Algebra.Lattice.Structures _≈_ -open import Relation.Binary.Reasoning.Setoid setoid -open import Relation.Binary -open import Function.Base -open import Function.Bundles using (_⇔_; module Equivalence) -open import Data.Product using (_,_) +open import Algebra.Lattice.Structures _≈_ +open import Relation.Binary.Reasoning.Setoid setoid +open import Function.Base using (id; _$_; _⟨_⟩_) +open import Function.Bundles using (_⇔_; module Equivalence) +open import Data.Product.Base using (_,_) ------------------------------------------------------------------------ -- Export properties from distributive lattices -open DistribLatticeProperties distributiveLattice public +open DistribLatticeProperties distributiveLattice public ------------------------------------------------------------------------ -- The dual construction is also a boolean algebra -∧-∨-isBooleanAlgebra : IsBooleanAlgebra _∧_ _∨_ ¬_ ⊥ ⊤ +∧-∨-isBooleanAlgebra : IsBooleanAlgebra _∧_ _∨_ ¬_ ⊥ ⊤ ∧-∨-isBooleanAlgebra = record - { isDistributiveLattice = ∧-∨-isDistributiveLattice - ; ∨-complement = ∧-complement - ; ∧-complement = ∨-complement - ; ¬-cong = ¬-cong + { isDistributiveLattice = ∧-∨-isDistributiveLattice + ; ∨-complement = ∧-complement + ; ∧-complement = ∨-complement + ; ¬-cong = ¬-cong } -∧-∨-booleanAlgebra : BooleanAlgebra _ _ +∧-∨-booleanAlgebra : BooleanAlgebra _ _ ∧-∨-booleanAlgebra = record - { isBooleanAlgebra = ∧-∨-isBooleanAlgebra + { isBooleanAlgebra = ∧-∨-isBooleanAlgebra } ------------------------------------------------------------------------ -- (∨, ∧, ⊥, ⊤) and (∧, ∨, ⊤, ⊥) are commutative semirings -∧-identityʳ : RightIdentity ⊤ _∧_ -∧-identityʳ x = begin - x ∧ ⊤ ≈⟨ ∧-congˡ (sym (∨-complementʳ _)) ⟩ - x ∧ (x ∨ ¬ x) ≈⟨ ∧-absorbs-∨ _ _ ⟩ - x ∎ +∧-identityʳ : RightIdentity ⊤ _∧_ +∧-identityʳ x = begin + x ∧ ⊤ ≈⟨ ∧-congˡ (sym (∨-complementʳ _)) ⟩ + x ∧ (x ∨ ¬ x) ≈⟨ ∧-absorbs-∨ _ _ ⟩ + x ∎ -∧-identityˡ : LeftIdentity ⊤ _∧_ -∧-identityˡ = comm+idʳ⇒idˡ ∧-comm ∧-identityʳ +∧-identityˡ : LeftIdentity ⊤ _∧_ +∧-identityˡ = comm∧idʳ⇒idˡ ∧-comm ∧-identityʳ -∧-identity : Identity ⊤ _∧_ +∧-identity : Identity ⊤ _∧_ ∧-identity = ∧-identityˡ , ∧-identityʳ -∨-identityʳ : RightIdentity ⊥ _∨_ -∨-identityʳ x = begin - x ∨ ⊥ ≈⟨ ∨-congˡ $ sym (∧-complementʳ _) ⟩ - x ∨ x ∧ ¬ x ≈⟨ ∨-absorbs-∧ _ _ ⟩ - x ∎ +∨-identityʳ : RightIdentity ⊥ _∨_ +∨-identityʳ x = begin + x ∨ ⊥ ≈⟨ ∨-congˡ $ sym (∧-complementʳ _) ⟩ + x ∨ x ∧ ¬ x ≈⟨ ∨-absorbs-∧ _ _ ⟩ + x ∎ -∨-identityˡ : LeftIdentity ⊥ _∨_ -∨-identityˡ = comm+idʳ⇒idˡ ∨-comm ∨-identityʳ +∨-identityˡ : LeftIdentity ⊥ _∨_ +∨-identityˡ = comm∧idʳ⇒idˡ ∨-comm ∨-identityʳ -∨-identity : Identity ⊥ _∨_ +∨-identity : Identity ⊥ _∨_ ∨-identity = ∨-identityˡ , ∨-identityʳ -∧-zeroʳ : RightZero ⊥ _∧_ -∧-zeroʳ x = begin - x ∧ ⊥ ≈˘⟨ ∧-congˡ (∧-complementʳ x) ⟩ - x ∧ x ∧ ¬ x ≈˘⟨ ∧-assoc x x (¬ x) ⟩ - (x ∧ x) ∧ ¬ x ≈⟨ ∧-congʳ (∧-idem x) ⟩ - x ∧ ¬ x ≈⟨ ∧-complementʳ x ⟩ - ⊥ ∎ - -∧-zeroˡ : LeftZero ⊥ _∧_ -∧-zeroˡ = comm+zeʳ⇒zeˡ ∧-comm ∧-zeroʳ - -∧-zero : Zero ⊥ _∧_ -∧-zero = ∧-zeroˡ , ∧-zeroʳ - -∨-zeroʳ : ∀ x → x ∨ ⊤ ≈ ⊤ -∨-zeroʳ x = begin - x ∨ ⊤ ≈˘⟨ ∨-congˡ (∨-complementʳ x) ⟩ - x ∨ x ∨ ¬ x ≈˘⟨ ∨-assoc x x (¬ x) ⟩ - (x ∨ x) ∨ ¬ x ≈⟨ ∨-congʳ (∨-idem x) ⟩ - x ∨ ¬ x ≈⟨ ∨-complementʳ x ⟩ - ⊤ ∎ - -∨-zeroˡ : LeftZero ⊤ _∨_ -∨-zeroˡ = comm+zeʳ⇒zeˡ ∨-comm ∨-zeroʳ - -∨-zero : Zero ⊤ _∨_ -∨-zero = ∨-zeroˡ , ∨-zeroʳ - -∨-⊥-isMonoid : IsMonoid _∨_ ⊥ -∨-⊥-isMonoid = record - { isSemigroup = ∨-isSemigroup - ; identity = ∨-identity - } - -∧-⊤-isMonoid : IsMonoid _∧_ ⊤ -∧-⊤-isMonoid = record - { isSemigroup = ∧-isSemigroup - ; identity = ∧-identity - } - -∨-⊥-isCommutativeMonoid : IsCommutativeMonoid _∨_ ⊥ -∨-⊥-isCommutativeMonoid = record - { isMonoid = ∨-⊥-isMonoid - ; comm = ∨-comm - } - -∧-⊤-isCommutativeMonoid : IsCommutativeMonoid _∧_ ⊤ -∧-⊤-isCommutativeMonoid = record - { isMonoid = ∧-⊤-isMonoid - ; comm = ∧-comm - } - -∨-∧-isSemiring : IsSemiring _∨_ _∧_ ⊥ ⊤ -∨-∧-isSemiring = record - { isSemiringWithoutAnnihilatingZero = record - { +-isCommutativeMonoid = ∨-⊥-isCommutativeMonoid - ; *-cong = ∧-cong - ; *-assoc = ∧-assoc - ; *-identity = ∧-identity - ; distrib = ∧-distrib-∨ - } - ; zero = ∧-zero - } - -∧-∨-isSemiring : IsSemiring _∧_ _∨_ ⊤ ⊥ -∧-∨-isSemiring = record - { isSemiringWithoutAnnihilatingZero = record - { +-isCommutativeMonoid = ∧-⊤-isCommutativeMonoid - ; *-cong = ∨-cong - ; *-assoc = ∨-assoc - ; *-identity = ∨-identity - ; distrib = ∨-distrib-∧ - } - ; zero = ∨-zero - } - -∨-∧-isCommutativeSemiring : IsCommutativeSemiring _∨_ _∧_ ⊥ ⊤ -∨-∧-isCommutativeSemiring = record - { isSemiring = ∨-∧-isSemiring - ; *-comm = ∧-comm - } - -∧-∨-isCommutativeSemiring : IsCommutativeSemiring _∧_ _∨_ ⊤ ⊥ -∧-∨-isCommutativeSemiring = record - { isSemiring = ∧-∨-isSemiring - ; *-comm = ∨-comm - } - -∨-∧-commutativeSemiring : CommutativeSemiring _ _ -∨-∧-commutativeSemiring = record - { isCommutativeSemiring = ∨-∧-isCommutativeSemiring - } - -∧-∨-commutativeSemiring : CommutativeSemiring _ _ -∧-∨-commutativeSemiring = record - { isCommutativeSemiring = ∧-∨-isCommutativeSemiring - } - ------------------------------------------------------------------------- --- Some other properties - --- I took the statement of this lemma (called Uniqueness of --- Complements) from some course notes, "Boolean Algebra", written --- by Gert Smolka. - -private - lemma : ∀ x y → x ∧ y ≈ ⊥ → x ∨ y ≈ ⊤ → ¬ x ≈ y - lemma x y x∧y=⊥ x∨y=⊤ = begin - ¬ x ≈˘⟨ ∧-identityʳ _ ⟩ - ¬ x ∧ ⊤ ≈˘⟨ ∧-congˡ x∨y=⊤ ⟩ - ¬ x ∧ (x ∨ y) ≈⟨ ∧-distribˡ-∨ _ _ _ ⟩ - ¬ x ∧ x ∨ ¬ x ∧ y ≈⟨ ∨-congʳ $ ∧-complementˡ _ ⟩ - ⊥ ∨ ¬ x ∧ y ≈˘⟨ ∨-congʳ x∧y=⊥ ⟩ - x ∧ y ∨ ¬ x ∧ y ≈˘⟨ ∧-distribʳ-∨ _ _ _ ⟩ - (x ∨ ¬ x) ∧ y ≈⟨ ∧-congʳ $ ∨-complementʳ _ ⟩ - ⊤ ∧ y ≈⟨ ∧-identityˡ _ ⟩ - y ∎ - -⊥≉⊤ : ¬ ⊥ ≈ ⊤ -⊥≉⊤ = lemma ⊥ ⊤ (∧-identityʳ _) (∨-zeroʳ _) - -⊤≉⊥ : ¬ ⊤ ≈ ⊥ -⊤≉⊥ = lemma ⊤ ⊥ (∧-zeroʳ _) (∨-identityʳ _) - -¬-involutive : Involutive ¬_ -¬-involutive x = lemma (¬ x) x (∧-complementˡ _) (∨-complementˡ _) - -deMorgan₁ : ∀ x y → ¬ (x ∧ y) ≈ ¬ x ∨ ¬ y -deMorgan₁ x y = lemma (x ∧ y) (¬ x ∨ ¬ y) lem₁ lem₂ - where - lem₁ = begin - (x ∧ y) ∧ (¬ x ∨ ¬ y) ≈⟨ ∧-distribˡ-∨ _ _ _ ⟩ - (x ∧ y) ∧ ¬ x ∨ (x ∧ y) ∧ ¬ y ≈⟨ ∨-congʳ $ ∧-congʳ $ ∧-comm _ _ ⟩ - (y ∧ x) ∧ ¬ x ∨ (x ∧ y) ∧ ¬ y ≈⟨ ∧-assoc _ _ _ ⟨ ∨-cong ⟩ ∧-assoc _ _ _ ⟩ - y ∧ (x ∧ ¬ x) ∨ x ∧ (y ∧ ¬ y) ≈⟨ (∧-congˡ $ ∧-complementʳ _) ⟨ ∨-cong ⟩ - (∧-congˡ $ ∧-complementʳ _) ⟩ - (y ∧ ⊥) ∨ (x ∧ ⊥) ≈⟨ ∧-zeroʳ _ ⟨ ∨-cong ⟩ ∧-zeroʳ _ ⟩ - ⊥ ∨ ⊥ ≈⟨ ∨-identityʳ _ ⟩ - ⊥ ∎ - - lem₃ = begin - (x ∧ y) ∨ ¬ x ≈⟨ ∨-distribʳ-∧ _ _ _ ⟩ - (x ∨ ¬ x) ∧ (y ∨ ¬ x) ≈⟨ ∧-congʳ $ ∨-complementʳ _ ⟩ - ⊤ ∧ (y ∨ ¬ x) ≈⟨ ∧-identityˡ _ ⟩ - y ∨ ¬ x ≈⟨ ∨-comm _ _ ⟩ - ¬ x ∨ y ∎ - - lem₂ = begin - (x ∧ y) ∨ (¬ x ∨ ¬ y) ≈˘⟨ ∨-assoc _ _ _ ⟩ - ((x ∧ y) ∨ ¬ x) ∨ ¬ y ≈⟨ ∨-congʳ lem₃ ⟩ - (¬ x ∨ y) ∨ ¬ y ≈⟨ ∨-assoc _ _ _ ⟩ - ¬ x ∨ (y ∨ ¬ y) ≈⟨ ∨-congˡ $ ∨-complementʳ _ ⟩ - ¬ x ∨ ⊤ ≈⟨ ∨-zeroʳ _ ⟩ - ⊤ ∎ - -deMorgan₂ : ∀ x y → ¬ (x ∨ y) ≈ ¬ x ∧ ¬ y -deMorgan₂ x y = begin - ¬ (x ∨ y) ≈˘⟨ ¬-cong $ ((¬-involutive _) ⟨ ∨-cong ⟩ (¬-involutive _)) ⟩ - ¬ (¬ ¬ x ∨ ¬ ¬ y) ≈˘⟨ ¬-cong $ deMorgan₁ _ _ ⟩ - ¬ ¬ (¬ x ∧ ¬ y) ≈⟨ ¬-involutive _ ⟩ - ¬ x ∧ ¬ y ∎ - ------------------------------------------------------------------------- --- (⊕, ∧, id, ⊥, ⊤) is a commutative ring - --- This construction is parameterised over the definition of xor. - -module XorRing - (xor : Op₂ Carrier) - (⊕-def : ∀ x y → xor x y ≈ (x ∨ y) ∧ ¬ (x ∧ y)) - where - - private - infixl 6 _⊕_ - - _⊕_ : Op₂ Carrier - _⊕_ = xor - - helper : ∀ {x y u v} → x ≈ y → u ≈ v → x ∧ ¬ u ≈ y ∧ ¬ v - helper x≈y u≈v = x≈y ⟨ ∧-cong ⟩ ¬-cong u≈v - - ⊕-cong : Congruent₂ _⊕_ - ⊕-cong {x} {y} {u} {v} x≈y u≈v = begin - x ⊕ u ≈⟨ ⊕-def _ _ ⟩ - (x ∨ u) ∧ ¬ (x ∧ u) ≈⟨ helper (x≈y ⟨ ∨-cong ⟩ u≈v) - (x≈y ⟨ ∧-cong ⟩ u≈v) ⟩ - (y ∨ v) ∧ ¬ (y ∧ v) ≈˘⟨ ⊕-def _ _ ⟩ - y ⊕ v ∎ - - ⊕-comm : Commutative _⊕_ - ⊕-comm x y = begin - x ⊕ y ≈⟨ ⊕-def _ _ ⟩ - (x ∨ y) ∧ ¬ (x ∧ y) ≈⟨ helper (∨-comm _ _) (∧-comm _ _) ⟩ - (y ∨ x) ∧ ¬ (y ∧ x) ≈˘⟨ ⊕-def _ _ ⟩ - y ⊕ x ∎ - - ¬-distribˡ-⊕ : ∀ x y → ¬ (x ⊕ y) ≈ ¬ x ⊕ y - ¬-distribˡ-⊕ x y = begin - ¬ (x ⊕ y) ≈⟨ ¬-cong $ ⊕-def _ _ ⟩ - ¬ ((x ∨ y) ∧ (¬ (x ∧ y))) ≈⟨ ¬-cong (∧-distribʳ-∨ _ _ _) ⟩ - ¬ ((x ∧ ¬ (x ∧ y)) ∨ (y ∧ ¬ (x ∧ y))) ≈⟨ ¬-cong $ ∨-congˡ $ ∧-congˡ $ ¬-cong (∧-comm _ _) ⟩ - ¬ ((x ∧ ¬ (x ∧ y)) ∨ (y ∧ ¬ (y ∧ x))) ≈⟨ ¬-cong $ lem _ _ ⟨ ∨-cong ⟩ lem _ _ ⟩ - ¬ ((x ∧ ¬ y) ∨ (y ∧ ¬ x)) ≈⟨ deMorgan₂ _ _ ⟩ - ¬ (x ∧ ¬ y) ∧ ¬ (y ∧ ¬ x) ≈⟨ ∧-congʳ $ deMorgan₁ _ _ ⟩ - (¬ x ∨ (¬ ¬ y)) ∧ ¬ (y ∧ ¬ x) ≈⟨ helper (∨-congˡ $ ¬-involutive _) (∧-comm _ _) ⟩ - (¬ x ∨ y) ∧ ¬ (¬ x ∧ y) ≈˘⟨ ⊕-def _ _ ⟩ - ¬ x ⊕ y ∎ - where - lem : ∀ x y → x ∧ ¬ (x ∧ y) ≈ x ∧ ¬ y - lem x y = begin - x ∧ ¬ (x ∧ y) ≈⟨ ∧-congˡ $ deMorgan₁ _ _ ⟩ - x ∧ (¬ x ∨ ¬ y) ≈⟨ ∧-distribˡ-∨ _ _ _ ⟩ - (x ∧ ¬ x) ∨ (x ∧ ¬ y) ≈⟨ ∨-congʳ $ ∧-complementʳ _ ⟩ - ⊥ ∨ (x ∧ ¬ y) ≈⟨ ∨-identityˡ _ ⟩ - x ∧ ¬ y ∎ - - ¬-distribʳ-⊕ : ∀ x y → ¬ (x ⊕ y) ≈ x ⊕ ¬ y - ¬-distribʳ-⊕ x y = begin - ¬ (x ⊕ y) ≈⟨ ¬-cong $ ⊕-comm _ _ ⟩ - ¬ (y ⊕ x) ≈⟨ ¬-distribˡ-⊕ _ _ ⟩ - ¬ y ⊕ x ≈⟨ ⊕-comm _ _ ⟩ - x ⊕ ¬ y ∎ - - ⊕-annihilates-¬ : ∀ x y → x ⊕ y ≈ ¬ x ⊕ ¬ y - ⊕-annihilates-¬ x y = begin - x ⊕ y ≈˘⟨ ¬-involutive _ ⟩ - ¬ ¬ (x ⊕ y) ≈⟨ ¬-cong $ ¬-distribˡ-⊕ _ _ ⟩ - ¬ (¬ x ⊕ y) ≈⟨ ¬-distribʳ-⊕ _ _ ⟩ - ¬ x ⊕ ¬ y ∎ - - ⊕-identityˡ : LeftIdentity ⊥ _⊕_ - ⊕-identityˡ x = begin - ⊥ ⊕ x ≈⟨ ⊕-def _ _ ⟩ - (⊥ ∨ x) ∧ ¬ (⊥ ∧ x) ≈⟨ helper (∨-identityˡ _) (∧-zeroˡ _) ⟩ - x ∧ ¬ ⊥ ≈⟨ ∧-congˡ ⊥≉⊤ ⟩ - x ∧ ⊤ ≈⟨ ∧-identityʳ _ ⟩ - x ∎ - - ⊕-identityʳ : RightIdentity ⊥ _⊕_ - ⊕-identityʳ _ = ⊕-comm _ _ ⟨ trans ⟩ ⊕-identityˡ _ - - ⊕-identity : Identity ⊥ _⊕_ - ⊕-identity = ⊕-identityˡ , ⊕-identityʳ - - ⊕-inverseˡ : LeftInverse ⊥ id _⊕_ - ⊕-inverseˡ x = begin - x ⊕ x ≈⟨ ⊕-def _ _ ⟩ - (x ∨ x) ∧ ¬ (x ∧ x) ≈⟨ helper (∨-idem _) (∧-idem _) ⟩ - x ∧ ¬ x ≈⟨ ∧-complementʳ _ ⟩ - ⊥ ∎ - - ⊕-inverseʳ : RightInverse ⊥ id _⊕_ - ⊕-inverseʳ _ = ⊕-comm _ _ ⟨ trans ⟩ ⊕-inverseˡ _ - - ⊕-inverse : Inverse ⊥ id _⊕_ - ⊕-inverse = ⊕-inverseˡ , ⊕-inverseʳ - - ∧-distribˡ-⊕ : _∧_ DistributesOverˡ _⊕_ - ∧-distribˡ-⊕ x y z = begin - x ∧ (y ⊕ z) ≈⟨ ∧-congˡ $ ⊕-def _ _ ⟩ - x ∧ ((y ∨ z) ∧ ¬ (y ∧ z)) ≈˘⟨ ∧-assoc _ _ _ ⟩ - (x ∧ (y ∨ z)) ∧ ¬ (y ∧ z) ≈⟨ ∧-congˡ $ deMorgan₁ _ _ ⟩ - (x ∧ (y ∨ z)) ∧ - (¬ y ∨ ¬ z) ≈˘⟨ ∨-identityˡ _ ⟩ - ⊥ ∨ - ((x ∧ (y ∨ z)) ∧ - (¬ y ∨ ¬ z)) ≈⟨ ∨-congʳ lem₃ ⟩ - ((x ∧ (y ∨ z)) ∧ ¬ x) ∨ - ((x ∧ (y ∨ z)) ∧ - (¬ y ∨ ¬ z)) ≈˘⟨ ∧-distribˡ-∨ _ _ _ ⟩ - (x ∧ (y ∨ z)) ∧ - (¬ x ∨ (¬ y ∨ ¬ z)) ≈˘⟨ ∧-congˡ $ ∨-congˡ (deMorgan₁ _ _) ⟩ - (x ∧ (y ∨ z)) ∧ - (¬ x ∨ ¬ (y ∧ z)) ≈˘⟨ ∧-congˡ (deMorgan₁ _ _) ⟩ - (x ∧ (y ∨ z)) ∧ - ¬ (x ∧ (y ∧ z)) ≈⟨ helper refl lem₁ ⟩ - (x ∧ (y ∨ z)) ∧ - ¬ ((x ∧ y) ∧ (x ∧ z)) ≈⟨ ∧-congʳ $ ∧-distribˡ-∨ _ _ _ ⟩ - ((x ∧ y) ∨ (x ∧ z)) ∧ - ¬ ((x ∧ y) ∧ (x ∧ z)) ≈˘⟨ ⊕-def _ _ ⟩ - (x ∧ y) ⊕ (x ∧ z) ∎ - where - lem₂ = begin - x ∧ (y ∧ z) ≈˘⟨ ∧-assoc _ _ _ ⟩ - (x ∧ y) ∧ z ≈⟨ ∧-congʳ $ ∧-comm _ _ ⟩ - (y ∧ x) ∧ z ≈⟨ ∧-assoc _ _ _ ⟩ - y ∧ (x ∧ z) ∎ - - lem₁ = begin - x ∧ (y ∧ z) ≈˘⟨ ∧-congʳ (∧-idem _) ⟩ - (x ∧ x) ∧ (y ∧ z) ≈⟨ ∧-assoc _ _ _ ⟩ - x ∧ (x ∧ (y ∧ z)) ≈⟨ ∧-congˡ lem₂ ⟩ - x ∧ (y ∧ (x ∧ z)) ≈˘⟨ ∧-assoc _ _ _ ⟩ - (x ∧ y) ∧ (x ∧ z) ∎ - - lem₃ = begin - ⊥ ≈˘⟨ ∧-zeroʳ _ ⟩ - (y ∨ z) ∧ ⊥ ≈˘⟨ ∧-congˡ (∧-complementʳ _) ⟩ - (y ∨ z) ∧ (x ∧ ¬ x) ≈˘⟨ ∧-assoc _ _ _ ⟩ - ((y ∨ z) ∧ x) ∧ ¬ x ≈⟨ ∧-comm _ _ ⟨ ∧-cong ⟩ refl ⟩ - (x ∧ (y ∨ z)) ∧ ¬ x ∎ - - ∧-distribʳ-⊕ : _∧_ DistributesOverʳ _⊕_ - ∧-distribʳ-⊕ = comm+distrˡ⇒distrʳ ⊕-cong ∧-comm ∧-distribˡ-⊕ - - ∧-distrib-⊕ : _∧_ DistributesOver _⊕_ - ∧-distrib-⊕ = ∧-distribˡ-⊕ , ∧-distribʳ-⊕ - - private - - lemma₂ : ∀ x y u v → - (x ∧ y) ∨ (u ∧ v) ≈ - ((x ∨ u) ∧ (y ∨ u)) ∧ - ((x ∨ v) ∧ (y ∨ v)) - lemma₂ x y u v = begin - (x ∧ y) ∨ (u ∧ v) ≈⟨ ∨-distribˡ-∧ _ _ _ ⟩ - ((x ∧ y) ∨ u) ∧ ((x ∧ y) ∨ v) ≈⟨ ∨-distribʳ-∧ _ _ _ - ⟨ ∧-cong ⟩ - ∨-distribʳ-∧ _ _ _ ⟩ - ((x ∨ u) ∧ (y ∨ u)) ∧ - ((x ∨ v) ∧ (y ∨ v)) ∎ - - ⊕-assoc : Associative _⊕_ - ⊕-assoc x y z = sym $ begin - x ⊕ (y ⊕ z) ≈⟨ refl ⟨ ⊕-cong ⟩ ⊕-def _ _ ⟩ - x ⊕ ((y ∨ z) ∧ ¬ (y ∧ z)) ≈⟨ ⊕-def _ _ ⟩ - (x ∨ ((y ∨ z) ∧ ¬ (y ∧ z))) ∧ - ¬ (x ∧ ((y ∨ z) ∧ ¬ (y ∧ z))) ≈⟨ lem₃ ⟨ ∧-cong ⟩ lem₄ ⟩ - (((x ∨ y) ∨ z) ∧ ((x ∨ ¬ y) ∨ ¬ z)) ∧ - (((¬ x ∨ ¬ y) ∨ z) ∧ ((¬ x ∨ y) ∨ ¬ z)) ≈⟨ ∧-assoc _ _ _ ⟩ - ((x ∨ y) ∨ z) ∧ - (((x ∨ ¬ y) ∨ ¬ z) ∧ - (((¬ x ∨ ¬ y) ∨ z) ∧ ((¬ x ∨ y) ∨ ¬ z))) ≈⟨ ∧-congˡ lem₅ ⟩ - ((x ∨ y) ∨ z) ∧ - (((¬ x ∨ ¬ y) ∨ z) ∧ - (((x ∨ ¬ y) ∨ ¬ z) ∧ ((¬ x ∨ y) ∨ ¬ z))) ≈˘⟨ ∧-assoc _ _ _ ⟩ - (((x ∨ y) ∨ z) ∧ ((¬ x ∨ ¬ y) ∨ z)) ∧ - (((x ∨ ¬ y) ∨ ¬ z) ∧ ((¬ x ∨ y) ∨ ¬ z)) ≈⟨ lem₁ ⟨ ∧-cong ⟩ lem₂ ⟩ - (((x ∨ y) ∧ ¬ (x ∧ y)) ∨ z) ∧ - ¬ (((x ∨ y) ∧ ¬ (x ∧ y)) ∧ z) ≈˘⟨ ⊕-def _ _ ⟩ - ((x ∨ y) ∧ ¬ (x ∧ y)) ⊕ z ≈˘⟨ ⊕-def _ _ ⟨ ⊕-cong ⟩ refl ⟩ - (x ⊕ y) ⊕ z ∎ - where - lem₁ = begin - ((x ∨ y) ∨ z) ∧ ((¬ x ∨ ¬ y) ∨ z) ≈˘⟨ ∨-distribʳ-∧ _ _ _ ⟩ - ((x ∨ y) ∧ (¬ x ∨ ¬ y)) ∨ z ≈˘⟨ ∨-congʳ $ ∧-congˡ (deMorgan₁ _ _) ⟩ - ((x ∨ y) ∧ ¬ (x ∧ y)) ∨ z ∎ - - lem₂′ = begin - (x ∨ ¬ y) ∧ (¬ x ∨ y) ≈˘⟨ ∧-identityˡ _ ⟨ ∧-cong ⟩ ∧-identityʳ _ ⟩ - (⊤ ∧ (x ∨ ¬ y)) ∧ ((¬ x ∨ y) ∧ ⊤) ≈˘⟨ (∨-complementˡ _ ⟨ ∧-cong ⟩ ∨-comm _ _) - ⟨ ∧-cong ⟩ - (∧-congˡ $ ∨-complementˡ _) ⟩ - ((¬ x ∨ x) ∧ (¬ y ∨ x)) ∧ - ((¬ x ∨ y) ∧ (¬ y ∨ y)) ≈˘⟨ lemma₂ _ _ _ _ ⟩ - (¬ x ∧ ¬ y) ∨ (x ∧ y) ≈˘⟨ deMorgan₂ _ _ ⟨ ∨-cong ⟩ ¬-involutive _ ⟩ - ¬ (x ∨ y) ∨ ¬ ¬ (x ∧ y) ≈˘⟨ deMorgan₁ _ _ ⟩ - ¬ ((x ∨ y) ∧ ¬ (x ∧ y)) ∎ - - lem₂ = begin - ((x ∨ ¬ y) ∨ ¬ z) ∧ ((¬ x ∨ y) ∨ ¬ z) ≈˘⟨ ∨-distribʳ-∧ _ _ _ ⟩ - ((x ∨ ¬ y) ∧ (¬ x ∨ y)) ∨ ¬ z ≈⟨ ∨-congʳ lem₂′ ⟩ - ¬ ((x ∨ y) ∧ ¬ (x ∧ y)) ∨ ¬ z ≈˘⟨ deMorgan₁ _ _ ⟩ - ¬ (((x ∨ y) ∧ ¬ (x ∧ y)) ∧ z) ∎ - - lem₃ = begin - x ∨ ((y ∨ z) ∧ ¬ (y ∧ z)) ≈⟨ ∨-congˡ $ ∧-congˡ $ deMorgan₁ _ _ ⟩ - x ∨ ((y ∨ z) ∧ (¬ y ∨ ¬ z)) ≈⟨ ∨-distribˡ-∧ _ _ _ ⟩ - (x ∨ (y ∨ z)) ∧ (x ∨ (¬ y ∨ ¬ z)) ≈˘⟨ ∨-assoc _ _ _ ⟨ ∧-cong ⟩ ∨-assoc _ _ _ ⟩ - ((x ∨ y) ∨ z) ∧ ((x ∨ ¬ y) ∨ ¬ z) ∎ - - lem₄′ = begin - ¬ ((y ∨ z) ∧ ¬ (y ∧ z)) ≈⟨ deMorgan₁ _ _ ⟩ - ¬ (y ∨ z) ∨ ¬ ¬ (y ∧ z) ≈⟨ deMorgan₂ _ _ ⟨ ∨-cong ⟩ ¬-involutive _ ⟩ - (¬ y ∧ ¬ z) ∨ (y ∧ z) ≈⟨ lemma₂ _ _ _ _ ⟩ - ((¬ y ∨ y) ∧ (¬ z ∨ y)) ∧ - ((¬ y ∨ z) ∧ (¬ z ∨ z)) ≈⟨ (∨-complementˡ _ ⟨ ∧-cong ⟩ ∨-comm _ _) - ⟨ ∧-cong ⟩ - (∧-congˡ $ ∨-complementˡ _) ⟩ - (⊤ ∧ (y ∨ ¬ z)) ∧ - ((¬ y ∨ z) ∧ ⊤) ≈⟨ ∧-identityˡ _ ⟨ ∧-cong ⟩ ∧-identityʳ _ ⟩ - (y ∨ ¬ z) ∧ (¬ y ∨ z) ∎ - - lem₄ = begin - ¬ (x ∧ ((y ∨ z) ∧ ¬ (y ∧ z))) ≈⟨ deMorgan₁ _ _ ⟩ - ¬ x ∨ ¬ ((y ∨ z) ∧ ¬ (y ∧ z)) ≈⟨ ∨-congˡ lem₄′ ⟩ - ¬ x ∨ ((y ∨ ¬ z) ∧ (¬ y ∨ z)) ≈⟨ ∨-distribˡ-∧ _ _ _ ⟩ - (¬ x ∨ (y ∨ ¬ z)) ∧ - (¬ x ∨ (¬ y ∨ z)) ≈˘⟨ ∨-assoc _ _ _ ⟨ ∧-cong ⟩ ∨-assoc _ _ _ ⟩ - ((¬ x ∨ y) ∨ ¬ z) ∧ - ((¬ x ∨ ¬ y) ∨ z) ≈⟨ ∧-comm _ _ ⟩ - ((¬ x ∨ ¬ y) ∨ z) ∧ - ((¬ x ∨ y) ∨ ¬ z) ∎ - - lem₅ = begin - ((x ∨ ¬ y) ∨ ¬ z) ∧ - (((¬ x ∨ ¬ y) ∨ z) ∧ ((¬ x ∨ y) ∨ ¬ z)) ≈˘⟨ ∧-assoc _ _ _ ⟩ - (((x ∨ ¬ y) ∨ ¬ z) ∧ ((¬ x ∨ ¬ y) ∨ z)) ∧ - ((¬ x ∨ y) ∨ ¬ z) ≈⟨ ∧-congʳ $ ∧-comm _ _ ⟩ - (((¬ x ∨ ¬ y) ∨ z) ∧ ((x ∨ ¬ y) ∨ ¬ z)) ∧ - ((¬ x ∨ y) ∨ ¬ z) ≈⟨ ∧-assoc _ _ _ ⟩ - ((¬ x ∨ ¬ y) ∨ z) ∧ - (((x ∨ ¬ y) ∨ ¬ z) ∧ ((¬ x ∨ y) ∨ ¬ z)) ∎ - - ⊕-isMagma : IsMagma _⊕_ - ⊕-isMagma = record - { isEquivalence = isEquivalence - ; ∙-cong = ⊕-cong - } - - ⊕-isSemigroup : IsSemigroup _⊕_ - ⊕-isSemigroup = record - { isMagma = ⊕-isMagma - ; assoc = ⊕-assoc - } - - ⊕-⊥-isMonoid : IsMonoid _⊕_ ⊥ - ⊕-⊥-isMonoid = record - { isSemigroup = ⊕-isSemigroup - ; identity = ⊕-identity - } - - ⊕-⊥-isGroup : IsGroup _⊕_ ⊥ id - ⊕-⊥-isGroup = record - { isMonoid = ⊕-⊥-isMonoid - ; inverse = ⊕-inverse - ; ⁻¹-cong = id - } - - ⊕-⊥-isAbelianGroup : IsAbelianGroup _⊕_ ⊥ id - ⊕-⊥-isAbelianGroup = record - { isGroup = ⊕-⊥-isGroup - ; comm = ⊕-comm - } - - ⊕-∧-isRing : IsRing _⊕_ _∧_ id ⊥ ⊤ - ⊕-∧-isRing = record - { +-isAbelianGroup = ⊕-⊥-isAbelianGroup - ; *-cong = ∧-cong - ; *-assoc = ∧-assoc - ; *-identity = ∧-identity - ; distrib = ∧-distrib-⊕ - ; zero = ∧-zero - } - - ⊕-∧-isCommutativeRing : IsCommutativeRing _⊕_ _∧_ id ⊥ ⊤ - ⊕-∧-isCommutativeRing = record - { isRing = ⊕-∧-isRing - ; *-comm = ∧-comm - } - - ⊕-∧-commutativeRing : CommutativeRing _ _ - ⊕-∧-commutativeRing = record - { isCommutativeRing = ⊕-∧-isCommutativeRing - } - - -infixl 6 _⊕_ - -_⊕_ : Op₂ Carrier -x ⊕ y = (x ∨ y) ∧ ¬ (x ∧ y) - -module DefaultXorRing = XorRing _⊕_ (λ _ _ → refl) +∧-zeroʳ : RightZero ⊥ _∧_ +∧-zeroʳ x = begin + x ∧ ⊥ ≈⟨ ∧-congˡ (∧-complementʳ x) ⟨ + x ∧ x ∧ ¬ x ≈⟨ ∧-assoc x x (¬ x) ⟨ + (x ∧ x) ∧ ¬ x ≈⟨ ∧-congʳ (∧-idem x) ⟩ + x ∧ ¬ x ≈⟨ ∧-complementʳ x ⟩ + ⊥ ∎ + +∧-zeroˡ : LeftZero ⊥ _∧_ +∧-zeroˡ = comm∧zeʳ⇒zeˡ ∧-comm ∧-zeroʳ + +∧-zero : Zero ⊥ _∧_ +∧-zero = ∧-zeroˡ , ∧-zeroʳ + +∨-zeroʳ : ∀ x → x ∨ ⊤ ≈ ⊤ +∨-zeroʳ x = begin + x ∨ ⊤ ≈⟨ ∨-congˡ (∨-complementʳ x) ⟨ + x ∨ x ∨ ¬ x ≈⟨ ∨-assoc x x (¬ x) ⟨ + (x ∨ x) ∨ ¬ x ≈⟨ ∨-congʳ (∨-idem x) ⟩ + x ∨ ¬ x ≈⟨ ∨-complementʳ x ⟩ + ⊤ ∎ + +∨-zeroˡ : LeftZero ⊤ _∨_ +∨-zeroˡ = comm∧zeʳ⇒zeˡ ∨-comm ∨-zeroʳ + +∨-zero : Zero ⊤ _∨_ +∨-zero = ∨-zeroˡ , ∨-zeroʳ + +∨-⊥-isMonoid : IsMonoid _∨_ ⊥ +∨-⊥-isMonoid = record + { isSemigroup = ∨-isSemigroup + ; identity = ∨-identity + } + +∧-⊤-isMonoid : IsMonoid _∧_ ⊤ +∧-⊤-isMonoid = record + { isSemigroup = ∧-isSemigroup + ; identity = ∧-identity + } + +∨-⊥-isCommutativeMonoid : IsCommutativeMonoid _∨_ ⊥ +∨-⊥-isCommutativeMonoid = record + { isMonoid = ∨-⊥-isMonoid + ; comm = ∨-comm + } + +∧-⊤-isCommutativeMonoid : IsCommutativeMonoid _∧_ ⊤ +∧-⊤-isCommutativeMonoid = record + { isMonoid = ∧-⊤-isMonoid + ; comm = ∧-comm + } + +∨-∧-isSemiring : IsSemiring _∨_ _∧_ ⊥ ⊤ +∨-∧-isSemiring = record + { isSemiringWithoutAnnihilatingZero = record + { +-isCommutativeMonoid = ∨-⊥-isCommutativeMonoid + ; *-cong = ∧-cong + ; *-assoc = ∧-assoc + ; *-identity = ∧-identity + ; distrib = ∧-distrib-∨ + } + ; zero = ∧-zero + } + +∧-∨-isSemiring : IsSemiring _∧_ _∨_ ⊤ ⊥ +∧-∨-isSemiring = record + { isSemiringWithoutAnnihilatingZero = record + { +-isCommutativeMonoid = ∧-⊤-isCommutativeMonoid + ; *-cong = ∨-cong + ; *-assoc = ∨-assoc + ; *-identity = ∨-identity + ; distrib = ∨-distrib-∧ + } + ; zero = ∨-zero + } + +∨-∧-isCommutativeSemiring : IsCommutativeSemiring _∨_ _∧_ ⊥ ⊤ +∨-∧-isCommutativeSemiring = record + { isSemiring = ∨-∧-isSemiring + ; *-comm = ∧-comm + } + +∧-∨-isCommutativeSemiring : IsCommutativeSemiring _∧_ _∨_ ⊤ ⊥ +∧-∨-isCommutativeSemiring = record + { isSemiring = ∧-∨-isSemiring + ; *-comm = ∨-comm + } + +∨-∧-commutativeSemiring : CommutativeSemiring _ _ +∨-∧-commutativeSemiring = record + { isCommutativeSemiring = ∨-∧-isCommutativeSemiring + } + +∧-∨-commutativeSemiring : CommutativeSemiring _ _ +∧-∨-commutativeSemiring = record + { isCommutativeSemiring = ∧-∨-isCommutativeSemiring + } + +------------------------------------------------------------------------ +-- Some other properties + +-- I took the statement of this lemma (called Uniqueness of +-- Complements) from some course notes, "Boolean Algebra", written +-- by Gert Smolka. + +private + lemma : ∀ x y → x ∧ y ≈ ⊥ → x ∨ y ≈ ⊤ → ¬ x ≈ y + lemma x y x∧y=⊥ x∨y=⊤ = begin + ¬ x ≈⟨ ∧-identityʳ _ ⟨ + ¬ x ∧ ⊤ ≈⟨ ∧-congˡ x∨y=⊤ ⟨ + ¬ x ∧ (x ∨ y) ≈⟨ ∧-distribˡ-∨ _ _ _ ⟩ + ¬ x ∧ x ∨ ¬ x ∧ y ≈⟨ ∨-congʳ $ ∧-complementˡ _ ⟩ + ⊥ ∨ ¬ x ∧ y ≈⟨ ∨-congʳ x∧y=⊥ ⟨ + x ∧ y ∨ ¬ x ∧ y ≈⟨ ∧-distribʳ-∨ _ _ _ ⟨ + (x ∨ ¬ x) ∧ y ≈⟨ ∧-congʳ $ ∨-complementʳ _ ⟩ + ⊤ ∧ y ≈⟨ ∧-identityˡ _ ⟩ + y ∎ + +⊥≉⊤ : ¬ ⊥ ≈ ⊤ +⊥≉⊤ = lemma ⊥ ⊤ (∧-identityʳ _) (∨-zeroʳ _) + +⊤≉⊥ : ¬ ⊤ ≈ ⊥ +⊤≉⊥ = lemma ⊤ ⊥ (∧-zeroʳ _) (∨-identityʳ _) + +¬-involutive : Involutive ¬_ +¬-involutive x = lemma (¬ x) x (∧-complementˡ _) (∨-complementˡ _) + +deMorgan₁ : ∀ x y → ¬ (x ∧ y) ≈ ¬ x ∨ ¬ y +deMorgan₁ x y = lemma (x ∧ y) (¬ x ∨ ¬ y) lem₁ lem₂ + where + lem₁ = begin + (x ∧ y) ∧ (¬ x ∨ ¬ y) ≈⟨ ∧-distribˡ-∨ _ _ _ ⟩ + (x ∧ y) ∧ ¬ x ∨ (x ∧ y) ∧ ¬ y ≈⟨ ∨-congʳ $ ∧-congʳ $ ∧-comm _ _ ⟩ + (y ∧ x) ∧ ¬ x ∨ (x ∧ y) ∧ ¬ y ≈⟨ ∧-assoc _ _ _ ⟨ ∨-cong ⟩ ∧-assoc _ _ _ ⟩ + y ∧ (x ∧ ¬ x) ∨ x ∧ (y ∧ ¬ y) ≈⟨ (∧-congˡ $ ∧-complementʳ _) ⟨ ∨-cong ⟩ + (∧-congˡ $ ∧-complementʳ _) ⟩ + (y ∧ ⊥) ∨ (x ∧ ⊥) ≈⟨ ∧-zeroʳ _ ⟨ ∨-cong ⟩ ∧-zeroʳ _ ⟩ + ⊥ ∨ ⊥ ≈⟨ ∨-identityʳ _ ⟩ + ⊥ ∎ + + lem₃ = begin + (x ∧ y) ∨ ¬ x ≈⟨ ∨-distribʳ-∧ _ _ _ ⟩ + (x ∨ ¬ x) ∧ (y ∨ ¬ x) ≈⟨ ∧-congʳ $ ∨-complementʳ _ ⟩ + ⊤ ∧ (y ∨ ¬ x) ≈⟨ ∧-identityˡ _ ⟩ + y ∨ ¬ x ≈⟨ ∨-comm _ _ ⟩ + ¬ x ∨ y ∎ + + lem₂ = begin + (x ∧ y) ∨ (¬ x ∨ ¬ y) ≈⟨ ∨-assoc _ _ _ ⟨ + ((x ∧ y) ∨ ¬ x) ∨ ¬ y ≈⟨ ∨-congʳ lem₃ ⟩ + (¬ x ∨ y) ∨ ¬ y ≈⟨ ∨-assoc _ _ _ ⟩ + ¬ x ∨ (y ∨ ¬ y) ≈⟨ ∨-congˡ $ ∨-complementʳ _ ⟩ + ¬ x ∨ ⊤ ≈⟨ ∨-zeroʳ _ ⟩ + ⊤ ∎ + +deMorgan₂ : ∀ x y → ¬ (x ∨ y) ≈ ¬ x ∧ ¬ y +deMorgan₂ x y = begin + ¬ (x ∨ y) ≈⟨ ¬-cong $ ((¬-involutive _) ⟨ ∨-cong ⟩ (¬-involutive _)) ⟨ + ¬ (¬ ¬ x ∨ ¬ ¬ y) ≈⟨ ¬-cong $ deMorgan₁ _ _ ⟨ + ¬ ¬ (¬ x ∧ ¬ y) ≈⟨ ¬-involutive _ ⟩ + ¬ x ∧ ¬ y ∎ + +------------------------------------------------------------------------ +-- (⊕, ∧, id, ⊥, ⊤) is a commutative ring + +-- This construction is parameterised over the definition of xor. + +module XorRing + (xor : Op₂ Carrier) + (⊕-def : ∀ x y → xor x y ≈ (x ∨ y) ∧ ¬ (x ∧ y)) + where + + private + infixl 6 _⊕_ + + _⊕_ : Op₂ Carrier + _⊕_ = xor + + helper : ∀ {x y u v} → x ≈ y → u ≈ v → x ∧ ¬ u ≈ y ∧ ¬ v + helper x≈y u≈v = x≈y ⟨ ∧-cong ⟩ ¬-cong u≈v + + ⊕-cong : Congruent₂ _⊕_ + ⊕-cong {x} {y} {u} {v} x≈y u≈v = begin + x ⊕ u ≈⟨ ⊕-def _ _ ⟩ + (x ∨ u) ∧ ¬ (x ∧ u) ≈⟨ helper (x≈y ⟨ ∨-cong ⟩ u≈v) + (x≈y ⟨ ∧-cong ⟩ u≈v) ⟩ + (y ∨ v) ∧ ¬ (y ∧ v) ≈⟨ ⊕-def _ _ ⟨ + y ⊕ v ∎ + + ⊕-comm : Commutative _⊕_ + ⊕-comm x y = begin + x ⊕ y ≈⟨ ⊕-def _ _ ⟩ + (x ∨ y) ∧ ¬ (x ∧ y) ≈⟨ helper (∨-comm _ _) (∧-comm _ _) ⟩ + (y ∨ x) ∧ ¬ (y ∧ x) ≈⟨ ⊕-def _ _ ⟨ + y ⊕ x ∎ + + ¬-distribˡ-⊕ : ∀ x y → ¬ (x ⊕ y) ≈ ¬ x ⊕ y + ¬-distribˡ-⊕ x y = begin + ¬ (x ⊕ y) ≈⟨ ¬-cong $ ⊕-def _ _ ⟩ + ¬ ((x ∨ y) ∧ (¬ (x ∧ y))) ≈⟨ ¬-cong (∧-distribʳ-∨ _ _ _) ⟩ + ¬ ((x ∧ ¬ (x ∧ y)) ∨ (y ∧ ¬ (x ∧ y))) ≈⟨ ¬-cong $ ∨-congˡ $ ∧-congˡ $ ¬-cong (∧-comm _ _) ⟩ + ¬ ((x ∧ ¬ (x ∧ y)) ∨ (y ∧ ¬ (y ∧ x))) ≈⟨ ¬-cong $ lem _ _ ⟨ ∨-cong ⟩ lem _ _ ⟩ + ¬ ((x ∧ ¬ y) ∨ (y ∧ ¬ x)) ≈⟨ deMorgan₂ _ _ ⟩ + ¬ (x ∧ ¬ y) ∧ ¬ (y ∧ ¬ x) ≈⟨ ∧-congʳ $ deMorgan₁ _ _ ⟩ + (¬ x ∨ (¬ ¬ y)) ∧ ¬ (y ∧ ¬ x) ≈⟨ helper (∨-congˡ $ ¬-involutive _) (∧-comm _ _) ⟩ + (¬ x ∨ y) ∧ ¬ (¬ x ∧ y) ≈⟨ ⊕-def _ _ ⟨ + ¬ x ⊕ y ∎ + where + lem : ∀ x y → x ∧ ¬ (x ∧ y) ≈ x ∧ ¬ y + lem x y = begin + x ∧ ¬ (x ∧ y) ≈⟨ ∧-congˡ $ deMorgan₁ _ _ ⟩ + x ∧ (¬ x ∨ ¬ y) ≈⟨ ∧-distribˡ-∨ _ _ _ ⟩ + (x ∧ ¬ x) ∨ (x ∧ ¬ y) ≈⟨ ∨-congʳ $ ∧-complementʳ _ ⟩ + ⊥ ∨ (x ∧ ¬ y) ≈⟨ ∨-identityˡ _ ⟩ + x ∧ ¬ y ∎ + + ¬-distribʳ-⊕ : ∀ x y → ¬ (x ⊕ y) ≈ x ⊕ ¬ y + ¬-distribʳ-⊕ x y = begin + ¬ (x ⊕ y) ≈⟨ ¬-cong $ ⊕-comm _ _ ⟩ + ¬ (y ⊕ x) ≈⟨ ¬-distribˡ-⊕ _ _ ⟩ + ¬ y ⊕ x ≈⟨ ⊕-comm _ _ ⟩ + x ⊕ ¬ y ∎ + + ⊕-annihilates-¬ : ∀ x y → x ⊕ y ≈ ¬ x ⊕ ¬ y + ⊕-annihilates-¬ x y = begin + x ⊕ y ≈⟨ ¬-involutive _ ⟨ + ¬ ¬ (x ⊕ y) ≈⟨ ¬-cong $ ¬-distribˡ-⊕ _ _ ⟩ + ¬ (¬ x ⊕ y) ≈⟨ ¬-distribʳ-⊕ _ _ ⟩ + ¬ x ⊕ ¬ y ∎ + + ⊕-identityˡ : LeftIdentity ⊥ _⊕_ + ⊕-identityˡ x = begin + ⊥ ⊕ x ≈⟨ ⊕-def _ _ ⟩ + (⊥ ∨ x) ∧ ¬ (⊥ ∧ x) ≈⟨ helper (∨-identityˡ _) (∧-zeroˡ _) ⟩ + x ∧ ¬ ⊥ ≈⟨ ∧-congˡ ⊥≉⊤ ⟩ + x ∧ ⊤ ≈⟨ ∧-identityʳ _ ⟩ + x ∎ + + ⊕-identityʳ : RightIdentity ⊥ _⊕_ + ⊕-identityʳ _ = ⊕-comm _ _ ⟨ trans ⟩ ⊕-identityˡ _ + + ⊕-identity : Identity ⊥ _⊕_ + ⊕-identity = ⊕-identityˡ , ⊕-identityʳ + + ⊕-inverseˡ : LeftInverse ⊥ id _⊕_ + ⊕-inverseˡ x = begin + x ⊕ x ≈⟨ ⊕-def _ _ ⟩ + (x ∨ x) ∧ ¬ (x ∧ x) ≈⟨ helper (∨-idem _) (∧-idem _) ⟩ + x ∧ ¬ x ≈⟨ ∧-complementʳ _ ⟩ + ⊥ ∎ + + ⊕-inverseʳ : RightInverse ⊥ id _⊕_ + ⊕-inverseʳ _ = ⊕-comm _ _ ⟨ trans ⟩ ⊕-inverseˡ _ + + ⊕-inverse : Inverse ⊥ id _⊕_ + ⊕-inverse = ⊕-inverseˡ , ⊕-inverseʳ + + ∧-distribˡ-⊕ : _∧_ DistributesOverˡ _⊕_ + ∧-distribˡ-⊕ x y z = begin + x ∧ (y ⊕ z) ≈⟨ ∧-congˡ $ ⊕-def _ _ ⟩ + x ∧ ((y ∨ z) ∧ ¬ (y ∧ z)) ≈⟨ ∧-assoc _ _ _ ⟨ + (x ∧ (y ∨ z)) ∧ ¬ (y ∧ z) ≈⟨ ∧-congˡ $ deMorgan₁ _ _ ⟩ + (x ∧ (y ∨ z)) ∧ + (¬ y ∨ ¬ z) ≈⟨ ∨-identityˡ _ ⟨ + ⊥ ∨ + ((x ∧ (y ∨ z)) ∧ + (¬ y ∨ ¬ z)) ≈⟨ ∨-congʳ lem₃ ⟩ + ((x ∧ (y ∨ z)) ∧ ¬ x) ∨ + ((x ∧ (y ∨ z)) ∧ + (¬ y ∨ ¬ z)) ≈⟨ ∧-distribˡ-∨ _ _ _ ⟨ + (x ∧ (y ∨ z)) ∧ + (¬ x ∨ (¬ y ∨ ¬ z)) ≈⟨ ∧-congˡ $ ∨-congˡ (deMorgan₁ _ _) ⟨ + (x ∧ (y ∨ z)) ∧ + (¬ x ∨ ¬ (y ∧ z)) ≈⟨ ∧-congˡ (deMorgan₁ _ _) ⟨ + (x ∧ (y ∨ z)) ∧ + ¬ (x ∧ (y ∧ z)) ≈⟨ helper refl lem₁ ⟩ + (x ∧ (y ∨ z)) ∧ + ¬ ((x ∧ y) ∧ (x ∧ z)) ≈⟨ ∧-congʳ $ ∧-distribˡ-∨ _ _ _ ⟩ + ((x ∧ y) ∨ (x ∧ z)) ∧ + ¬ ((x ∧ y) ∧ (x ∧ z)) ≈⟨ ⊕-def _ _ ⟨ + (x ∧ y) ⊕ (x ∧ z) ∎ + where + lem₂ = begin + x ∧ (y ∧ z) ≈⟨ ∧-assoc _ _ _ ⟨ + (x ∧ y) ∧ z ≈⟨ ∧-congʳ $ ∧-comm _ _ ⟩ + (y ∧ x) ∧ z ≈⟨ ∧-assoc _ _ _ ⟩ + y ∧ (x ∧ z) ∎ + + lem₁ = begin + x ∧ (y ∧ z) ≈⟨ ∧-congʳ (∧-idem _) ⟨ + (x ∧ x) ∧ (y ∧ z) ≈⟨ ∧-assoc _ _ _ ⟩ + x ∧ (x ∧ (y ∧ z)) ≈⟨ ∧-congˡ lem₂ ⟩ + x ∧ (y ∧ (x ∧ z)) ≈⟨ ∧-assoc _ _ _ ⟨ + (x ∧ y) ∧ (x ∧ z) ∎ + + lem₃ = begin + ⊥ ≈⟨ ∧-zeroʳ _ ⟨ + (y ∨ z) ∧ ⊥ ≈⟨ ∧-congˡ (∧-complementʳ _) ⟨ + (y ∨ z) ∧ (x ∧ ¬ x) ≈⟨ ∧-assoc _ _ _ ⟨ + ((y ∨ z) ∧ x) ∧ ¬ x ≈⟨ ∧-congʳ (∧-comm _ _) ⟩ + (x ∧ (y ∨ z)) ∧ ¬ x ∎ + + ∧-distribʳ-⊕ : _∧_ DistributesOverʳ _⊕_ + ∧-distribʳ-⊕ = comm∧distrˡ⇒distrʳ ⊕-cong ∧-comm ∧-distribˡ-⊕ + + ∧-distrib-⊕ : _∧_ DistributesOver _⊕_ + ∧-distrib-⊕ = ∧-distribˡ-⊕ , ∧-distribʳ-⊕ + + private + + lemma₂ : ∀ x y u v → + (x ∧ y) ∨ (u ∧ v) ≈ + ((x ∨ u) ∧ (y ∨ u)) ∧ + ((x ∨ v) ∧ (y ∨ v)) + lemma₂ x y u v = begin + (x ∧ y) ∨ (u ∧ v) ≈⟨ ∨-distribˡ-∧ _ _ _ ⟩ + ((x ∧ y) ∨ u) ∧ ((x ∧ y) ∨ v) ≈⟨ ∨-distribʳ-∧ _ _ _ + ⟨ ∧-cong ⟩ + ∨-distribʳ-∧ _ _ _ ⟩ + ((x ∨ u) ∧ (y ∨ u)) ∧ + ((x ∨ v) ∧ (y ∨ v)) ∎ + + ⊕-assoc : Associative _⊕_ + ⊕-assoc x y z = sym $ begin + x ⊕ (y ⊕ z) ≈⟨ ⊕-cong refl (⊕-def _ _) ⟩ + x ⊕ ((y ∨ z) ∧ ¬ (y ∧ z)) ≈⟨ ⊕-def _ _ ⟩ + (x ∨ ((y ∨ z) ∧ ¬ (y ∧ z))) ∧ + ¬ (x ∧ ((y ∨ z) ∧ ¬ (y ∧ z))) ≈⟨ ∧-cong lem₃ lem₄ ⟩ + (((x ∨ y) ∨ z) ∧ ((x ∨ ¬ y) ∨ ¬ z)) ∧ + (((¬ x ∨ ¬ y) ∨ z) ∧ ((¬ x ∨ y) ∨ ¬ z)) ≈⟨ ∧-assoc _ _ _ ⟩ + ((x ∨ y) ∨ z) ∧ + (((x ∨ ¬ y) ∨ ¬ z) ∧ + (((¬ x ∨ ¬ y) ∨ z) ∧ ((¬ x ∨ y) ∨ ¬ z))) ≈⟨ ∧-congˡ lem₅ ⟩ + ((x ∨ y) ∨ z) ∧ + (((¬ x ∨ ¬ y) ∨ z) ∧ + (((x ∨ ¬ y) ∨ ¬ z) ∧ ((¬ x ∨ y) ∨ ¬ z))) ≈⟨ ∧-assoc _ _ _ ⟨ + (((x ∨ y) ∨ z) ∧ ((¬ x ∨ ¬ y) ∨ z)) ∧ + (((x ∨ ¬ y) ∨ ¬ z) ∧ ((¬ x ∨ y) ∨ ¬ z)) ≈⟨ ∧-cong lem₁ lem₂ ⟩ + (((x ∨ y) ∧ ¬ (x ∧ y)) ∨ z) ∧ + ¬ (((x ∨ y) ∧ ¬ (x ∧ y)) ∧ z) ≈⟨ ⊕-def _ _ ⟨ + ((x ∨ y) ∧ ¬ (x ∧ y)) ⊕ z ≈⟨ ⊕-cong (⊕-def _ _) refl ⟨ + (x ⊕ y) ⊕ z ∎ + where + lem₁ = begin + ((x ∨ y) ∨ z) ∧ ((¬ x ∨ ¬ y) ∨ z) ≈⟨ ∨-distribʳ-∧ _ _ _ ⟨ + ((x ∨ y) ∧ (¬ x ∨ ¬ y)) ∨ z ≈⟨ ∨-congʳ $ ∧-congˡ (deMorgan₁ _ _) ⟨ + ((x ∨ y) ∧ ¬ (x ∧ y)) ∨ z ∎ + + lem₂′ = begin + (x ∨ ¬ y) ∧ (¬ x ∨ y) ≈⟨ ∧-cong (∧-identityˡ _) (∧-identityʳ _) ⟨ + (⊤ ∧ (x ∨ ¬ y)) ∧ ((¬ x ∨ y) ∧ ⊤) ≈⟨ ∧-cong + (∧-cong (∨-complementˡ _) (∨-comm _ _)) + (∧-congˡ $ ∨-complementˡ _) ⟨ + ((¬ x ∨ x) ∧ (¬ y ∨ x)) ∧ + ((¬ x ∨ y) ∧ (¬ y ∨ y)) ≈⟨ lemma₂ _ _ _ _ ⟨ + (¬ x ∧ ¬ y) ∨ (x ∧ y) ≈⟨ ∨-cong (deMorgan₂ _ _) (¬-involutive _) ⟨ + ¬ (x ∨ y) ∨ ¬ ¬ (x ∧ y) ≈⟨ deMorgan₁ _ _ ⟨ + ¬ ((x ∨ y) ∧ ¬ (x ∧ y)) ∎ + + lem₂ = begin + ((x ∨ ¬ y) ∨ ¬ z) ∧ ((¬ x ∨ y) ∨ ¬ z) ≈⟨ ∨-distribʳ-∧ _ _ _ ⟨ + ((x ∨ ¬ y) ∧ (¬ x ∨ y)) ∨ ¬ z ≈⟨ ∨-congʳ lem₂′ ⟩ + ¬ ((x ∨ y) ∧ ¬ (x ∧ y)) ∨ ¬ z ≈⟨ deMorgan₁ _ _ ⟨ + ¬ (((x ∨ y) ∧ ¬ (x ∧ y)) ∧ z) ∎ + + lem₃ = begin + x ∨ ((y ∨ z) ∧ ¬ (y ∧ z)) ≈⟨ ∨-congˡ $ ∧-congˡ $ deMorgan₁ _ _ ⟩ + x ∨ ((y ∨ z) ∧ (¬ y ∨ ¬ z)) ≈⟨ ∨-distribˡ-∧ _ _ _ ⟩ + (x ∨ (y ∨ z)) ∧ (x ∨ (¬ y ∨ ¬ z)) ≈⟨ ∨-assoc _ _ _ ⟨ ∧-cong ⟩ ∨-assoc _ _ _ ⟨ + ((x ∨ y) ∨ z) ∧ ((x ∨ ¬ y) ∨ ¬ z) ∎ + + lem₄′ = begin + ¬ ((y ∨ z) ∧ ¬ (y ∧ z)) ≈⟨ deMorgan₁ _ _ ⟩ + ¬ (y ∨ z) ∨ ¬ ¬ (y ∧ z) ≈⟨ deMorgan₂ _ _ ⟨ ∨-cong ⟩ ¬-involutive _ ⟩ + (¬ y ∧ ¬ z) ∨ (y ∧ z) ≈⟨ lemma₂ _ _ _ _ ⟩ + ((¬ y ∨ y) ∧ (¬ z ∨ y)) ∧ + ((¬ y ∨ z) ∧ (¬ z ∨ z)) ≈⟨ (∨-complementˡ _ ⟨ ∧-cong ⟩ ∨-comm _ _) + ⟨ ∧-cong ⟩ + (∧-congˡ $ ∨-complementˡ _) ⟩ + (⊤ ∧ (y ∨ ¬ z)) ∧ + ((¬ y ∨ z) ∧ ⊤) ≈⟨ ∧-identityˡ _ ⟨ ∧-cong ⟩ ∧-identityʳ _ ⟩ + (y ∨ ¬ z) ∧ (¬ y ∨ z) ∎ + + lem₄ = begin + ¬ (x ∧ ((y ∨ z) ∧ ¬ (y ∧ z))) ≈⟨ deMorgan₁ _ _ ⟩ + ¬ x ∨ ¬ ((y ∨ z) ∧ ¬ (y ∧ z)) ≈⟨ ∨-congˡ lem₄′ ⟩ + ¬ x ∨ ((y ∨ ¬ z) ∧ (¬ y ∨ z)) ≈⟨ ∨-distribˡ-∧ _ _ _ ⟩ + (¬ x ∨ (y ∨ ¬ z)) ∧ + (¬ x ∨ (¬ y ∨ z)) ≈⟨ ∨-assoc _ _ _ ⟨ ∧-cong ⟩ ∨-assoc _ _ _ ⟨ + ((¬ x ∨ y) ∨ ¬ z) ∧ + ((¬ x ∨ ¬ y) ∨ z) ≈⟨ ∧-comm _ _ ⟩ + ((¬ x ∨ ¬ y) ∨ z) ∧ + ((¬ x ∨ y) ∨ ¬ z) ∎ + + lem₅ = begin + ((x ∨ ¬ y) ∨ ¬ z) ∧ + (((¬ x ∨ ¬ y) ∨ z) ∧ ((¬ x ∨ y) ∨ ¬ z)) ≈⟨ ∧-assoc _ _ _ ⟨ + (((x ∨ ¬ y) ∨ ¬ z) ∧ ((¬ x ∨ ¬ y) ∨ z)) ∧ + ((¬ x ∨ y) ∨ ¬ z) ≈⟨ ∧-congʳ $ ∧-comm _ _ ⟩ + (((¬ x ∨ ¬ y) ∨ z) ∧ ((x ∨ ¬ y) ∨ ¬ z)) ∧ + ((¬ x ∨ y) ∨ ¬ z) ≈⟨ ∧-assoc _ _ _ ⟩ + ((¬ x ∨ ¬ y) ∨ z) ∧ + (((x ∨ ¬ y) ∨ ¬ z) ∧ ((¬ x ∨ y) ∨ ¬ z)) ∎ + + ⊕-isMagma : IsMagma _⊕_ + ⊕-isMagma = record + { isEquivalence = isEquivalence + ; ∙-cong = ⊕-cong + } + + ⊕-isSemigroup : IsSemigroup _⊕_ + ⊕-isSemigroup = record + { isMagma = ⊕-isMagma + ; assoc = ⊕-assoc + } + + ⊕-⊥-isMonoid : IsMonoid _⊕_ ⊥ + ⊕-⊥-isMonoid = record + { isSemigroup = ⊕-isSemigroup + ; identity = ⊕-identity + } + + ⊕-⊥-isGroup : IsGroup _⊕_ ⊥ id + ⊕-⊥-isGroup = record + { isMonoid = ⊕-⊥-isMonoid + ; inverse = ⊕-inverse + ; ⁻¹-cong = id + } + + ⊕-⊥-isAbelianGroup : IsAbelianGroup _⊕_ ⊥ id + ⊕-⊥-isAbelianGroup = record + { isGroup = ⊕-⊥-isGroup + ; comm = ⊕-comm + } + + ⊕-∧-isRing : IsRing _⊕_ _∧_ id ⊥ ⊤ + ⊕-∧-isRing = record + { +-isAbelianGroup = ⊕-⊥-isAbelianGroup + ; *-cong = ∧-cong + ; *-assoc = ∧-assoc + ; *-identity = ∧-identity + ; distrib = ∧-distrib-⊕ + } + + ⊕-∧-isCommutativeRing : IsCommutativeRing _⊕_ _∧_ id ⊥ ⊤ + ⊕-∧-isCommutativeRing = record + { isRing = ⊕-∧-isRing + ; *-comm = ∧-comm + } + + ⊕-∧-commutativeRing : CommutativeRing _ _ + ⊕-∧-commutativeRing = record + { isCommutativeRing = ⊕-∧-isCommutativeRing + } + + +infixl 6 _⊕_ + +_⊕_ : Op₂ Carrier +x ⊕ y = (x ∨ y) ∧ ¬ (x ∧ y) + +module DefaultXorRing = XorRing _⊕_ (λ _ _ → refl) \ No newline at end of file diff --git a/Algebra.Lattice.Properties.DistributiveLattice.html b/Algebra.Lattice.Properties.DistributiveLattice.html index faf913be..6863fa28 100644 --- a/Algebra.Lattice.Properties.DistributiveLattice.html +++ b/Algebra.Lattice.Properties.DistributiveLattice.html @@ -11,31 +11,31 @@ import Algebra.Lattice.Properties.Lattice as LatticeProperties module Algebra.Lattice.Properties.DistributiveLattice - {dl₁ dl₂} (DL : DistributiveLattice dl₁ dl₂) + {dl₁ dl₂} (DL : DistributiveLattice dl₁ dl₂) where -open DistributiveLattice DL -open import Algebra.Definitions _≈_ -open import Algebra.Lattice.Structures _≈_ -open import Relation.Binary.Reasoning.Setoid setoid +open DistributiveLattice DL +open import Algebra.Definitions _≈_ +open import Algebra.Lattice.Structures _≈_ +open import Relation.Binary.Reasoning.Setoid setoid ------------------------------------------------------------------------ -- Export properties of lattices -open LatticeProperties lattice public +open LatticeProperties lattice public ------------------------------------------------------------------------ -- The dual construction is also a distributive lattice. -∧-∨-isDistributiveLattice : IsDistributiveLattice _∧_ _∨_ +∧-∨-isDistributiveLattice : IsDistributiveLattice _∧_ _∨_ ∧-∨-isDistributiveLattice = record - { isLattice = ∧-∨-isLattice - ; ∨-distrib-∧ = ∧-distrib-∨ - ; ∧-distrib-∨ = ∨-distrib-∧ + { isLattice = ∧-∨-isLattice + ; ∨-distrib-∧ = ∧-distrib-∨ + ; ∧-distrib-∨ = ∨-distrib-∧ } -∧-∨-distributiveLattice : DistributiveLattice _ _ +∧-∨-distributiveLattice : DistributiveLattice _ _ ∧-∨-distributiveLattice = record - { isDistributiveLattice = ∧-∨-isDistributiveLattice + { isDistributiveLattice = ∧-∨-isDistributiveLattice } \ No newline at end of file diff --git a/Algebra.Lattice.Properties.Lattice.html b/Algebra.Lattice.Properties.Lattice.html index bc8a0dce..7a097ace 100644 --- a/Algebra.Lattice.Properties.Lattice.html +++ b/Algebra.Lattice.Properties.Lattice.html @@ -9,174 +9,174 @@ open import Algebra.Lattice.Bundles import Algebra.Lattice.Properties.Semilattice as SemilatticeProperties -open import Relation.Binary -import Relation.Binary.Lattice as R -open import Function.Base -open import Data.Product using (_,_; swap) - -module Algebra.Lattice.Properties.Lattice - {l₁ l₂} (L : Lattice l₁ l₂) where - -open Lattice L -open import Algebra.Definitions _≈_ -open import Algebra.Structures _≈_ -open import Algebra.Lattice.Structures _≈_ -open import Relation.Binary.Reasoning.Setoid setoid - ------------------------------------------------------------------------- --- _∧_ is a semilattice - -∧-idem : Idempotent _∧_ -∧-idem x = begin - x ∧ x ≈˘⟨ ∧-congˡ (∨-absorbs-∧ _ _) ⟩ - x ∧ (x ∨ x ∧ x) ≈⟨ ∧-absorbs-∨ _ _ ⟩ - x ∎ - -∧-isMagma : IsMagma _∧_ -∧-isMagma = record - { isEquivalence = isEquivalence - ; ∙-cong = ∧-cong - } - -∧-isSemigroup : IsSemigroup _∧_ -∧-isSemigroup = record - { isMagma = ∧-isMagma - ; assoc = ∧-assoc - } - -∧-isBand : IsBand _∧_ -∧-isBand = record - { isSemigroup = ∧-isSemigroup - ; idem = ∧-idem - } - -∧-isSemilattice : IsSemilattice _∧_ -∧-isSemilattice = record - { isBand = ∧-isBand - ; comm = ∧-comm - } - -∧-semilattice : Semilattice l₁ l₂ -∧-semilattice = record - { isSemilattice = ∧-isSemilattice - } - -open SemilatticeProperties ∧-semilattice public - using - ( ∧-isOrderTheoreticMeetSemilattice - ; ∧-isOrderTheoreticJoinSemilattice - ; ∧-orderTheoreticMeetSemilattice - ; ∧-orderTheoreticJoinSemilattice - ) - ------------------------------------------------------------------------- --- _∨_ is a semilattice - -∨-idem : Idempotent _∨_ -∨-idem x = begin - x ∨ x ≈˘⟨ ∨-congˡ (∧-idem _) ⟩ - x ∨ x ∧ x ≈⟨ ∨-absorbs-∧ _ _ ⟩ - x ∎ - -∨-isMagma : IsMagma _∨_ -∨-isMagma = record - { isEquivalence = isEquivalence - ; ∙-cong = ∨-cong - } - -∨-isSemigroup : IsSemigroup _∨_ -∨-isSemigroup = record - { isMagma = ∨-isMagma - ; assoc = ∨-assoc - } - -∨-isBand : IsBand _∨_ -∨-isBand = record - { isSemigroup = ∨-isSemigroup - ; idem = ∨-idem - } - -∨-isSemilattice : IsSemilattice _∨_ -∨-isSemilattice = record - { isBand = ∨-isBand - ; comm = ∨-comm - } - -∨-semilattice : Semilattice l₁ l₂ -∨-semilattice = record - { isSemilattice = ∨-isSemilattice - } - -open SemilatticeProperties ∨-semilattice public - using () - renaming - ( ∧-isOrderTheoreticMeetSemilattice to ∨-isOrderTheoreticMeetSemilattice - ; ∧-isOrderTheoreticJoinSemilattice to ∨-isOrderTheoreticJoinSemilattice - ; ∧-orderTheoreticMeetSemilattice to ∨-orderTheoreticMeetSemilattice - ; ∧-orderTheoreticJoinSemilattice to ∨-orderTheoreticJoinSemilattice - ) - ------------------------------------------------------------------------- --- The dual construction is also a lattice. - -∧-∨-isLattice : IsLattice _∧_ _∨_ -∧-∨-isLattice = record - { isEquivalence = isEquivalence - ; ∨-comm = ∧-comm - ; ∨-assoc = ∧-assoc - ; ∨-cong = ∧-cong - ; ∧-comm = ∨-comm - ; ∧-assoc = ∨-assoc - ; ∧-cong = ∨-cong - ; absorptive = swap absorptive - } - -∧-∨-lattice : Lattice _ _ -∧-∨-lattice = record - { isLattice = ∧-∨-isLattice - } - ------------------------------------------------------------------------- --- Every algebraic lattice can be turned into an order-theoretic one. - -open SemilatticeProperties ∧-semilattice public using (poset) -open Poset poset using (_≤_; isPartialOrder) - -∨-∧-isOrderTheoreticLattice : R.IsLattice _≈_ _≤_ _∨_ _∧_ -∨-∧-isOrderTheoreticLattice = record - { isPartialOrder = isPartialOrder - ; supremum = supremum - ; infimum = infimum - } - where - open R.MeetSemilattice ∧-orderTheoreticMeetSemilattice using (infimum) - open R.JoinSemilattice ∨-orderTheoreticJoinSemilattice using (x≤x∨y; y≤x∨y; ∨-least) - renaming (_≤_ to _≤′_) - - -- An alternative but equivalent interpretation of the order _≤_. - - sound : ∀ {x y} → x ≤′ y → x ≤ y - sound {x} {y} y≈y∨x = sym $ begin - x ∧ y ≈⟨ ∧-congˡ y≈y∨x ⟩ - x ∧ (y ∨ x) ≈⟨ ∧-congˡ (∨-comm y x) ⟩ - x ∧ (x ∨ y) ≈⟨ ∧-absorbs-∨ x y ⟩ - x ∎ - - complete : ∀ {x y} → x ≤ y → x ≤′ y - complete {x} {y} x≈x∧y = sym $ begin - y ∨ x ≈⟨ ∨-congˡ x≈x∧y ⟩ - y ∨ (x ∧ y) ≈⟨ ∨-congˡ (∧-comm x y) ⟩ - y ∨ (y ∧ x) ≈⟨ ∨-absorbs-∧ y x ⟩ - y ∎ - - supremum : R.Supremum _≤_ _∨_ - supremum x y = - sound (x≤x∨y x y) , - sound (y≤x∨y x y) , - λ z x≤z y≤z → sound (∨-least (complete x≤z) (complete y≤z)) - -∨-∧-orderTheoreticLattice : R.Lattice _ _ _ -∨-∧-orderTheoreticLattice = record - { isLattice = ∨-∧-isOrderTheoreticLattice - } +open import Relation.Binary.Bundles using (Poset) +import Relation.Binary.Lattice as R +open import Function.Base +open import Data.Product.Base using (_,_; swap) + +module Algebra.Lattice.Properties.Lattice + {l₁ l₂} (L : Lattice l₁ l₂) where + +open Lattice L +open import Algebra.Definitions _≈_ +open import Algebra.Structures _≈_ +open import Algebra.Lattice.Structures _≈_ +open import Relation.Binary.Reasoning.Setoid setoid + +------------------------------------------------------------------------ +-- _∧_ is a semilattice + +∧-idem : Idempotent _∧_ +∧-idem x = begin + x ∧ x ≈⟨ ∧-congˡ (∨-absorbs-∧ _ _) ⟨ + x ∧ (x ∨ x ∧ x) ≈⟨ ∧-absorbs-∨ _ _ ⟩ + x ∎ + +∧-isMagma : IsMagma _∧_ +∧-isMagma = record + { isEquivalence = isEquivalence + ; ∙-cong = ∧-cong + } + +∧-isSemigroup : IsSemigroup _∧_ +∧-isSemigroup = record + { isMagma = ∧-isMagma + ; assoc = ∧-assoc + } + +∧-isBand : IsBand _∧_ +∧-isBand = record + { isSemigroup = ∧-isSemigroup + ; idem = ∧-idem + } + +∧-isSemilattice : IsSemilattice _∧_ +∧-isSemilattice = record + { isBand = ∧-isBand + ; comm = ∧-comm + } + +∧-semilattice : Semilattice l₁ l₂ +∧-semilattice = record + { isSemilattice = ∧-isSemilattice + } + +open SemilatticeProperties ∧-semilattice public + using + ( ∧-isOrderTheoreticMeetSemilattice + ; ∧-isOrderTheoreticJoinSemilattice + ; ∧-orderTheoreticMeetSemilattice + ; ∧-orderTheoreticJoinSemilattice + ) + +------------------------------------------------------------------------ +-- _∨_ is a semilattice + +∨-idem : Idempotent _∨_ +∨-idem x = begin + x ∨ x ≈⟨ ∨-congˡ (∧-idem _) ⟨ + x ∨ x ∧ x ≈⟨ ∨-absorbs-∧ _ _ ⟩ + x ∎ + +∨-isMagma : IsMagma _∨_ +∨-isMagma = record + { isEquivalence = isEquivalence + ; ∙-cong = ∨-cong + } + +∨-isSemigroup : IsSemigroup _∨_ +∨-isSemigroup = record + { isMagma = ∨-isMagma + ; assoc = ∨-assoc + } + +∨-isBand : IsBand _∨_ +∨-isBand = record + { isSemigroup = ∨-isSemigroup + ; idem = ∨-idem + } + +∨-isSemilattice : IsSemilattice _∨_ +∨-isSemilattice = record + { isBand = ∨-isBand + ; comm = ∨-comm + } + +∨-semilattice : Semilattice l₁ l₂ +∨-semilattice = record + { isSemilattice = ∨-isSemilattice + } + +open SemilatticeProperties ∨-semilattice public + using () + renaming + ( ∧-isOrderTheoreticMeetSemilattice to ∨-isOrderTheoreticMeetSemilattice + ; ∧-isOrderTheoreticJoinSemilattice to ∨-isOrderTheoreticJoinSemilattice + ; ∧-orderTheoreticMeetSemilattice to ∨-orderTheoreticMeetSemilattice + ; ∧-orderTheoreticJoinSemilattice to ∨-orderTheoreticJoinSemilattice + ) + +------------------------------------------------------------------------ +-- The dual construction is also a lattice. + +∧-∨-isLattice : IsLattice _∧_ _∨_ +∧-∨-isLattice = record + { isEquivalence = isEquivalence + ; ∨-comm = ∧-comm + ; ∨-assoc = ∧-assoc + ; ∨-cong = ∧-cong + ; ∧-comm = ∨-comm + ; ∧-assoc = ∨-assoc + ; ∧-cong = ∨-cong + ; absorptive = swap absorptive + } + +∧-∨-lattice : Lattice _ _ +∧-∨-lattice = record + { isLattice = ∧-∨-isLattice + } + +------------------------------------------------------------------------ +-- Every algebraic lattice can be turned into an order-theoretic one. + +open SemilatticeProperties ∧-semilattice public using (poset) +open Poset poset using (_≤_; isPartialOrder) + +∨-∧-isOrderTheoreticLattice : R.IsLattice _≈_ _≤_ _∨_ _∧_ +∨-∧-isOrderTheoreticLattice = record + { isPartialOrder = isPartialOrder + ; supremum = supremum + ; infimum = infimum + } + where + open R.MeetSemilattice ∧-orderTheoreticMeetSemilattice using (infimum) + open R.JoinSemilattice ∨-orderTheoreticJoinSemilattice using (x≤x∨y; y≤x∨y; ∨-least) + renaming (_≤_ to _≤′_) + + -- An alternative but equivalent interpretation of the order _≤_. + + sound : ∀ {x y} → x ≤′ y → x ≤ y + sound {x} {y} y≈y∨x = sym $ begin + x ∧ y ≈⟨ ∧-congˡ y≈y∨x ⟩ + x ∧ (y ∨ x) ≈⟨ ∧-congˡ (∨-comm y x) ⟩ + x ∧ (x ∨ y) ≈⟨ ∧-absorbs-∨ x y ⟩ + x ∎ + + complete : ∀ {x y} → x ≤ y → x ≤′ y + complete {x} {y} x≈x∧y = sym $ begin + y ∨ x ≈⟨ ∨-congˡ x≈x∧y ⟩ + y ∨ (x ∧ y) ≈⟨ ∨-congˡ (∧-comm x y) ⟩ + y ∨ (y ∧ x) ≈⟨ ∨-absorbs-∧ y x ⟩ + y ∎ + + supremum : R.Supremum _≤_ _∨_ + supremum x y = + sound (x≤x∨y x y) , + sound (y≤x∨y x y) , + λ z x≤z y≤z → sound (∨-least (complete x≤z) (complete y≤z)) + +∨-∧-orderTheoreticLattice : R.Lattice _ _ _ +∨-∧-orderTheoreticLattice = record + { isLattice = ∨-∧-isOrderTheoreticLattice + } \ No newline at end of file diff --git a/Algebra.Lattice.Properties.Semilattice.html b/Algebra.Lattice.Properties.Semilattice.html index 00986d50..c5739054 100644 --- a/Algebra.Lattice.Properties.Semilattice.html +++ b/Algebra.Lattice.Properties.Semilattice.html @@ -7,56 +7,53 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Algebra.Lattice -open import Algebra.Structures -open import Function -open import Data.Product -open import Relation.Binary -import Relation.Binary.Lattice as B -import Relation.Binary.Properties.Poset as PosetProperties - -module Algebra.Lattice.Properties.Semilattice - {c ℓ} (L : Semilattice c ℓ) where - -open Semilattice L renaming (_∙_ to _∧_) - -open import Relation.Binary.Reasoning.Setoid setoid -import Relation.Binary.Construct.NaturalOrder.Left _≈_ _∧_ - as LeftNaturalOrder - ------------------------------------------------------------------------- --- Every semilattice can be turned into a poset via the left natural --- order. - -poset : Poset c ℓ ℓ -poset = LeftNaturalOrder.poset isSemilattice - -open Poset poset using (_≤_; isPartialOrder) -open PosetProperties poset using (_≥_; ≥-isPartialOrder) - ------------------------------------------------------------------------- --- Every algebraic semilattice can be turned into an order-theoretic one. - -∧-isOrderTheoreticMeetSemilattice : B.IsMeetSemilattice _≈_ _≤_ _∧_ -∧-isOrderTheoreticMeetSemilattice = record - { isPartialOrder = isPartialOrder - ; infimum = LeftNaturalOrder.infimum isSemilattice - } - -∧-isOrderTheoreticJoinSemilattice : B.IsJoinSemilattice _≈_ _≥_ _∧_ -∧-isOrderTheoreticJoinSemilattice = record - { isPartialOrder = ≥-isPartialOrder - ; supremum = B.IsMeetSemilattice.infimum - ∧-isOrderTheoreticMeetSemilattice - } - -∧-orderTheoreticMeetSemilattice : B.MeetSemilattice c ℓ ℓ -∧-orderTheoreticMeetSemilattice = record - { isMeetSemilattice = ∧-isOrderTheoreticMeetSemilattice - } - -∧-orderTheoreticJoinSemilattice : B.JoinSemilattice c ℓ ℓ -∧-orderTheoreticJoinSemilattice = record - { isJoinSemilattice = ∧-isOrderTheoreticJoinSemilattice - } +open import Algebra.Lattice.Bundles using (Semilattice) +open import Relation.Binary.Bundles using (Poset) +import Relation.Binary.Lattice as B +import Relation.Binary.Properties.Poset as PosetProperties + +module Algebra.Lattice.Properties.Semilattice + {c ℓ} (L : Semilattice c ℓ) where + +open Semilattice L renaming (_∙_ to _∧_) + +open import Relation.Binary.Reasoning.Setoid setoid +import Relation.Binary.Construct.NaturalOrder.Left _≈_ _∧_ + as LeftNaturalOrder + +------------------------------------------------------------------------ +-- Every semilattice can be turned into a poset via the left natural +-- order. + +poset : Poset c ℓ ℓ +poset = LeftNaturalOrder.poset isSemilattice + +open Poset poset using (_≤_; _≥_; isPartialOrder) +open PosetProperties poset using (≥-isPartialOrder) + +------------------------------------------------------------------------ +-- Every algebraic semilattice can be turned into an order-theoretic one. + +∧-isOrderTheoreticMeetSemilattice : B.IsMeetSemilattice _≈_ _≤_ _∧_ +∧-isOrderTheoreticMeetSemilattice = record + { isPartialOrder = isPartialOrder + ; infimum = LeftNaturalOrder.infimum isSemilattice + } + +∧-isOrderTheoreticJoinSemilattice : B.IsJoinSemilattice _≈_ _≥_ _∧_ +∧-isOrderTheoreticJoinSemilattice = record + { isPartialOrder = ≥-isPartialOrder + ; supremum = B.IsMeetSemilattice.infimum + ∧-isOrderTheoreticMeetSemilattice + } + +∧-orderTheoreticMeetSemilattice : B.MeetSemilattice c ℓ ℓ +∧-orderTheoreticMeetSemilattice = record + { isMeetSemilattice = ∧-isOrderTheoreticMeetSemilattice + } + +∧-orderTheoreticJoinSemilattice : B.JoinSemilattice c ℓ ℓ +∧-orderTheoreticJoinSemilattice = record + { isJoinSemilattice = ∧-isOrderTheoreticJoinSemilattice + } \ No newline at end of file diff --git a/Algebra.Lattice.Structures.Biased.html b/Algebra.Lattice.Structures.Biased.html index d874d216..9f4d977e 100644 --- a/Algebra.Lattice.Structures.Biased.html +++ b/Algebra.Lattice.Structures.Biased.html @@ -15,109 +15,111 @@ open import Algebra.Core open import Algebra.Consequences.Setoid -open import Data.Product using (proj₁; proj₂) -open import Level using (_⊔_) -open import Relation.Binary using (Rel; Setoid; IsEquivalence) - -module Algebra.Lattice.Structures.Biased - {a ℓ} {A : Set a} -- The underlying set - (_≈_ : Rel A ℓ) -- The underlying equality relation - where - -open import Algebra.Definitions _≈_ -open import Algebra.Lattice.Structures _≈_ - -private - variable - ∧ ∨ : Op₂ A - ¬ : Op₁ A - ⊤ ⊥ : A - ------------------------------------------------------------------------- --- Lattice - --- An alternative form of `IsLattice` defined in terms of --- `IsJoinSemilattice` and `IsMeetLattice`. This form may be desirable --- to use when constructing a lattice object as it requires fewer --- arguments, but is often a mistake to use as an argument as it --- contains two, *potentially different*, proofs that the equality --- relation _≈_ is an equivalence. - -record IsLattice₂ (∨ ∧ : Op₂ A) : Set (a ⊔ ℓ) where - field - isJoinSemilattice : IsJoinSemilattice ∨ - isMeetSemilattice : IsMeetSemilattice ∧ - absorptive : Absorptive ∨ ∧ - - module ML = IsMeetSemilattice isMeetSemilattice - module JL = IsJoinSemilattice isJoinSemilattice - - isLattice₂ : IsLattice ∨ ∧ - isLattice₂ = record - { isEquivalence = ML.isEquivalence - ; ∨-comm = JL.comm - ; ∨-assoc = JL.assoc - ; ∨-cong = JL.∨-cong - ; ∧-comm = ML.comm - ; ∧-assoc = ML.assoc - ; ∧-cong = ML.∧-cong - ; absorptive = absorptive - } - -open IsLattice₂ public using (isLattice₂) - ------------------------------------------------------------------------- --- DistributiveLattice - --- A version of distributive lattice that is biased towards the (r)ight --- distributivity law for (j)oin and (m)eet. -record IsDistributiveLatticeʳʲᵐ (∨ ∧ : Op₂ A) : Set (a ⊔ ℓ) where - field - isLattice : IsLattice ∨ ∧ - ∨-distribʳ-∧ : ∨ DistributesOverʳ ∧ - - open IsLattice isLattice public - - setoid : Setoid a ℓ - setoid = record { isEquivalence = isEquivalence } - - ∨-distrib-∧ = comm+distrʳ⇒distr setoid ∧-cong ∨-comm ∨-distribʳ-∧ - ∧-distribˡ-∨ = distrib+absorbs⇒distribˡ setoid ∧-cong ∧-assoc ∨-comm ∧-absorbs-∨ ∨-absorbs-∧ ∨-distrib-∧ - ∧-distrib-∨ = comm+distrˡ⇒distr setoid ∨-cong ∧-comm ∧-distribˡ-∨ - - isDistributiveLatticeʳʲᵐ : IsDistributiveLattice ∨ ∧ - isDistributiveLatticeʳʲᵐ = record - { isLattice = isLattice - ; ∨-distrib-∧ = ∨-distrib-∧ - ; ∧-distrib-∨ = ∧-distrib-∨ - } - -open IsDistributiveLatticeʳʲᵐ public using (isDistributiveLatticeʳʲᵐ) - ------------------------------------------------------------------------- --- BooleanAlgebra - --- A (r)ight biased version of a boolean algebra. -record IsBooleanAlgebraʳ - (∨ ∧ : Op₂ A) (¬ : Op₁ A) (⊤ ⊥ : A) : Set (a ⊔ ℓ) where - field - isDistributiveLattice : IsDistributiveLattice ∨ ∧ - ∨-complementʳ : RightInverse ⊤ ¬ ∨ - ∧-complementʳ : RightInverse ⊥ ¬ ∧ - ¬-cong : Congruent₁ ¬ - - open IsDistributiveLattice isDistributiveLattice public - - setoid : Setoid a ℓ - setoid = record { isEquivalence = isEquivalence } - - isBooleanAlgebraʳ : IsBooleanAlgebra ∨ ∧ ¬ ⊤ ⊥ - isBooleanAlgebraʳ = record - { isDistributiveLattice = isDistributiveLattice - ; ∨-complement = comm+invʳ⇒inv setoid ∨-comm ∨-complementʳ - ; ∧-complement = comm+invʳ⇒inv setoid ∧-comm ∧-complementʳ - ; ¬-cong = ¬-cong - } - -open IsBooleanAlgebraʳ public using (isBooleanAlgebraʳ) +open import Data.Product.Base using (proj₁; proj₂) +open import Level using (_⊔_) +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Binary.Structures using (IsEquivalence) + +module Algebra.Lattice.Structures.Biased + {a ℓ} {A : Set a} -- The underlying set + (_≈_ : Rel A ℓ) -- The underlying equality relation + where + +open import Algebra.Definitions _≈_ +open import Algebra.Lattice.Structures _≈_ + +private + variable + ∧ ∨ : Op₂ A + ¬ : Op₁ A + ⊤ ⊥ : A + +------------------------------------------------------------------------ +-- Lattice + +-- An alternative form of `IsLattice` defined in terms of +-- `IsJoinSemilattice` and `IsMeetLattice`. This form may be desirable +-- to use when constructing a lattice object as it requires fewer +-- arguments, but is often a mistake to use as an argument as it +-- contains two, *potentially different*, proofs that the equality +-- relation _≈_ is an equivalence. + +record IsLattice₂ (∨ ∧ : Op₂ A) : Set (a ⊔ ℓ) where + field + isJoinSemilattice : IsJoinSemilattice ∨ + isMeetSemilattice : IsMeetSemilattice ∧ + absorptive : Absorptive ∨ ∧ + + module ML = IsMeetSemilattice isMeetSemilattice + module JL = IsJoinSemilattice isJoinSemilattice + + isLattice₂ : IsLattice ∨ ∧ + isLattice₂ = record + { isEquivalence = ML.isEquivalence + ; ∨-comm = JL.comm + ; ∨-assoc = JL.assoc + ; ∨-cong = JL.∨-cong + ; ∧-comm = ML.comm + ; ∧-assoc = ML.assoc + ; ∧-cong = ML.∧-cong + ; absorptive = absorptive + } + +open IsLattice₂ public using (isLattice₂) + +------------------------------------------------------------------------ +-- DistributiveLattice + +-- A version of distributive lattice that is biased towards the (r)ight +-- distributivity law for (j)oin and (m)eet. +record IsDistributiveLatticeʳʲᵐ (∨ ∧ : Op₂ A) : Set (a ⊔ ℓ) where + field + isLattice : IsLattice ∨ ∧ + ∨-distribʳ-∧ : ∨ DistributesOverʳ ∧ + + open IsLattice isLattice public + + setoid : Setoid a ℓ + setoid = record { isEquivalence = isEquivalence } + + ∨-distrib-∧ = comm∧distrʳ⇒distr setoid ∧-cong ∨-comm ∨-distribʳ-∧ + ∧-distribˡ-∨ = distrib∧absorbs⇒distribˡ setoid ∧-cong ∧-assoc ∨-comm ∧-absorbs-∨ ∨-absorbs-∧ ∨-distrib-∧ + ∧-distrib-∨ = comm∧distrˡ⇒distr setoid ∨-cong ∧-comm ∧-distribˡ-∨ + + isDistributiveLatticeʳʲᵐ : IsDistributiveLattice ∨ ∧ + isDistributiveLatticeʳʲᵐ = record + { isLattice = isLattice + ; ∨-distrib-∧ = ∨-distrib-∧ + ; ∧-distrib-∨ = ∧-distrib-∨ + } + +open IsDistributiveLatticeʳʲᵐ public using (isDistributiveLatticeʳʲᵐ) + +------------------------------------------------------------------------ +-- BooleanAlgebra + +-- A (r)ight biased version of a boolean algebra. +record IsBooleanAlgebraʳ + (∨ ∧ : Op₂ A) (¬ : Op₁ A) (⊤ ⊥ : A) : Set (a ⊔ ℓ) where + field + isDistributiveLattice : IsDistributiveLattice ∨ ∧ + ∨-complementʳ : RightInverse ⊤ ¬ ∨ + ∧-complementʳ : RightInverse ⊥ ¬ ∧ + ¬-cong : Congruent₁ ¬ + + open IsDistributiveLattice isDistributiveLattice public + + setoid : Setoid a ℓ + setoid = record { isEquivalence = isEquivalence } + + isBooleanAlgebraʳ : IsBooleanAlgebra ∨ ∧ ¬ ⊤ ⊥ + isBooleanAlgebraʳ = record + { isDistributiveLattice = isDistributiveLattice + ; ∨-complement = comm∧invʳ⇒inv setoid ∨-comm ∨-complementʳ + ; ∧-complement = comm∧invʳ⇒inv setoid ∧-comm ∧-complementʳ + ; ¬-cong = ¬-cong + } + +open IsBooleanAlgebraʳ public using (isBooleanAlgebraʳ) \ No newline at end of file diff --git a/Algebra.Lattice.Structures.html b/Algebra.Lattice.Structures.html index addc2b62..6a5f9fbf 100644 --- a/Algebra.Lattice.Structures.html +++ b/Algebra.Lattice.Structures.html @@ -15,189 +15,186 @@ {-# OPTIONS --cubical-compatible --safe #-} open import Algebra.Core -open import Data.Product using (proj₁; proj₂) -open import Level using (_⊔_) -open import Relation.Binary using (Rel; Setoid; IsEquivalence) - -module Algebra.Lattice.Structures - {a ℓ} {A : Set a} -- The underlying set - (_≈_ : Rel A ℓ) -- The underlying equality relation - where - -open import Algebra.Definitions _≈_ -open import Algebra.Structures _≈_ - ------------------------------------------------------------------------- --- Structures with 1 binary operation - -record IsSemilattice (∙ : Op₂ A) : Set (a ⊔ ℓ) where - field - isBand : IsBand ∙ - comm : Commutative ∙ - - open IsBand isBand public - renaming - ( ∙-cong to ∧-cong - ; ∙-congˡ to ∧-congˡ - ; ∙-congʳ to ∧-congʳ - ) - --- Used to bring names appropriate for a meet semilattice into scope. -IsMeetSemilattice = IsSemilattice -module IsMeetSemilattice {∧} (L : IsMeetSemilattice ∧) where - open IsSemilattice L public - renaming - ( ∧-cong to ∧-cong - ; ∧-congˡ to ∧-congˡ - ; ∧-congʳ to ∧-congʳ - ) - --- Used to bring names appropriate for a join semilattice into scope. -IsJoinSemilattice = IsSemilattice -module IsJoinSemilattice {∨} (L : IsJoinSemilattice ∨) where - open IsSemilattice L public - renaming - ( ∧-cong to ∨-cong - ; ∧-congˡ to ∨-congˡ - ; ∧-congʳ to ∨-congʳ - ) - ------------------------------------------------------------------------- --- Structures with 1 binary operation & 1 element - --- A bounded semi-lattice is the same thing as an idempotent commutative --- monoid. -IsBoundedSemilattice = IsIdempotentCommutativeMonoid -module IsBoundedSemilattice {∙ ε} (L : IsBoundedSemilattice ∙ ε) where - - open IsIdempotentCommutativeMonoid L public - - isSemilattice : IsSemilattice ∙ - isSemilattice = record - { isBand = isBand - ; comm = comm - } - - --- Used to bring names appropriate for a bounded meet semilattice --- into scope. -IsBoundedMeetSemilattice = IsBoundedSemilattice -module IsBoundedMeetSemilattice {∧ ⊤} (L : IsBoundedMeetSemilattice ∧ ⊤) - where - - open IsBoundedSemilattice L public - using (identity; identityˡ; identityʳ) - renaming (isSemilattice to isMeetSemilattice) - - open IsMeetSemilattice isMeetSemilattice public - - --- Used to bring names appropriate for a bounded join semilattice --- into scope. -IsBoundedJoinSemilattice = IsBoundedSemilattice -module IsBoundedJoinSemilattice {∨ ⊥} (L : IsBoundedJoinSemilattice ∨ ⊥) - where - - open IsBoundedSemilattice L public - using (identity; identityˡ; identityʳ) - renaming (isSemilattice to isJoinSemilattice) - - open IsJoinSemilattice isJoinSemilattice public - ------------------------------------------------------------------------- --- Structures with 2 binary operations - --- Note that `IsLattice` is not defined in terms of `IsMeetSemilattice` --- and `IsJoinSemilattice` for two reasons: --- 1) it would result in a structure with two *different* proofs that --- the equality relation `≈` is an equivalence relation. --- 2) the idempotence laws of ∨ and ∧ can be derived from the --- absorption laws, which makes the corresponding "idem" fields --- redundant. --- --- It is possible to construct the `IsLattice` record from --- `IsMeetSemilattice` and `IsJoinSemilattice` via the `IsLattice₂` --- record found in `Algebra.Lattice.Structures.Biased`. --- --- The derived idempotence laws are stated and proved in --- `Algebra.Lattice.Properties.Lattice` along with the fact that every --- lattice consists of two semilattices. - -record IsLattice (∨ ∧ : Op₂ A) : Set (a ⊔ ℓ) where - field - isEquivalence : IsEquivalence _≈_ - ∨-comm : Commutative ∨ - ∨-assoc : Associative ∨ - ∨-cong : Congruent₂ ∨ - ∧-comm : Commutative ∧ - ∧-assoc : Associative ∧ - ∧-cong : Congruent₂ ∧ - absorptive : Absorptive ∨ ∧ - - open IsEquivalence isEquivalence public - - ∨-absorbs-∧ : ∨ Absorbs ∧ - ∨-absorbs-∧ = proj₁ absorptive - - ∧-absorbs-∨ : ∧ Absorbs ∨ - ∧-absorbs-∨ = proj₂ absorptive +open import Data.Product.Base using (proj₁; proj₂) +open import Level using (_⊔_) +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Binary.Structures using (IsEquivalence) + +module Algebra.Lattice.Structures + {a ℓ} {A : Set a} -- The underlying set + (_≈_ : Rel A ℓ) -- The underlying equality relation + where + +open import Algebra.Definitions _≈_ +open import Algebra.Structures _≈_ + +------------------------------------------------------------------------ +-- Structures with 1 binary operation + +record IsSemilattice (∙ : Op₂ A) : Set (a ⊔ ℓ) where + field + isBand : IsBand ∙ + comm : Commutative ∙ + + open IsBand isBand public + +-- Used to bring names appropriate for a meet semilattice into scope. +IsMeetSemilattice = IsSemilattice +module IsMeetSemilattice {∧} (L : IsMeetSemilattice ∧) where + open IsSemilattice L public + renaming + ( ∙-cong to ∧-cong + ; ∙-congˡ to ∧-congˡ + ; ∙-congʳ to ∧-congʳ + ) + +-- Used to bring names appropriate for a join semilattice into scope. +IsJoinSemilattice = IsSemilattice +module IsJoinSemilattice {∨} (L : IsJoinSemilattice ∨) where + open IsSemilattice L public + renaming + ( ∙-cong to ∨-cong + ; ∙-congˡ to ∨-congˡ + ; ∙-congʳ to ∨-congʳ + ) + +------------------------------------------------------------------------ +-- Structures with 1 binary operation & 1 element + +-- A bounded semi-lattice is the same thing as an idempotent commutative +-- monoid. +IsBoundedSemilattice = IsIdempotentCommutativeMonoid +module IsBoundedSemilattice {∙ ε} (L : IsBoundedSemilattice ∙ ε) where + + open IsIdempotentCommutativeMonoid L public + + isSemilattice : IsSemilattice ∙ + isSemilattice = record + { isBand = isBand + ; comm = comm + } + + +-- Used to bring names appropriate for a bounded meet semilattice +-- into scope. +IsBoundedMeetSemilattice = IsBoundedSemilattice +module IsBoundedMeetSemilattice {∧ ⊤} (L : IsBoundedMeetSemilattice ∧ ⊤) + where + + open IsBoundedSemilattice L public + using (identity; identityˡ; identityʳ) + renaming (isSemilattice to isMeetSemilattice) + + open IsMeetSemilattice isMeetSemilattice public + + +-- Used to bring names appropriate for a bounded join semilattice +-- into scope. +IsBoundedJoinSemilattice = IsBoundedSemilattice +module IsBoundedJoinSemilattice {∨ ⊥} (L : IsBoundedJoinSemilattice ∨ ⊥) + where + + open IsBoundedSemilattice L public + using (identity; identityˡ; identityʳ) + renaming (isSemilattice to isJoinSemilattice) + + open IsJoinSemilattice isJoinSemilattice public + +------------------------------------------------------------------------ +-- Structures with 2 binary operations + +-- Note that `IsLattice` is not defined in terms of `IsMeetSemilattice` +-- and `IsJoinSemilattice` for two reasons: +-- 1) it would result in a structure with two *different* proofs that +-- the equality relation `≈` is an equivalence relation. +-- 2) the idempotence laws of ∨ and ∧ can be derived from the +-- absorption laws, which makes the corresponding "idem" fields +-- redundant. +-- +-- It is possible to construct the `IsLattice` record from +-- `IsMeetSemilattice` and `IsJoinSemilattice` via the `IsLattice₂` +-- record found in `Algebra.Lattice.Structures.Biased`. +-- +-- The derived idempotence laws are stated and proved in +-- `Algebra.Lattice.Properties.Lattice` along with the fact that every +-- lattice consists of two semilattices. - ∧-congˡ : LeftCongruent ∧ - ∧-congˡ y≈z = ∧-cong refl y≈z - - ∧-congʳ : RightCongruent ∧ - ∧-congʳ y≈z = ∧-cong y≈z refl +record IsLattice (∨ ∧ : Op₂ A) : Set (a ⊔ ℓ) where + field + isEquivalence : IsEquivalence _≈_ + ∨-comm : Commutative ∨ + ∨-assoc : Associative ∨ + ∨-cong : Congruent₂ ∨ + ∧-comm : Commutative ∧ + ∧-assoc : Associative ∧ + ∧-cong : Congruent₂ ∧ + absorptive : Absorptive ∨ ∧ - ∨-congˡ : LeftCongruent ∨ - ∨-congˡ y≈z = ∨-cong refl y≈z + open IsEquivalence isEquivalence public + + ∨-absorbs-∧ : ∨ Absorbs ∧ + ∨-absorbs-∧ = proj₁ absorptive - ∨-congʳ : RightCongruent ∨ - ∨-congʳ y≈z = ∨-cong y≈z refl + ∧-absorbs-∨ : ∧ Absorbs ∨ + ∧-absorbs-∨ = proj₂ absorptive + ∧-congˡ : LeftCongruent ∧ + ∧-congˡ y≈z = ∧-cong refl y≈z + + ∧-congʳ : RightCongruent ∧ + ∧-congʳ y≈z = ∧-cong y≈z refl -record IsDistributiveLattice (∨ ∧ : Op₂ A) : Set (a ⊔ ℓ) where - field - isLattice : IsLattice ∨ ∧ - ∨-distrib-∧ : ∨ DistributesOver ∧ - ∧-distrib-∨ : ∧ DistributesOver ∨ + ∨-congˡ : LeftCongruent ∨ + ∨-congˡ y≈z = ∨-cong refl y≈z - open IsLattice isLattice public + ∨-congʳ : RightCongruent ∨ + ∨-congʳ y≈z = ∨-cong y≈z refl - ∨-distribˡ-∧ : ∨ DistributesOverˡ ∧ - ∨-distribˡ-∧ = proj₁ ∨-distrib-∧ - ∨-distribʳ-∧ : ∨ DistributesOverʳ ∧ - ∨-distribʳ-∧ = proj₂ ∨-distrib-∧ +record IsDistributiveLattice (∨ ∧ : Op₂ A) : Set (a ⊔ ℓ) where + field + isLattice : IsLattice ∨ ∧ + ∨-distrib-∧ : ∨ DistributesOver ∧ + ∧-distrib-∨ : ∧ DistributesOver ∨ - ∧-distribˡ-∨ : ∧ DistributesOverˡ ∨ - ∧-distribˡ-∨ = proj₁ ∧-distrib-∨ + open IsLattice isLattice public - ∧-distribʳ-∨ : ∧ DistributesOverʳ ∨ - ∧-distribʳ-∨ = proj₂ ∧-distrib-∨ + ∨-distribˡ-∧ : ∨ DistributesOverˡ ∧ + ∨-distribˡ-∧ = proj₁ ∨-distrib-∧ ------------------------------------------------------------------------- --- Structures with 2 binary ops, 1 unary op and 2 elements. + ∨-distribʳ-∧ : ∨ DistributesOverʳ ∧ + ∨-distribʳ-∧ = proj₂ ∨-distrib-∧ -record IsBooleanAlgebra (∨ ∧ : Op₂ A) (¬ : Op₁ A) (⊤ ⊥ : A) : Set (a ⊔ ℓ) - where + ∧-distribˡ-∨ : ∧ DistributesOverˡ ∨ + ∧-distribˡ-∨ = proj₁ ∧-distrib-∨ - field - isDistributiveLattice : IsDistributiveLattice ∨ ∧ - ∨-complement : Inverse ⊤ ¬ ∨ - ∧-complement : Inverse ⊥ ¬ ∧ - ¬-cong : Congruent₁ ¬ + ∧-distribʳ-∨ : ∧ DistributesOverʳ ∨ + ∧-distribʳ-∨ = proj₂ ∧-distrib-∨ - open IsDistributiveLattice isDistributiveLattice public +------------------------------------------------------------------------ +-- Structures with 2 binary ops, 1 unary op and 2 elements. - ∨-complementˡ : LeftInverse ⊤ ¬ ∨ - ∨-complementˡ = proj₁ ∨-complement +record IsBooleanAlgebra (∨ ∧ : Op₂ A) (¬ : Op₁ A) (⊤ ⊥ : A) : Set (a ⊔ ℓ) + where - ∨-complementʳ : RightInverse ⊤ ¬ ∨ - ∨-complementʳ = proj₂ ∨-complement + field + isDistributiveLattice : IsDistributiveLattice ∨ ∧ + ∨-complement : Inverse ⊤ ¬ ∨ + ∧-complement : Inverse ⊥ ¬ ∧ + ¬-cong : Congruent₁ ¬ - ∧-complementˡ : LeftInverse ⊥ ¬ ∧ - ∧-complementˡ = proj₁ ∧-complement + open IsDistributiveLattice isDistributiveLattice public - ∧-complementʳ : RightInverse ⊥ ¬ ∧ - ∧-complementʳ = proj₂ ∧-complement + ∨-complementˡ : LeftInverse ⊤ ¬ ∨ + ∨-complementˡ = proj₁ ∨-complement + + ∨-complementʳ : RightInverse ⊤ ¬ ∨ + ∨-complementʳ = proj₂ ∨-complement + + ∧-complementˡ : LeftInverse ⊥ ¬ ∧ + ∧-complementˡ = proj₁ ∧-complement + + ∧-complementʳ : RightInverse ⊥ ¬ ∧ + ∧-complementʳ = proj₂ ∧-complement \ No newline at end of file diff --git a/Algebra.Morphism.Definitions.html b/Algebra.Morphism.Definitions.html index 4be376c9..ff04bed5 100644 --- a/Algebra.Morphism.Definitions.html +++ b/Algebra.Morphism.Definitions.html @@ -12,7 +12,7 @@ module Algebra.Morphism.Definitions {a} (A : Set a) -- The domain of the morphism {b} (B : Set b) -- The codomain of the morphism - {ℓ} (_≈_ : Rel B ℓ) -- The equality relation over the codomain + {ℓ} (_≈_ : Rel B ℓ) -- The equality relation over the codomain where open import Algebra.Core diff --git a/Algebra.Morphism.GroupMonomorphism.html b/Algebra.Morphism.GroupMonomorphism.html index 07c4aed8..005f2b6c 100644 --- a/Algebra.Morphism.GroupMonomorphism.html +++ b/Algebra.Morphism.GroupMonomorphism.html @@ -16,10 +16,10 @@ module Algebra.Morphism.GroupMonomorphism {a b ℓ₁ ℓ₂} {G₁ : RawGroup a ℓ₁} {G₂ : RawGroup b ℓ₂} {⟦_⟧} - (isGroupMonomorphism : IsGroupMonomorphism G₁ G₂ ⟦_⟧) + (isGroupMonomorphism : IsGroupMonomorphism G₁ G₂ ⟦_⟧) where -open IsGroupMonomorphism isGroupMonomorphism +open IsGroupMonomorphism isGroupMonomorphism open RawGroup G₁ renaming (Carrier to A; _≈_ to _≈₁_; _∙_ to _∙_; _⁻¹ to _⁻¹₁; ε to ε₁) open RawGroup G₂ renaming @@ -27,73 +27,73 @@ open import Algebra.Definitions open import Algebra.Structures -open import Data.Product -import Relation.Binary.Reasoning.Setoid as SetoidReasoning - ------------------------------------------------------------------------- --- Re-export all properties of monoid monomorphisms - -open import Algebra.Morphism.MonoidMonomorphism - isMonoidMonomorphism public - ------------------------------------------------------------------------- --- Properties - -module _ (◦-isMagma : IsMagma _≈₂_ _◦_) where - - open IsMagma ◦-isMagma renaming (∙-cong to ◦-cong) - open SetoidReasoning setoid - - inverseˡ : LeftInverse _≈₂_ ε₂ _⁻¹₂ _◦_ → LeftInverse _≈₁_ ε₁ _⁻¹₁ _∙_ - inverseˡ invˡ x = injective (begin - ⟦ x ⁻¹₁ ∙ x ⟧ ≈⟨ ∙-homo (x ⁻¹₁ ) x ⟩ - ⟦ x ⁻¹₁ ⟧ ◦ ⟦ x ⟧ ≈⟨ ◦-cong (⁻¹-homo x) refl ⟩ - ⟦ x ⟧ ⁻¹₂ ◦ ⟦ x ⟧ ≈⟨ invˡ ⟦ x ⟧ ⟩ - ε₂ ≈˘⟨ ε-homo ⟩ - ⟦ ε₁ ⟧ ∎) - - inverseʳ : RightInverse _≈₂_ ε₂ _⁻¹₂ _◦_ → RightInverse _≈₁_ ε₁ _⁻¹₁ _∙_ - inverseʳ invʳ x = injective (begin - ⟦ x ∙ x ⁻¹₁ ⟧ ≈⟨ ∙-homo x (x ⁻¹₁) ⟩ - ⟦ x ⟧ ◦ ⟦ x ⁻¹₁ ⟧ ≈⟨ ◦-cong refl (⁻¹-homo x) ⟩ - ⟦ x ⟧ ◦ ⟦ x ⟧ ⁻¹₂ ≈⟨ invʳ ⟦ x ⟧ ⟩ - ε₂ ≈˘⟨ ε-homo ⟩ - ⟦ ε₁ ⟧ ∎) - - inverse : Inverse _≈₂_ ε₂ _⁻¹₂ _◦_ → Inverse _≈₁_ ε₁ _⁻¹₁ _∙_ - inverse (invˡ , invʳ) = inverseˡ invˡ , inverseʳ invʳ - - ⁻¹-cong : Congruent₁ _≈₂_ _⁻¹₂ → Congruent₁ _≈₁_ _⁻¹₁ - ⁻¹-cong ⁻¹-cong {x} {y} x≈y = injective (begin - ⟦ x ⁻¹₁ ⟧ ≈⟨ ⁻¹-homo x ⟩ - ⟦ x ⟧ ⁻¹₂ ≈⟨ ⁻¹-cong (⟦⟧-cong x≈y) ⟩ - ⟦ y ⟧ ⁻¹₂ ≈˘⟨ ⁻¹-homo y ⟩ - ⟦ y ⁻¹₁ ⟧ ∎) - -module _ (◦-isAbelianGroup : IsAbelianGroup _≈₂_ _◦_ ε₂ _⁻¹₂) where - - open IsAbelianGroup ◦-isAbelianGroup renaming (∙-cong to ◦-cong; ⁻¹-cong to ⁻¹₂-cong) - open SetoidReasoning setoid - - ⁻¹-distrib-∙ : (∀ x y → (x ◦ y) ⁻¹₂ ≈₂ (x ⁻¹₂) ◦ (y ⁻¹₂)) → (∀ x y → (x ∙ y) ⁻¹₁ ≈₁ (x ⁻¹₁) ∙ (y ⁻¹₁)) - ⁻¹-distrib-∙ ⁻¹-distrib-∙ x y = injective (begin - ⟦ (x ∙ y) ⁻¹₁ ⟧ ≈⟨ ⁻¹-homo (x ∙ y) ⟩ - ⟦ x ∙ y ⟧ ⁻¹₂ ≈⟨ ⁻¹₂-cong (∙-homo x y) ⟩ - (⟦ x ⟧ ◦ ⟦ y ⟧) ⁻¹₂ ≈⟨ ⁻¹-distrib-∙ ⟦ x ⟧ ⟦ y ⟧ ⟩ - ⟦ x ⟧ ⁻¹₂ ◦ ⟦ y ⟧ ⁻¹₂ ≈⟨ sym (◦-cong (⁻¹-homo x) (⁻¹-homo y)) ⟩ - ⟦ x ⁻¹₁ ⟧ ◦ ⟦ y ⁻¹₁ ⟧ ≈⟨ sym (∙-homo (x ⁻¹₁) (y ⁻¹₁)) ⟩ - ⟦ (x ⁻¹₁) ∙ (y ⁻¹₁) ⟧ ∎) - -isGroup : IsGroup _≈₂_ _◦_ ε₂ _⁻¹₂ → IsGroup _≈₁_ _∙_ ε₁ _⁻¹₁ -isGroup isGroup = record - { isMonoid = isMonoid G.isMonoid - ; inverse = inverse G.isMagma G.inverse - ; ⁻¹-cong = ⁻¹-cong G.isMagma G.⁻¹-cong - } where module G = IsGroup isGroup - -isAbelianGroup : IsAbelianGroup _≈₂_ _◦_ ε₂ _⁻¹₂ → IsAbelianGroup _≈₁_ _∙_ ε₁ _⁻¹₁ -isAbelianGroup isAbelianGroup = record - { isGroup = isGroup G.isGroup - ; comm = comm G.isMagma G.comm - } where module G = IsAbelianGroup isAbelianGroup +open import Data.Product.Base using (_,_) +import Relation.Binary.Reasoning.Setoid as SetoidReasoning + +------------------------------------------------------------------------ +-- Re-export all properties of monoid monomorphisms + +open import Algebra.Morphism.MonoidMonomorphism + isMonoidMonomorphism public + +------------------------------------------------------------------------ +-- Properties + +module _ (◦-isMagma : IsMagma _≈₂_ _◦_) where + + open IsMagma ◦-isMagma renaming (∙-cong to ◦-cong) + open SetoidReasoning setoid + + inverseˡ : LeftInverse _≈₂_ ε₂ _⁻¹₂ _◦_ → LeftInverse _≈₁_ ε₁ _⁻¹₁ _∙_ + inverseˡ invˡ x = injective (begin + ⟦ x ⁻¹₁ ∙ x ⟧ ≈⟨ ∙-homo (x ⁻¹₁ ) x ⟩ + ⟦ x ⁻¹₁ ⟧ ◦ ⟦ x ⟧ ≈⟨ ◦-cong (⁻¹-homo x) refl ⟩ + ⟦ x ⟧ ⁻¹₂ ◦ ⟦ x ⟧ ≈⟨ invˡ ⟦ x ⟧ ⟩ + ε₂ ≈⟨ ε-homo ⟨ + ⟦ ε₁ ⟧ ∎) + + inverseʳ : RightInverse _≈₂_ ε₂ _⁻¹₂ _◦_ → RightInverse _≈₁_ ε₁ _⁻¹₁ _∙_ + inverseʳ invʳ x = injective (begin + ⟦ x ∙ x ⁻¹₁ ⟧ ≈⟨ ∙-homo x (x ⁻¹₁) ⟩ + ⟦ x ⟧ ◦ ⟦ x ⁻¹₁ ⟧ ≈⟨ ◦-cong refl (⁻¹-homo x) ⟩ + ⟦ x ⟧ ◦ ⟦ x ⟧ ⁻¹₂ ≈⟨ invʳ ⟦ x ⟧ ⟩ + ε₂ ≈⟨ ε-homo ⟨ + ⟦ ε₁ ⟧ ∎) + + inverse : Inverse _≈₂_ ε₂ _⁻¹₂ _◦_ → Inverse _≈₁_ ε₁ _⁻¹₁ _∙_ + inverse (invˡ , invʳ) = inverseˡ invˡ , inverseʳ invʳ + + ⁻¹-cong : Congruent₁ _≈₂_ _⁻¹₂ → Congruent₁ _≈₁_ _⁻¹₁ + ⁻¹-cong ⁻¹-cong {x} {y} x≈y = injective (begin + ⟦ x ⁻¹₁ ⟧ ≈⟨ ⁻¹-homo x ⟩ + ⟦ x ⟧ ⁻¹₂ ≈⟨ ⁻¹-cong (⟦⟧-cong x≈y) ⟩ + ⟦ y ⟧ ⁻¹₂ ≈⟨ ⁻¹-homo y ⟨ + ⟦ y ⁻¹₁ ⟧ ∎) + +module _ (◦-isAbelianGroup : IsAbelianGroup _≈₂_ _◦_ ε₂ _⁻¹₂) where + + open IsAbelianGroup ◦-isAbelianGroup renaming (∙-cong to ◦-cong; ⁻¹-cong to ⁻¹₂-cong) + open SetoidReasoning setoid + + ⁻¹-distrib-∙ : (∀ x y → (x ◦ y) ⁻¹₂ ≈₂ (x ⁻¹₂) ◦ (y ⁻¹₂)) → (∀ x y → (x ∙ y) ⁻¹₁ ≈₁ (x ⁻¹₁) ∙ (y ⁻¹₁)) + ⁻¹-distrib-∙ ⁻¹-distrib-∙ x y = injective (begin + ⟦ (x ∙ y) ⁻¹₁ ⟧ ≈⟨ ⁻¹-homo (x ∙ y) ⟩ + ⟦ x ∙ y ⟧ ⁻¹₂ ≈⟨ ⁻¹₂-cong (∙-homo x y) ⟩ + (⟦ x ⟧ ◦ ⟦ y ⟧) ⁻¹₂ ≈⟨ ⁻¹-distrib-∙ ⟦ x ⟧ ⟦ y ⟧ ⟩ + ⟦ x ⟧ ⁻¹₂ ◦ ⟦ y ⟧ ⁻¹₂ ≈⟨ sym (◦-cong (⁻¹-homo x) (⁻¹-homo y)) ⟩ + ⟦ x ⁻¹₁ ⟧ ◦ ⟦ y ⁻¹₁ ⟧ ≈⟨ sym (∙-homo (x ⁻¹₁) (y ⁻¹₁)) ⟩ + ⟦ (x ⁻¹₁) ∙ (y ⁻¹₁) ⟧ ∎) + +isGroup : IsGroup _≈₂_ _◦_ ε₂ _⁻¹₂ → IsGroup _≈₁_ _∙_ ε₁ _⁻¹₁ +isGroup isGroup = record + { isMonoid = isMonoid G.isMonoid + ; inverse = inverse G.isMagma G.inverse + ; ⁻¹-cong = ⁻¹-cong G.isMagma G.⁻¹-cong + } where module G = IsGroup isGroup + +isAbelianGroup : IsAbelianGroup _≈₂_ _◦_ ε₂ _⁻¹₂ → IsAbelianGroup _≈₁_ _∙_ ε₁ _⁻¹₁ +isAbelianGroup isAbelianGroup = record + { isGroup = isGroup G.isGroup + ; comm = comm G.isMagma G.comm + } where module G = IsAbelianGroup isAbelianGroup \ No newline at end of file diff --git a/Algebra.Morphism.MagmaMonomorphism.html b/Algebra.Morphism.MagmaMonomorphism.html index 1f630757..47d79f28 100644 --- a/Algebra.Morphism.MagmaMonomorphism.html +++ b/Algebra.Morphism.MagmaMonomorphism.html @@ -17,109 +17,109 @@ module Algebra.Morphism.MagmaMonomorphism {a b ℓ₁ ℓ₂} {M₁ : RawMagma a ℓ₁} {M₂ : RawMagma b ℓ₂} {⟦_⟧} - (isMagmaMonomorphism : IsMagmaMonomorphism M₁ M₂ ⟦_⟧) + (isMagmaMonomorphism : IsMagmaMonomorphism M₁ M₂ ⟦_⟧) where -open IsMagmaMonomorphism isMagmaMonomorphism +open IsMagmaMonomorphism isMagmaMonomorphism open RawMagma M₁ renaming (Carrier to A; _≈_ to _≈₁_; _∙_ to _∙_) open RawMagma M₂ renaming (Carrier to B; _≈_ to _≈₂_; _∙_ to _◦_) open import Algebra.Structures open import Algebra.Definitions -open import Data.Product -open import Data.Sum.Base using (inj₁; inj₂) -import Relation.Binary.Reasoning.Setoid as SetoidReasoning -import Relation.Binary.Morphism.RelMonomorphism isRelMonomorphism as RelMorphism - ------------------------------------------------------------------------- --- Properties - -module _ (◦-isMagma : IsMagma _≈₂_ _◦_) where - - open IsMagma ◦-isMagma renaming (∙-cong to ◦-cong) - open SetoidReasoning setoid - - cong : Congruent₂ _≈₁_ _∙_ - cong {x} {y} {u} {v} x≈y u≈v = injective (begin - ⟦ x ∙ u ⟧ ≈⟨ homo x u ⟩ - ⟦ x ⟧ ◦ ⟦ u ⟧ ≈⟨ ◦-cong (⟦⟧-cong x≈y) (⟦⟧-cong u≈v) ⟩ - ⟦ y ⟧ ◦ ⟦ v ⟧ ≈˘⟨ homo y v ⟩ - ⟦ y ∙ v ⟧ ∎) - - assoc : Associative _≈₂_ _◦_ → Associative _≈₁_ _∙_ - assoc assoc x y z = injective (begin - ⟦ (x ∙ y) ∙ z ⟧ ≈⟨ homo (x ∙ y) z ⟩ - ⟦ x ∙ y ⟧ ◦ ⟦ z ⟧ ≈⟨ ◦-cong (homo x y) refl ⟩ - (⟦ x ⟧ ◦ ⟦ y ⟧) ◦ ⟦ z ⟧ ≈⟨ assoc ⟦ x ⟧ ⟦ y ⟧ ⟦ z ⟧ ⟩ - ⟦ x ⟧ ◦ (⟦ y ⟧ ◦ ⟦ z ⟧) ≈˘⟨ ◦-cong refl (homo y z) ⟩ - ⟦ x ⟧ ◦ ⟦ y ∙ z ⟧ ≈˘⟨ homo x (y ∙ z) ⟩ - ⟦ x ∙ (y ∙ z) ⟧ ∎) - - comm : Commutative _≈₂_ _◦_ → Commutative _≈₁_ _∙_ - comm comm x y = injective (begin - ⟦ x ∙ y ⟧ ≈⟨ homo x y ⟩ - ⟦ x ⟧ ◦ ⟦ y ⟧ ≈⟨ comm ⟦ x ⟧ ⟦ y ⟧ ⟩ - ⟦ y ⟧ ◦ ⟦ x ⟧ ≈˘⟨ homo y x ⟩ - ⟦ y ∙ x ⟧ ∎) - - idem : Idempotent _≈₂_ _◦_ → Idempotent _≈₁_ _∙_ - idem idem x = injective (begin - ⟦ x ∙ x ⟧ ≈⟨ homo x x ⟩ - ⟦ x ⟧ ◦ ⟦ x ⟧ ≈⟨ idem ⟦ x ⟧ ⟩ - ⟦ x ⟧ ∎) - - sel : Selective _≈₂_ _◦_ → Selective _≈₁_ _∙_ - sel sel x y with sel ⟦ x ⟧ ⟦ y ⟧ - ... | inj₁ x◦y≈x = inj₁ (injective (begin - ⟦ x ∙ y ⟧ ≈⟨ homo x y ⟩ - ⟦ x ⟧ ◦ ⟦ y ⟧ ≈⟨ x◦y≈x ⟩ - ⟦ x ⟧ ∎)) - ... | inj₂ x◦y≈y = inj₂ (injective (begin - ⟦ x ∙ y ⟧ ≈⟨ homo x y ⟩ - ⟦ x ⟧ ◦ ⟦ y ⟧ ≈⟨ x◦y≈y ⟩ - ⟦ y ⟧ ∎)) - - cancelˡ : LeftCancellative _≈₂_ _◦_ → LeftCancellative _≈₁_ _∙_ - cancelˡ cancelˡ x y z x∙y≈x∙z = injective (cancelˡ ⟦ x ⟧ ⟦ y ⟧ ⟦ z ⟧ (begin - ⟦ x ⟧ ◦ ⟦ y ⟧ ≈˘⟨ homo x y ⟩ - ⟦ x ∙ y ⟧ ≈⟨ ⟦⟧-cong x∙y≈x∙z ⟩ - ⟦ x ∙ z ⟧ ≈⟨ homo x z ⟩ - ⟦ x ⟧ ◦ ⟦ z ⟧ ∎)) - - cancelʳ : RightCancellative _≈₂_ _◦_ → RightCancellative _≈₁_ _∙_ - cancelʳ cancelʳ x y z y∙x≈z∙x = injective (cancelʳ ⟦ x ⟧ ⟦ y ⟧ ⟦ z ⟧ (begin - ⟦ y ⟧ ◦ ⟦ x ⟧ ≈˘⟨ homo y x ⟩ - ⟦ y ∙ x ⟧ ≈⟨ ⟦⟧-cong y∙x≈z∙x ⟩ - ⟦ z ∙ x ⟧ ≈⟨ homo z x ⟩ - ⟦ z ⟧ ◦ ⟦ x ⟧ ∎)) - - cancel : Cancellative _≈₂_ _◦_ → Cancellative _≈₁_ _∙_ - cancel = map cancelˡ cancelʳ - ------------------------------------------------------------------------- --- Structures - -isMagma : IsMagma _≈₂_ _◦_ → IsMagma _≈₁_ _∙_ -isMagma isMagma = record - { isEquivalence = RelMorphism.isEquivalence M.isEquivalence - ; ∙-cong = cong isMagma - } where module M = IsMagma isMagma - -isSemigroup : IsSemigroup _≈₂_ _◦_ → IsSemigroup _≈₁_ _∙_ -isSemigroup isSemigroup = record - { isMagma = isMagma S.isMagma - ; assoc = assoc S.isMagma S.assoc - } where module S = IsSemigroup isSemigroup - -isBand : IsBand _≈₂_ _◦_ → IsBand _≈₁_ _∙_ -isBand isBand = record - { isSemigroup = isSemigroup B.isSemigroup - ; idem = idem B.isMagma B.idem - } where module B = IsBand isBand - -isSelectiveMagma : IsSelectiveMagma _≈₂_ _◦_ → IsSelectiveMagma _≈₁_ _∙_ -isSelectiveMagma isSelMagma = record - { isMagma = isMagma S.isMagma - ; sel = sel S.isMagma S.sel - } where module S = IsSelectiveMagma isSelMagma +open import Data.Product.Base using (map) +open import Data.Sum.Base using (inj₁; inj₂) +import Relation.Binary.Reasoning.Setoid as SetoidReasoning +import Relation.Binary.Morphism.RelMonomorphism isRelMonomorphism as RelMorphism + +------------------------------------------------------------------------ +-- Properties + +module _ (◦-isMagma : IsMagma _≈₂_ _◦_) where + + open IsMagma ◦-isMagma renaming (∙-cong to ◦-cong) + open SetoidReasoning setoid + + cong : Congruent₂ _≈₁_ _∙_ + cong {x} {y} {u} {v} x≈y u≈v = injective (begin + ⟦ x ∙ u ⟧ ≈⟨ homo x u ⟩ + ⟦ x ⟧ ◦ ⟦ u ⟧ ≈⟨ ◦-cong (⟦⟧-cong x≈y) (⟦⟧-cong u≈v) ⟩ + ⟦ y ⟧ ◦ ⟦ v ⟧ ≈⟨ homo y v ⟨ + ⟦ y ∙ v ⟧ ∎) + + assoc : Associative _≈₂_ _◦_ → Associative _≈₁_ _∙_ + assoc assoc x y z = injective (begin + ⟦ (x ∙ y) ∙ z ⟧ ≈⟨ homo (x ∙ y) z ⟩ + ⟦ x ∙ y ⟧ ◦ ⟦ z ⟧ ≈⟨ ◦-cong (homo x y) refl ⟩ + (⟦ x ⟧ ◦ ⟦ y ⟧) ◦ ⟦ z ⟧ ≈⟨ assoc ⟦ x ⟧ ⟦ y ⟧ ⟦ z ⟧ ⟩ + ⟦ x ⟧ ◦ (⟦ y ⟧ ◦ ⟦ z ⟧) ≈⟨ ◦-cong refl (homo y z) ⟨ + ⟦ x ⟧ ◦ ⟦ y ∙ z ⟧ ≈⟨ homo x (y ∙ z) ⟨ + ⟦ x ∙ (y ∙ z) ⟧ ∎) + + comm : Commutative _≈₂_ _◦_ → Commutative _≈₁_ _∙_ + comm comm x y = injective (begin + ⟦ x ∙ y ⟧ ≈⟨ homo x y ⟩ + ⟦ x ⟧ ◦ ⟦ y ⟧ ≈⟨ comm ⟦ x ⟧ ⟦ y ⟧ ⟩ + ⟦ y ⟧ ◦ ⟦ x ⟧ ≈⟨ homo y x ⟨ + ⟦ y ∙ x ⟧ ∎) + + idem : Idempotent _≈₂_ _◦_ → Idempotent _≈₁_ _∙_ + idem idem x = injective (begin + ⟦ x ∙ x ⟧ ≈⟨ homo x x ⟩ + ⟦ x ⟧ ◦ ⟦ x ⟧ ≈⟨ idem ⟦ x ⟧ ⟩ + ⟦ x ⟧ ∎) + + sel : Selective _≈₂_ _◦_ → Selective _≈₁_ _∙_ + sel sel x y with sel ⟦ x ⟧ ⟦ y ⟧ + ... | inj₁ x◦y≈x = inj₁ (injective (begin + ⟦ x ∙ y ⟧ ≈⟨ homo x y ⟩ + ⟦ x ⟧ ◦ ⟦ y ⟧ ≈⟨ x◦y≈x ⟩ + ⟦ x ⟧ ∎)) + ... | inj₂ x◦y≈y = inj₂ (injective (begin + ⟦ x ∙ y ⟧ ≈⟨ homo x y ⟩ + ⟦ x ⟧ ◦ ⟦ y ⟧ ≈⟨ x◦y≈y ⟩ + ⟦ y ⟧ ∎)) + + cancelˡ : LeftCancellative _≈₂_ _◦_ → LeftCancellative _≈₁_ _∙_ + cancelˡ cancelˡ x y z x∙y≈x∙z = injective (cancelˡ ⟦ x ⟧ ⟦ y ⟧ ⟦ z ⟧ (begin + ⟦ x ⟧ ◦ ⟦ y ⟧ ≈⟨ homo x y ⟨ + ⟦ x ∙ y ⟧ ≈⟨ ⟦⟧-cong x∙y≈x∙z ⟩ + ⟦ x ∙ z ⟧ ≈⟨ homo x z ⟩ + ⟦ x ⟧ ◦ ⟦ z ⟧ ∎)) + + cancelʳ : RightCancellative _≈₂_ _◦_ → RightCancellative _≈₁_ _∙_ + cancelʳ cancelʳ x y z y∙x≈z∙x = injective (cancelʳ ⟦ x ⟧ ⟦ y ⟧ ⟦ z ⟧ (begin + ⟦ y ⟧ ◦ ⟦ x ⟧ ≈⟨ homo y x ⟨ + ⟦ y ∙ x ⟧ ≈⟨ ⟦⟧-cong y∙x≈z∙x ⟩ + ⟦ z ∙ x ⟧ ≈⟨ homo z x ⟩ + ⟦ z ⟧ ◦ ⟦ x ⟧ ∎)) + + cancel : Cancellative _≈₂_ _◦_ → Cancellative _≈₁_ _∙_ + cancel = map cancelˡ cancelʳ + +------------------------------------------------------------------------ +-- Structures + +isMagma : IsMagma _≈₂_ _◦_ → IsMagma _≈₁_ _∙_ +isMagma isMagma = record + { isEquivalence = RelMorphism.isEquivalence M.isEquivalence + ; ∙-cong = cong isMagma + } where module M = IsMagma isMagma + +isSemigroup : IsSemigroup _≈₂_ _◦_ → IsSemigroup _≈₁_ _∙_ +isSemigroup isSemigroup = record + { isMagma = isMagma S.isMagma + ; assoc = assoc S.isMagma S.assoc + } where module S = IsSemigroup isSemigroup + +isBand : IsBand _≈₂_ _◦_ → IsBand _≈₁_ _∙_ +isBand isBand = record + { isSemigroup = isSemigroup B.isSemigroup + ; idem = idem B.isMagma B.idem + } where module B = IsBand isBand + +isSelectiveMagma : IsSelectiveMagma _≈₂_ _◦_ → IsSelectiveMagma _≈₁_ _∙_ +isSelectiveMagma isSelMagma = record + { isMagma = isMagma S.isMagma + ; sel = sel S.isMagma S.sel + } where module S = IsSelectiveMagma isSelMagma \ No newline at end of file diff --git a/Algebra.Morphism.MonoidMonomorphism.html b/Algebra.Morphism.MonoidMonomorphism.html index 1caedb63..b4a7d1b5 100644 --- a/Algebra.Morphism.MonoidMonomorphism.html +++ b/Algebra.Morphism.MonoidMonomorphism.html @@ -16,81 +16,81 @@ module Algebra.Morphism.MonoidMonomorphism {a b ℓ₁ ℓ₂} {M₁ : RawMonoid a ℓ₁} {M₂ : RawMonoid b ℓ₂} {⟦_⟧} - (isMonoidMonomorphism : IsMonoidMonomorphism M₁ M₂ ⟦_⟧) + (isMonoidMonomorphism : IsMonoidMonomorphism M₁ M₂ ⟦_⟧) where -open IsMonoidMonomorphism isMonoidMonomorphism +open IsMonoidMonomorphism isMonoidMonomorphism open RawMonoid M₁ renaming (Carrier to A; _≈_ to _≈₁_; _∙_ to _∙_; ε to ε₁) open RawMonoid M₂ renaming (Carrier to B; _≈_ to _≈₂_; _∙_ to _◦_; ε to ε₂) open import Algebra.Definitions open import Algebra.Structures -open import Data.Product using (map) -import Relation.Binary.Reasoning.Setoid as SetoidReasoning - ------------------------------------------------------------------------- --- Re-export all properties of magma monomorphisms - -open import Algebra.Morphism.MagmaMonomorphism - isMagmaMonomorphism public - ------------------------------------------------------------------------- --- Properties - -module _ (◦-isMagma : IsMagma _≈₂_ _◦_) where - - open IsMagma ◦-isMagma renaming (∙-cong to ◦-cong) - open SetoidReasoning setoid - - identityˡ : LeftIdentity _≈₂_ ε₂ _◦_ → LeftIdentity _≈₁_ ε₁ _∙_ - identityˡ idˡ x = injective (begin - ⟦ ε₁ ∙ x ⟧ ≈⟨ homo ε₁ x ⟩ - ⟦ ε₁ ⟧ ◦ ⟦ x ⟧ ≈⟨ ◦-cong ε-homo refl ⟩ - ε₂ ◦ ⟦ x ⟧ ≈⟨ idˡ ⟦ x ⟧ ⟩ - ⟦ x ⟧ ∎) - - identityʳ : RightIdentity _≈₂_ ε₂ _◦_ → RightIdentity _≈₁_ ε₁ _∙_ - identityʳ idʳ x = injective (begin - ⟦ x ∙ ε₁ ⟧ ≈⟨ homo x ε₁ ⟩ - ⟦ x ⟧ ◦ ⟦ ε₁ ⟧ ≈⟨ ◦-cong refl ε-homo ⟩ - ⟦ x ⟧ ◦ ε₂ ≈⟨ idʳ ⟦ x ⟧ ⟩ - ⟦ x ⟧ ∎) - - identity : Identity _≈₂_ ε₂ _◦_ → Identity _≈₁_ ε₁ _∙_ - identity = map identityˡ identityʳ - - zeroˡ : LeftZero _≈₂_ ε₂ _◦_ → LeftZero _≈₁_ ε₁ _∙_ - zeroˡ zeˡ x = injective (begin - ⟦ ε₁ ∙ x ⟧ ≈⟨ homo ε₁ x ⟩ - ⟦ ε₁ ⟧ ◦ ⟦ x ⟧ ≈⟨ ◦-cong ε-homo refl ⟩ - ε₂ ◦ ⟦ x ⟧ ≈⟨ zeˡ ⟦ x ⟧ ⟩ - ε₂ ≈˘⟨ ε-homo ⟩ - ⟦ ε₁ ⟧ ∎) - - zeroʳ : RightZero _≈₂_ ε₂ _◦_ → RightZero _≈₁_ ε₁ _∙_ - zeroʳ zeʳ x = injective (begin - ⟦ x ∙ ε₁ ⟧ ≈⟨ homo x ε₁ ⟩ - ⟦ x ⟧ ◦ ⟦ ε₁ ⟧ ≈⟨ ◦-cong refl ε-homo ⟩ - ⟦ x ⟧ ◦ ε₂ ≈⟨ zeʳ ⟦ x ⟧ ⟩ - ε₂ ≈˘⟨ ε-homo ⟩ - ⟦ ε₁ ⟧ ∎) - - zero : Zero _≈₂_ ε₂ _◦_ → Zero _≈₁_ ε₁ _∙_ - zero = map zeroˡ zeroʳ - ------------------------------------------------------------------------- --- Structures - -isMonoid : IsMonoid _≈₂_ _◦_ ε₂ → IsMonoid _≈₁_ _∙_ ε₁ -isMonoid isMonoid = record - { isSemigroup = isSemigroup M.isSemigroup - ; identity = identity M.isMagma M.identity - } where module M = IsMonoid isMonoid - -isCommutativeMonoid : IsCommutativeMonoid _≈₂_ _◦_ ε₂ → - IsCommutativeMonoid _≈₁_ _∙_ ε₁ -isCommutativeMonoid isCommMonoid = record - { isMonoid = isMonoid C.isMonoid - ; comm = comm C.isMagma C.comm - } where module C = IsCommutativeMonoid isCommMonoid +open import Data.Product.Base using (map) +import Relation.Binary.Reasoning.Setoid as SetoidReasoning + +------------------------------------------------------------------------ +-- Re-export all properties of magma monomorphisms + +open import Algebra.Morphism.MagmaMonomorphism + isMagmaMonomorphism public + +------------------------------------------------------------------------ +-- Properties + +module _ (◦-isMagma : IsMagma _≈₂_ _◦_) where + + open IsMagma ◦-isMagma renaming (∙-cong to ◦-cong) + open SetoidReasoning setoid + + identityˡ : LeftIdentity _≈₂_ ε₂ _◦_ → LeftIdentity _≈₁_ ε₁ _∙_ + identityˡ idˡ x = injective (begin + ⟦ ε₁ ∙ x ⟧ ≈⟨ homo ε₁ x ⟩ + ⟦ ε₁ ⟧ ◦ ⟦ x ⟧ ≈⟨ ◦-cong ε-homo refl ⟩ + ε₂ ◦ ⟦ x ⟧ ≈⟨ idˡ ⟦ x ⟧ ⟩ + ⟦ x ⟧ ∎) + + identityʳ : RightIdentity _≈₂_ ε₂ _◦_ → RightIdentity _≈₁_ ε₁ _∙_ + identityʳ idʳ x = injective (begin + ⟦ x ∙ ε₁ ⟧ ≈⟨ homo x ε₁ ⟩ + ⟦ x ⟧ ◦ ⟦ ε₁ ⟧ ≈⟨ ◦-cong refl ε-homo ⟩ + ⟦ x ⟧ ◦ ε₂ ≈⟨ idʳ ⟦ x ⟧ ⟩ + ⟦ x ⟧ ∎) + + identity : Identity _≈₂_ ε₂ _◦_ → Identity _≈₁_ ε₁ _∙_ + identity = map identityˡ identityʳ + + zeroˡ : LeftZero _≈₂_ ε₂ _◦_ → LeftZero _≈₁_ ε₁ _∙_ + zeroˡ zeˡ x = injective (begin + ⟦ ε₁ ∙ x ⟧ ≈⟨ homo ε₁ x ⟩ + ⟦ ε₁ ⟧ ◦ ⟦ x ⟧ ≈⟨ ◦-cong ε-homo refl ⟩ + ε₂ ◦ ⟦ x ⟧ ≈⟨ zeˡ ⟦ x ⟧ ⟩ + ε₂ ≈⟨ ε-homo ⟨ + ⟦ ε₁ ⟧ ∎) + + zeroʳ : RightZero _≈₂_ ε₂ _◦_ → RightZero _≈₁_ ε₁ _∙_ + zeroʳ zeʳ x = injective (begin + ⟦ x ∙ ε₁ ⟧ ≈⟨ homo x ε₁ ⟩ + ⟦ x ⟧ ◦ ⟦ ε₁ ⟧ ≈⟨ ◦-cong refl ε-homo ⟩ + ⟦ x ⟧ ◦ ε₂ ≈⟨ zeʳ ⟦ x ⟧ ⟩ + ε₂ ≈⟨ ε-homo ⟨ + ⟦ ε₁ ⟧ ∎) + + zero : Zero _≈₂_ ε₂ _◦_ → Zero _≈₁_ ε₁ _∙_ + zero = map zeroˡ zeroʳ + +------------------------------------------------------------------------ +-- Structures + +isMonoid : IsMonoid _≈₂_ _◦_ ε₂ → IsMonoid _≈₁_ _∙_ ε₁ +isMonoid isMonoid = record + { isSemigroup = isSemigroup M.isSemigroup + ; identity = identity M.isMagma M.identity + } where module M = IsMonoid isMonoid + +isCommutativeMonoid : IsCommutativeMonoid _≈₂_ _◦_ ε₂ → + IsCommutativeMonoid _≈₁_ _∙_ ε₁ +isCommutativeMonoid isCommMonoid = record + { isMonoid = isMonoid C.isMonoid + ; comm = comm C.isMagma C.comm + } where module C = IsCommutativeMonoid isCommMonoid \ No newline at end of file diff --git a/Algebra.Morphism.RingMonomorphism.html b/Algebra.Morphism.RingMonomorphism.html index d9ffa965..6d333616 100644 --- a/Algebra.Morphism.RingMonomorphism.html +++ b/Algebra.Morphism.RingMonomorphism.html @@ -17,147 +17,146 @@ open import Relation.Binary.Core module Algebra.Morphism.RingMonomorphism - {a b ℓ₁ ℓ₂} {R₁ : RawRing a ℓ₁} {R₂ : RawRing b ℓ₂} {⟦_⟧} - (isRingMonomorphism : IsRingMonomorphism R₁ R₂ ⟦_⟧) + {a b ℓ₁ ℓ₂} {R₁ : RawRing a ℓ₁} {R₂ : RawRing b ℓ₂} {⟦_⟧} + (isRingMonomorphism : IsRingMonomorphism R₁ R₂ ⟦_⟧) where -open IsRingMonomorphism isRingMonomorphism -open RawRing R₁ renaming (Carrier to A; _≈_ to _≈₁_) -open RawRing R₂ renaming - ( Carrier to B; _≈_ to _≈₂_; _+_ to _⊕_ - ; _*_ to _⊛_; 1# to 1#₂; 0# to 0#₂; -_ to ⊝_) +open IsRingMonomorphism isRingMonomorphism +open RawRing R₁ renaming (Carrier to A; _≈_ to _≈₁_) +open RawRing R₂ renaming + ( Carrier to B; _≈_ to _≈₂_; _+_ to _⊕_ + ; _*_ to _⊛_; 1# to 1#₂; 0# to 0#₂; -_ to ⊝_) open import Algebra.Definitions open import Algebra.Structures -open import Data.Product -import Relation.Binary.Reasoning.Setoid as SetoidReasoning - ------------------------------------------------------------------------- --- Re-export all properties of group and monoid monomorphisms - -open GroupMonomorphism +-isGroupMonomorphism public - renaming - ( assoc to +-assoc - ; comm to +-comm - ; cong to +-cong - ; idem to +-idem - ; sel to +-sel - ; ⁻¹-cong to neg-cong - - ; identity to +-identity; identityˡ to +-identityˡ; identityʳ to +-identityʳ - ; cancel to +-cancel; cancelˡ to +-cancelˡ; cancelʳ to +-cancelʳ - ; zero to +-zero; zeroˡ to +-zeroˡ; zeroʳ to +-zeroʳ - - ; isMagma to +-isMagma - ; isSemigroup to +-isSemigroup - ; isMonoid to +-isMonoid - ; isSelectiveMagma to +-isSelectiveMagma - ; isBand to +-isBand - ; isCommutativeMonoid to +-isCommutativeMonoid - ) - -open MonoidMonomorphism *-isMonoidMonomorphism public - renaming - ( assoc to *-assoc - ; comm to *-comm - ; cong to *-cong - ; idem to *-idem - ; sel to *-sel - - ; identity to *-identity; identityˡ to *-identityˡ; identityʳ to *-identityʳ - ; cancel to *-cancel; cancelˡ to *-cancelˡ; cancelʳ to *-cancelʳ - ; zero to *-zero; zeroˡ to *-zeroˡ; zeroʳ to *-zeroʳ - - ; isMagma to *-isMagma - ; isSemigroup to *-isSemigroup - ; isMonoid to *-isMonoid - ; isSelectiveMagma to *-isSelectiveMagma - ; isBand to *-isBand - ; isCommutativeMonoid to *-isCommutativeMonoid - ) - ------------------------------------------------------------------------- --- Properties - -module _ (+-isGroup : IsGroup _≈₂_ _⊕_ 0#₂ ⊝_) - (*-isMagma : IsMagma _≈₂_ _⊛_) where - - open IsGroup +-isGroup hiding (setoid; refl; sym) - open IsMagma *-isMagma renaming (∙-cong to ◦-cong) - open SetoidReasoning setoid - - distribˡ : _DistributesOverˡ_ _≈₂_ _⊛_ _⊕_ → _DistributesOverˡ_ _≈₁_ _*_ _+_ - distribˡ distribˡ x y z = injective (begin - ⟦ x * (y + z) ⟧ ≈⟨ *-homo x (y + z) ⟩ - ⟦ x ⟧ ⊛ ⟦ y + z ⟧ ≈⟨ ◦-cong refl (+-homo y z) ⟩ - ⟦ x ⟧ ⊛ (⟦ y ⟧ ⊕ ⟦ z ⟧) ≈⟨ distribˡ ⟦ x ⟧ ⟦ y ⟧ ⟦ z ⟧ ⟩ - ⟦ x ⟧ ⊛ ⟦ y ⟧ ⊕ ⟦ x ⟧ ⊛ ⟦ z ⟧ ≈˘⟨ ∙-cong (*-homo x y) (*-homo x z) ⟩ - ⟦ x * y ⟧ ⊕ ⟦ x * z ⟧ ≈˘⟨ +-homo (x * y) (x * z) ⟩ - ⟦ x * y + x * z ⟧ ∎) - - distribʳ : _DistributesOverʳ_ _≈₂_ _⊛_ _⊕_ → _DistributesOverʳ_ _≈₁_ _*_ _+_ - distribʳ distribˡ x y z = injective (begin - ⟦ (y + z) * x ⟧ ≈⟨ *-homo (y + z) x ⟩ - ⟦ y + z ⟧ ⊛ ⟦ x ⟧ ≈⟨ ◦-cong (+-homo y z) refl ⟩ - (⟦ y ⟧ ⊕ ⟦ z ⟧) ⊛ ⟦ x ⟧ ≈⟨ distribˡ ⟦ x ⟧ ⟦ y ⟧ ⟦ z ⟧ ⟩ - ⟦ y ⟧ ⊛ ⟦ x ⟧ ⊕ ⟦ z ⟧ ⊛ ⟦ x ⟧ ≈˘⟨ ∙-cong (*-homo y x) (*-homo z x) ⟩ - ⟦ y * x ⟧ ⊕ ⟦ z * x ⟧ ≈˘⟨ +-homo (y * x) (z * x) ⟩ - ⟦ y * x + z * x ⟧ ∎) - - distrib : _DistributesOver_ _≈₂_ _⊛_ _⊕_ → _DistributesOver_ _≈₁_ _*_ _+_ - distrib distrib = distribˡ (proj₁ distrib) , distribʳ (proj₂ distrib) - - zeroˡ : LeftZero _≈₂_ 0#₂ _⊛_ → LeftZero _≈₁_ 0# _*_ - zeroˡ zeroˡ x = injective (begin - ⟦ 0# * x ⟧ ≈⟨ *-homo 0# x ⟩ - ⟦ 0# ⟧ ⊛ ⟦ x ⟧ ≈⟨ ◦-cong 0#-homo refl ⟩ - 0#₂ ⊛ ⟦ x ⟧ ≈⟨ zeroˡ ⟦ x ⟧ ⟩ - 0#₂ ≈˘⟨ 0#-homo ⟩ - ⟦ 0# ⟧ ∎) - - zeroʳ : RightZero _≈₂_ 0#₂ _⊛_ → RightZero _≈₁_ 0# _*_ - zeroʳ zeroʳ x = injective (begin - ⟦ x * 0# ⟧ ≈⟨ *-homo x 0# ⟩ - ⟦ x ⟧ ⊛ ⟦ 0# ⟧ ≈⟨ ◦-cong refl 0#-homo ⟩ - ⟦ x ⟧ ⊛ 0#₂ ≈⟨ zeroʳ ⟦ x ⟧ ⟩ - 0#₂ ≈˘⟨ 0#-homo ⟩ - ⟦ 0# ⟧ ∎) - - zero : Zero _≈₂_ 0#₂ _⊛_ → Zero _≈₁_ 0# _*_ - zero zero = zeroˡ (proj₁ zero) , zeroʳ (proj₂ zero) - - neg-distribˡ-* : (∀ x y → (⊝ (x ⊛ y)) ≈₂ ((⊝ x) ⊛ y)) → (∀ x y → (- (x * y)) ≈₁ ((- x) * y)) - neg-distribˡ-* neg-distribˡ-* x y = injective (begin - ⟦ - (x * y) ⟧ ≈⟨ -‿homo (x * y) ⟩ - ⊝ ⟦ x * y ⟧ ≈⟨ ⁻¹-cong (*-homo x y) ⟩ - ⊝ (⟦ x ⟧ ⊛ ⟦ y ⟧) ≈⟨ neg-distribˡ-* ⟦ x ⟧ ⟦ y ⟧ ⟩ - ⊝ ⟦ x ⟧ ⊛ ⟦ y ⟧ ≈⟨ ◦-cong (sym (-‿homo x)) refl ⟩ - ⟦ - x ⟧ ⊛ ⟦ y ⟧ ≈⟨ sym (*-homo (- x) y) ⟩ - ⟦ - x * y ⟧ ∎) - - neg-distribʳ-* : (∀ x y → (⊝ (x ⊛ y)) ≈₂ (x ⊛ (⊝ y))) → (∀ x y → (- (x * y)) ≈₁ (x * (- y))) - neg-distribʳ-* neg-distribʳ-* x y = injective (begin - ⟦ - (x * y) ⟧ ≈⟨ -‿homo (x * y) ⟩ - ⊝ ⟦ x * y ⟧ ≈⟨ ⁻¹-cong (*-homo x y) ⟩ - ⊝ (⟦ x ⟧ ⊛ ⟦ y ⟧) ≈⟨ neg-distribʳ-* ⟦ x ⟧ ⟦ y ⟧ ⟩ - ⟦ x ⟧ ⊛ ⊝ ⟦ y ⟧ ≈⟨ ◦-cong refl (sym (-‿homo y)) ⟩ - ⟦ x ⟧ ⊛ ⟦ - y ⟧ ≈⟨ sym (*-homo x (- y)) ⟩ - ⟦ x * - y ⟧ ∎) - -isRing : IsRing _≈₂_ _⊕_ _⊛_ ⊝_ 0#₂ 1#₂ → IsRing _≈₁_ _+_ _*_ -_ 0# 1# -isRing isRing = record - { +-isAbelianGroup = isAbelianGroup R.+-isAbelianGroup - ; *-cong = *-cong R.*-isMagma - ; *-assoc = *-assoc R.*-isMagma R.*-assoc - ; *-identity = *-identity R.*-isMagma R.*-identity - ; distrib = distrib R.+-isGroup R.*-isMagma R.distrib - ; zero = zero R.+-isGroup R.*-isMagma R.zero - } where module R = IsRing isRing - -isCommutativeRing : IsCommutativeRing _≈₂_ _⊕_ _⊛_ ⊝_ 0#₂ 1#₂ → - IsCommutativeRing _≈₁_ _+_ _*_ -_ 0# 1# -isCommutativeRing isCommRing = record - { isRing = isRing C.isRing - ; *-comm = *-comm C.*-isMagma C.*-comm - } where module C = IsCommutativeRing isCommRing +open import Data.Product.Base using (proj₁; proj₂; _,_) +import Relation.Binary.Reasoning.Setoid as SetoidReasoning + +------------------------------------------------------------------------ +-- Re-export all properties of group and monoid monomorphisms + +open GroupMonomorphism +-isGroupMonomorphism public + renaming + ( assoc to +-assoc + ; comm to +-comm + ; cong to +-cong + ; idem to +-idem + ; sel to +-sel + ; ⁻¹-cong to neg-cong + + ; identity to +-identity; identityˡ to +-identityˡ; identityʳ to +-identityʳ + ; cancel to +-cancel; cancelˡ to +-cancelˡ; cancelʳ to +-cancelʳ + ; zero to +-zero; zeroˡ to +-zeroˡ; zeroʳ to +-zeroʳ + + ; isMagma to +-isMagma + ; isSemigroup to +-isSemigroup + ; isMonoid to +-isMonoid + ; isSelectiveMagma to +-isSelectiveMagma + ; isBand to +-isBand + ; isCommutativeMonoid to +-isCommutativeMonoid + ) + +open MonoidMonomorphism *-isMonoidMonomorphism public + renaming + ( assoc to *-assoc + ; comm to *-comm + ; cong to *-cong + ; idem to *-idem + ; sel to *-sel + + ; identity to *-identity; identityˡ to *-identityˡ; identityʳ to *-identityʳ + ; cancel to *-cancel; cancelˡ to *-cancelˡ; cancelʳ to *-cancelʳ + ; zero to *-zero; zeroˡ to *-zeroˡ; zeroʳ to *-zeroʳ + + ; isMagma to *-isMagma + ; isSemigroup to *-isSemigroup + ; isMonoid to *-isMonoid + ; isSelectiveMagma to *-isSelectiveMagma + ; isBand to *-isBand + ; isCommutativeMonoid to *-isCommutativeMonoid + ) + +------------------------------------------------------------------------ +-- Properties + +module _ (+-isGroup : IsGroup _≈₂_ _⊕_ 0#₂ ⊝_) + (*-isMagma : IsMagma _≈₂_ _⊛_) where + + open IsGroup +-isGroup hiding (setoid; refl; sym) + open IsMagma *-isMagma renaming (∙-cong to ◦-cong) + open SetoidReasoning setoid + + distribˡ : _DistributesOverˡ_ _≈₂_ _⊛_ _⊕_ → _DistributesOverˡ_ _≈₁_ _*_ _+_ + distribˡ distribˡ x y z = injective (begin + ⟦ x * (y + z) ⟧ ≈⟨ *-homo x (y + z) ⟩ + ⟦ x ⟧ ⊛ ⟦ y + z ⟧ ≈⟨ ◦-cong refl (+-homo y z) ⟩ + ⟦ x ⟧ ⊛ (⟦ y ⟧ ⊕ ⟦ z ⟧) ≈⟨ distribˡ ⟦ x ⟧ ⟦ y ⟧ ⟦ z ⟧ ⟩ + ⟦ x ⟧ ⊛ ⟦ y ⟧ ⊕ ⟦ x ⟧ ⊛ ⟦ z ⟧ ≈⟨ ∙-cong (*-homo x y) (*-homo x z) ⟨ + ⟦ x * y ⟧ ⊕ ⟦ x * z ⟧ ≈⟨ +-homo (x * y) (x * z) ⟨ + ⟦ x * y + x * z ⟧ ∎) + + distribʳ : _DistributesOverʳ_ _≈₂_ _⊛_ _⊕_ → _DistributesOverʳ_ _≈₁_ _*_ _+_ + distribʳ distribˡ x y z = injective (begin + ⟦ (y + z) * x ⟧ ≈⟨ *-homo (y + z) x ⟩ + ⟦ y + z ⟧ ⊛ ⟦ x ⟧ ≈⟨ ◦-cong (+-homo y z) refl ⟩ + (⟦ y ⟧ ⊕ ⟦ z ⟧) ⊛ ⟦ x ⟧ ≈⟨ distribˡ ⟦ x ⟧ ⟦ y ⟧ ⟦ z ⟧ ⟩ + ⟦ y ⟧ ⊛ ⟦ x ⟧ ⊕ ⟦ z ⟧ ⊛ ⟦ x ⟧ ≈⟨ ∙-cong (*-homo y x) (*-homo z x) ⟨ + ⟦ y * x ⟧ ⊕ ⟦ z * x ⟧ ≈⟨ +-homo (y * x) (z * x) ⟨ + ⟦ y * x + z * x ⟧ ∎) + + distrib : _DistributesOver_ _≈₂_ _⊛_ _⊕_ → _DistributesOver_ _≈₁_ _*_ _+_ + distrib distrib = distribˡ (proj₁ distrib) , distribʳ (proj₂ distrib) + + zeroˡ : LeftZero _≈₂_ 0#₂ _⊛_ → LeftZero _≈₁_ 0# _*_ + zeroˡ zeroˡ x = injective (begin + ⟦ 0# * x ⟧ ≈⟨ *-homo 0# x ⟩ + ⟦ 0# ⟧ ⊛ ⟦ x ⟧ ≈⟨ ◦-cong 0#-homo refl ⟩ + 0#₂ ⊛ ⟦ x ⟧ ≈⟨ zeroˡ ⟦ x ⟧ ⟩ + 0#₂ ≈⟨ 0#-homo ⟨ + ⟦ 0# ⟧ ∎) + + zeroʳ : RightZero _≈₂_ 0#₂ _⊛_ → RightZero _≈₁_ 0# _*_ + zeroʳ zeroʳ x = injective (begin + ⟦ x * 0# ⟧ ≈⟨ *-homo x 0# ⟩ + ⟦ x ⟧ ⊛ ⟦ 0# ⟧ ≈⟨ ◦-cong refl 0#-homo ⟩ + ⟦ x ⟧ ⊛ 0#₂ ≈⟨ zeroʳ ⟦ x ⟧ ⟩ + 0#₂ ≈⟨ 0#-homo ⟨ + ⟦ 0# ⟧ ∎) + + zero : Zero _≈₂_ 0#₂ _⊛_ → Zero _≈₁_ 0# _*_ + zero zero = zeroˡ (proj₁ zero) , zeroʳ (proj₂ zero) + + neg-distribˡ-* : (∀ x y → (⊝ (x ⊛ y)) ≈₂ ((⊝ x) ⊛ y)) → (∀ x y → (- (x * y)) ≈₁ ((- x) * y)) + neg-distribˡ-* neg-distribˡ-* x y = injective (begin + ⟦ - (x * y) ⟧ ≈⟨ -‿homo (x * y) ⟩ + ⊝ ⟦ x * y ⟧ ≈⟨ ⁻¹-cong (*-homo x y) ⟩ + ⊝ (⟦ x ⟧ ⊛ ⟦ y ⟧) ≈⟨ neg-distribˡ-* ⟦ x ⟧ ⟦ y ⟧ ⟩ + ⊝ ⟦ x ⟧ ⊛ ⟦ y ⟧ ≈⟨ ◦-cong (sym (-‿homo x)) refl ⟩ + ⟦ - x ⟧ ⊛ ⟦ y ⟧ ≈⟨ sym (*-homo (- x) y) ⟩ + ⟦ - x * y ⟧ ∎) + + neg-distribʳ-* : (∀ x y → (⊝ (x ⊛ y)) ≈₂ (x ⊛ (⊝ y))) → (∀ x y → (- (x * y)) ≈₁ (x * (- y))) + neg-distribʳ-* neg-distribʳ-* x y = injective (begin + ⟦ - (x * y) ⟧ ≈⟨ -‿homo (x * y) ⟩ + ⊝ ⟦ x * y ⟧ ≈⟨ ⁻¹-cong (*-homo x y) ⟩ + ⊝ (⟦ x ⟧ ⊛ ⟦ y ⟧) ≈⟨ neg-distribʳ-* ⟦ x ⟧ ⟦ y ⟧ ⟩ + ⟦ x ⟧ ⊛ ⊝ ⟦ y ⟧ ≈⟨ ◦-cong refl (sym (-‿homo y)) ⟩ + ⟦ x ⟧ ⊛ ⟦ - y ⟧ ≈⟨ sym (*-homo x (- y)) ⟩ + ⟦ x * - y ⟧ ∎) + +isRing : IsRing _≈₂_ _⊕_ _⊛_ ⊝_ 0#₂ 1#₂ → IsRing _≈₁_ _+_ _*_ -_ 0# 1# +isRing isRing = record + { +-isAbelianGroup = isAbelianGroup R.+-isAbelianGroup + ; *-cong = *-cong R.*-isMagma + ; *-assoc = *-assoc R.*-isMagma R.*-assoc + ; *-identity = *-identity R.*-isMagma R.*-identity + ; distrib = distrib R.+-isGroup R.*-isMagma R.distrib + } where module R = IsRing isRing + +isCommutativeRing : IsCommutativeRing _≈₂_ _⊕_ _⊛_ ⊝_ 0#₂ 1#₂ → + IsCommutativeRing _≈₁_ _+_ _*_ -_ 0# 1# +isCommutativeRing isCommRing = record + { isRing = isRing C.isRing + ; *-comm = *-comm C.*-isMagma C.*-comm + } where module C = IsCommutativeRing isCommRing \ No newline at end of file diff --git a/Algebra.Morphism.Structures.html b/Algebra.Morphism.Structures.html index 696c0c5a..21b77275 100644 --- a/Algebra.Morphism.Structures.html +++ b/Algebra.Morphism.Structures.html @@ -15,696 +15,729 @@ open import Algebra.Bundles import Algebra.Morphism.Definitions as MorphismDefinitions open import Level using (Level; _⊔_) -import Function.Definitions as FunctionDefinitions -open import Relation.Binary.Morphism.Structures +open import Function.Definitions +open import Relation.Binary.Morphism.Structures -private - variable - a b ℓ₁ ℓ₂ : Level +private + variable + a b ℓ₁ ℓ₂ : Level ------------------------------------------------------------------------- --- Morphisms over magma-like structures ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Morphisms over magma-like structures +------------------------------------------------------------------------ -module MagmaMorphisms (M₁ : RawMagma a ℓ₁) (M₂ : RawMagma b ℓ₂) where +module MagmaMorphisms (M₁ : RawMagma a ℓ₁) (M₂ : RawMagma b ℓ₂) where - open RawMagma M₁ renaming (Carrier to A; _≈_ to _≈₁_; _∙_ to _∙_) - open RawMagma M₂ renaming (Carrier to B; _≈_ to _≈₂_; _∙_ to _◦_) - open MorphismDefinitions A B _≈₂_ - open FunctionDefinitions _≈₁_ _≈₂_ + open RawMagma M₁ renaming (Carrier to A; _≈_ to _≈₁_; _∙_ to _∙_) + open RawMagma M₂ renaming (Carrier to B; _≈_ to _≈₂_; _∙_ to _◦_) + open MorphismDefinitions A B _≈₂_ - record IsMagmaHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isRelHomomorphism : IsRelHomomorphism _≈₁_ _≈₂_ ⟦_⟧ - homo : Homomorphic₂ ⟦_⟧ _∙_ _◦_ + record IsMagmaHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isRelHomomorphism : IsRelHomomorphism _≈₁_ _≈₂_ ⟦_⟧ + homo : Homomorphic₂ ⟦_⟧ _∙_ _◦_ - open IsRelHomomorphism isRelHomomorphism public - renaming (cong to ⟦⟧-cong) + open IsRelHomomorphism isRelHomomorphism public + renaming (cong to ⟦⟧-cong) - record IsMagmaMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isMagmaHomomorphism : IsMagmaHomomorphism ⟦_⟧ - injective : Injective ⟦_⟧ + record IsMagmaMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isMagmaHomomorphism : IsMagmaHomomorphism ⟦_⟧ + injective : Injective _≈₁_ _≈₂_ ⟦_⟧ - open IsMagmaHomomorphism isMagmaHomomorphism public + open IsMagmaHomomorphism isMagmaHomomorphism public - isRelMonomorphism : IsRelMonomorphism _≈₁_ _≈₂_ ⟦_⟧ - isRelMonomorphism = record - { isHomomorphism = isRelHomomorphism - ; injective = injective - } + isRelMonomorphism : IsRelMonomorphism _≈₁_ _≈₂_ ⟦_⟧ + isRelMonomorphism = record + { isHomomorphism = isRelHomomorphism + ; injective = injective + } - record IsMagmaIsomorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - isMagmaMonomorphism : IsMagmaMonomorphism ⟦_⟧ - surjective : Surjective ⟦_⟧ + record IsMagmaIsomorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + isMagmaMonomorphism : IsMagmaMonomorphism ⟦_⟧ + surjective : Surjective _≈₁_ _≈₂_ ⟦_⟧ - open IsMagmaMonomorphism isMagmaMonomorphism public + open IsMagmaMonomorphism isMagmaMonomorphism public - isRelIsomorphism : IsRelIsomorphism _≈₁_ _≈₂_ ⟦_⟧ - isRelIsomorphism = record - { isMonomorphism = isRelMonomorphism - ; surjective = surjective - } + isRelIsomorphism : IsRelIsomorphism _≈₁_ _≈₂_ ⟦_⟧ + isRelIsomorphism = record + { isMonomorphism = isRelMonomorphism + ; surjective = surjective + } ------------------------------------------------------------------------- --- Morphisms over monoid-like structures ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Morphisms over monoid-like structures +------------------------------------------------------------------------ -module MonoidMorphisms (M₁ : RawMonoid a ℓ₁) (M₂ : RawMonoid b ℓ₂) where +module MonoidMorphisms (M₁ : RawMonoid a ℓ₁) (M₂ : RawMonoid b ℓ₂) where - open RawMonoid M₁ renaming (Carrier to A; _≈_ to _≈₁_; _∙_ to _∙_; ε to ε₁) - open RawMonoid M₂ renaming (Carrier to B; _≈_ to _≈₂_; _∙_ to _◦_; ε to ε₂) - open MorphismDefinitions A B _≈₂_ - open FunctionDefinitions _≈₁_ _≈₂_ - open MagmaMorphisms (RawMonoid.rawMagma M₁) (RawMonoid.rawMagma M₂) + open RawMonoid M₁ renaming (Carrier to A; _≈_ to _≈₁_; _∙_ to _∙_; ε to ε₁) + open RawMonoid M₂ renaming (Carrier to B; _≈_ to _≈₂_; _∙_ to _◦_; ε to ε₂) + open MorphismDefinitions A B _≈₂_ + open MagmaMorphisms (RawMonoid.rawMagma M₁) (RawMonoid.rawMagma M₂) - record IsMonoidHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isMagmaHomomorphism : IsMagmaHomomorphism ⟦_⟧ - ε-homo : Homomorphic₀ ⟦_⟧ ε₁ ε₂ + record IsMonoidHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isMagmaHomomorphism : IsMagmaHomomorphism ⟦_⟧ + ε-homo : Homomorphic₀ ⟦_⟧ ε₁ ε₂ - open IsMagmaHomomorphism isMagmaHomomorphism public + open IsMagmaHomomorphism isMagmaHomomorphism public - record IsMonoidMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isMonoidHomomorphism : IsMonoidHomomorphism ⟦_⟧ - injective : Injective ⟦_⟧ + record IsMonoidMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isMonoidHomomorphism : IsMonoidHomomorphism ⟦_⟧ + injective : Injective _≈₁_ _≈₂_ ⟦_⟧ - open IsMonoidHomomorphism isMonoidHomomorphism public + open IsMonoidHomomorphism isMonoidHomomorphism public - isMagmaMonomorphism : IsMagmaMonomorphism ⟦_⟧ - isMagmaMonomorphism = record - { isMagmaHomomorphism = isMagmaHomomorphism - ; injective = injective - } + isMagmaMonomorphism : IsMagmaMonomorphism ⟦_⟧ + isMagmaMonomorphism = record + { isMagmaHomomorphism = isMagmaHomomorphism + ; injective = injective + } - open IsMagmaMonomorphism isMagmaMonomorphism public - using (isRelMonomorphism) + open IsMagmaMonomorphism isMagmaMonomorphism public + using (isRelMonomorphism) - record IsMonoidIsomorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - isMonoidMonomorphism : IsMonoidMonomorphism ⟦_⟧ - surjective : Surjective ⟦_⟧ + record IsMonoidIsomorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + isMonoidMonomorphism : IsMonoidMonomorphism ⟦_⟧ + surjective : Surjective _≈₁_ _≈₂_ ⟦_⟧ - open IsMonoidMonomorphism isMonoidMonomorphism public + open IsMonoidMonomorphism isMonoidMonomorphism public - isMagmaIsomorphism : IsMagmaIsomorphism ⟦_⟧ - isMagmaIsomorphism = record - { isMagmaMonomorphism = isMagmaMonomorphism - ; surjective = surjective - } + isMagmaIsomorphism : IsMagmaIsomorphism ⟦_⟧ + isMagmaIsomorphism = record + { isMagmaMonomorphism = isMagmaMonomorphism + ; surjective = surjective + } - open IsMagmaIsomorphism isMagmaIsomorphism public - using (isRelIsomorphism) + open IsMagmaIsomorphism isMagmaIsomorphism public + using (isRelIsomorphism) ------------------------------------------------------------------------- --- Morphisms over group-like structures ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Morphisms over group-like structures +------------------------------------------------------------------------ -module GroupMorphisms (G₁ : RawGroup a ℓ₁) (G₂ : RawGroup b ℓ₂) where +module GroupMorphisms (G₁ : RawGroup a ℓ₁) (G₂ : RawGroup b ℓ₂) where - open RawGroup G₁ renaming - (Carrier to A; _≈_ to _≈₁_; _∙_ to _∙_; _⁻¹ to _⁻¹₁; ε to ε₁) - open RawGroup G₂ renaming - (Carrier to B; _≈_ to _≈₂_; _∙_ to _◦_; _⁻¹ to _⁻¹₂; ε to ε₂) - open MorphismDefinitions A B _≈₂_ - open FunctionDefinitions _≈₁_ _≈₂_ - open MagmaMorphisms (RawGroup.rawMagma G₁) (RawGroup.rawMagma G₂) - open MonoidMorphisms (RawGroup.rawMonoid G₁) (RawGroup.rawMonoid G₂) + open RawGroup G₁ renaming + (Carrier to A; _≈_ to _≈₁_; _∙_ to _∙_; _⁻¹ to _⁻¹₁; ε to ε₁) + open RawGroup G₂ renaming + (Carrier to B; _≈_ to _≈₂_; _∙_ to _◦_; _⁻¹ to _⁻¹₂; ε to ε₂) + open MorphismDefinitions A B _≈₂_ + open MagmaMorphisms (RawGroup.rawMagma G₁) (RawGroup.rawMagma G₂) + open MonoidMorphisms (RawGroup.rawMonoid G₁) (RawGroup.rawMonoid G₂) - record IsGroupHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isMonoidHomomorphism : IsMonoidHomomorphism ⟦_⟧ - ⁻¹-homo : Homomorphic₁ ⟦_⟧ _⁻¹₁ _⁻¹₂ + record IsGroupHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isMonoidHomomorphism : IsMonoidHomomorphism ⟦_⟧ + ⁻¹-homo : Homomorphic₁ ⟦_⟧ _⁻¹₁ _⁻¹₂ - open IsMonoidHomomorphism isMonoidHomomorphism public + open IsMonoidHomomorphism isMonoidHomomorphism public - record IsGroupMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isGroupHomomorphism : IsGroupHomomorphism ⟦_⟧ - injective : Injective ⟦_⟧ + record IsGroupMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isGroupHomomorphism : IsGroupHomomorphism ⟦_⟧ + injective : Injective _≈₁_ _≈₂_ ⟦_⟧ - open IsGroupHomomorphism isGroupHomomorphism public - renaming (homo to ∙-homo) + open IsGroupHomomorphism isGroupHomomorphism public + renaming (homo to ∙-homo) - isMonoidMonomorphism : IsMonoidMonomorphism ⟦_⟧ - isMonoidMonomorphism = record - { isMonoidHomomorphism = isMonoidHomomorphism - ; injective = injective - } + isMonoidMonomorphism : IsMonoidMonomorphism ⟦_⟧ + isMonoidMonomorphism = record + { isMonoidHomomorphism = isMonoidHomomorphism + ; injective = injective + } - open IsMonoidMonomorphism isMonoidMonomorphism public - using (isRelMonomorphism; isMagmaMonomorphism) + open IsMonoidMonomorphism isMonoidMonomorphism public + using (isRelMonomorphism; isMagmaMonomorphism) - record IsGroupIsomorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - isGroupMonomorphism : IsGroupMonomorphism ⟦_⟧ - surjective : Surjective ⟦_⟧ + record IsGroupIsomorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + isGroupMonomorphism : IsGroupMonomorphism ⟦_⟧ + surjective : Surjective _≈₁_ _≈₂_ ⟦_⟧ - open IsGroupMonomorphism isGroupMonomorphism public + open IsGroupMonomorphism isGroupMonomorphism public - isMonoidIsomorphism : IsMonoidIsomorphism ⟦_⟧ - isMonoidIsomorphism = record - { isMonoidMonomorphism = isMonoidMonomorphism - ; surjective = surjective - } + isMonoidIsomorphism : IsMonoidIsomorphism ⟦_⟧ + isMonoidIsomorphism = record + { isMonoidMonomorphism = isMonoidMonomorphism + ; surjective = surjective + } - open IsMonoidIsomorphism isMonoidIsomorphism public - using (isRelIsomorphism; isMagmaIsomorphism) + open IsMonoidIsomorphism isMonoidIsomorphism public + using (isRelIsomorphism; isMagmaIsomorphism) ------------------------------------------------------------------------- --- Morphisms over near-semiring-like structures ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Morphisms over near-semiring-like structures +------------------------------------------------------------------------ -module NearSemiringMorphisms (R₁ : RawNearSemiring a ℓ₁) (R₂ : RawNearSemiring b ℓ₂) where +module NearSemiringMorphisms (R₁ : RawNearSemiring a ℓ₁) (R₂ : RawNearSemiring b ℓ₂) where - open RawNearSemiring R₁ renaming - ( Carrier to A; _≈_ to _≈₁_ - ; +-rawMonoid to +-rawMonoid₁ - ; _*_ to _*₁_ - ; *-rawMagma to *-rawMagma₁) + open RawNearSemiring R₁ renaming + ( Carrier to A; _≈_ to _≈₁_ + ; +-rawMonoid to +-rawMonoid₁ + ; _*_ to _*₁_ + ; *-rawMagma to *-rawMagma₁) - open RawNearSemiring R₂ renaming - ( Carrier to B; _≈_ to _≈₂_ - ; +-rawMonoid to +-rawMonoid₂ - ; _*_ to _*₂_ - ; *-rawMagma to *-rawMagma₂) + open RawNearSemiring R₂ renaming + ( Carrier to B; _≈_ to _≈₂_ + ; +-rawMonoid to +-rawMonoid₂ + ; _*_ to _*₂_ + ; *-rawMagma to *-rawMagma₂) - private - module + = MonoidMorphisms +-rawMonoid₁ +-rawMonoid₂ - module * = MagmaMorphisms *-rawMagma₁ *-rawMagma₂ + private + module + = MonoidMorphisms +-rawMonoid₁ +-rawMonoid₂ + module * = MagmaMorphisms *-rawMagma₁ *-rawMagma₂ - open MorphismDefinitions A B _≈₂_ - open FunctionDefinitions _≈₁_ _≈₂_ + open MorphismDefinitions A B _≈₂_ - record IsNearSemiringHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - +-isMonoidHomomorphism : +.IsMonoidHomomorphism ⟦_⟧ - *-homo : Homomorphic₂ ⟦_⟧ _*₁_ _*₂_ + record IsNearSemiringHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + +-isMonoidHomomorphism : +.IsMonoidHomomorphism ⟦_⟧ + *-homo : Homomorphic₂ ⟦_⟧ _*₁_ _*₂_ - open +.IsMonoidHomomorphism +-isMonoidHomomorphism public - renaming (homo to +-homo; ε-homo to 0#-homo; isMagmaHomomorphism to +-isMagmaHomomorphism) + open +.IsMonoidHomomorphism +-isMonoidHomomorphism public + renaming (homo to +-homo; ε-homo to 0#-homo; isMagmaHomomorphism to +-isMagmaHomomorphism) - *-isMagmaHomomorphism : *.IsMagmaHomomorphism ⟦_⟧ - *-isMagmaHomomorphism = record - { isRelHomomorphism = isRelHomomorphism - ; homo = *-homo - } + *-isMagmaHomomorphism : *.IsMagmaHomomorphism ⟦_⟧ + *-isMagmaHomomorphism = record + { isRelHomomorphism = isRelHomomorphism + ; homo = *-homo + } - record IsNearSemiringMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isNearSemiringHomomorphism : IsNearSemiringHomomorphism ⟦_⟧ - injective : Injective ⟦_⟧ + record IsNearSemiringMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isNearSemiringHomomorphism : IsNearSemiringHomomorphism ⟦_⟧ + injective : Injective _≈₁_ _≈₂_ ⟦_⟧ - open IsNearSemiringHomomorphism isNearSemiringHomomorphism public + open IsNearSemiringHomomorphism isNearSemiringHomomorphism public - +-isMonoidMonomorphism : +.IsMonoidMonomorphism ⟦_⟧ - +-isMonoidMonomorphism = record - { isMonoidHomomorphism = +-isMonoidHomomorphism - ; injective = injective - } + +-isMonoidMonomorphism : +.IsMonoidMonomorphism ⟦_⟧ + +-isMonoidMonomorphism = record + { isMonoidHomomorphism = +-isMonoidHomomorphism + ; injective = injective + } - open +.IsMonoidMonomorphism +-isMonoidMonomorphism public - using (isRelMonomorphism) - renaming (isMagmaMonomorphism to +-isMagmaMonomorphsm) + open +.IsMonoidMonomorphism +-isMonoidMonomorphism public + using (isRelMonomorphism) + renaming (isMagmaMonomorphism to +-isMagmaMonomorphsm) - *-isMagmaMonomorphism : *.IsMagmaMonomorphism ⟦_⟧ - *-isMagmaMonomorphism = record - { isMagmaHomomorphism = *-isMagmaHomomorphism - ; injective = injective - } + *-isMagmaMonomorphism : *.IsMagmaMonomorphism ⟦_⟧ + *-isMagmaMonomorphism = record + { isMagmaHomomorphism = *-isMagmaHomomorphism + ; injective = injective + } - record IsNearSemiringIsomorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - isNearSemiringMonomorphism : IsNearSemiringMonomorphism ⟦_⟧ - surjective : Surjective ⟦_⟧ - - open IsNearSemiringMonomorphism isNearSemiringMonomorphism public - - +-isMonoidIsomorphism : +.IsMonoidIsomorphism ⟦_⟧ - +-isMonoidIsomorphism = record - { isMonoidMonomorphism = +-isMonoidMonomorphism - ; surjective = surjective - } - - open +.IsMonoidIsomorphism +-isMonoidIsomorphism public - using (isRelIsomorphism) - renaming (isMagmaIsomorphism to +-isMagmaIsomorphism) - - *-isMagmaIsomorphism : *.IsMagmaIsomorphism ⟦_⟧ - *-isMagmaIsomorphism = record - { isMagmaMonomorphism = *-isMagmaMonomorphism - ; surjective = surjective - } - ------------------------------------------------------------------------- --- Morphisms over semiring-like structures ------------------------------------------------------------------------- - -module SemiringMorphisms (R₁ : RawSemiring a ℓ₁) (R₂ : RawSemiring b ℓ₂) where - - open RawSemiring R₁ renaming - ( Carrier to A; _≈_ to _≈₁_ - ; 1# to 1#₁ - ; rawNearSemiring to rawNearSemiring₁ - ; *-rawMonoid to *-rawMonoid₁) - - open RawSemiring R₂ renaming - ( Carrier to B; _≈_ to _≈₂_ - ; 1# to 1#₂ - ; rawNearSemiring to rawNearSemiring₂ - ; *-rawMonoid to *-rawMonoid₂) - - private - module * = MonoidMorphisms *-rawMonoid₁ *-rawMonoid₂ - - open MorphismDefinitions A B _≈₂_ - open FunctionDefinitions _≈₁_ _≈₂_ - open NearSemiringMorphisms rawNearSemiring₁ rawNearSemiring₂ - - record IsSemiringHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isNearSemiringHomomorphism : IsNearSemiringHomomorphism ⟦_⟧ - 1#-homo : Homomorphic₀ ⟦_⟧ 1#₁ 1#₂ - - open IsNearSemiringHomomorphism isNearSemiringHomomorphism public - - *-isMonoidHomomorphism : *.IsMonoidHomomorphism ⟦_⟧ - *-isMonoidHomomorphism = record - { isMagmaHomomorphism = *-isMagmaHomomorphism - ; ε-homo = 1#-homo - } - - record IsSemiringMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isSemiringHomomorphism : IsSemiringHomomorphism ⟦_⟧ - injective : Injective ⟦_⟧ - - open IsSemiringHomomorphism isSemiringHomomorphism public - - isNearSemiringMonomorphism : IsNearSemiringMonomorphism ⟦_⟧ - isNearSemiringMonomorphism = record - { isNearSemiringHomomorphism = isNearSemiringHomomorphism - ; injective = injective - } - - open IsNearSemiringMonomorphism isNearSemiringMonomorphism public - using (+-isMonoidMonomorphism; *-isMagmaMonomorphism) - - *-isMonoidMonomorphism : *.IsMonoidMonomorphism ⟦_⟧ - *-isMonoidMonomorphism = record - { isMonoidHomomorphism = *-isMonoidHomomorphism - ; injective = injective - } - - record IsSemiringIsomorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - isSemiringMonomorphism : IsSemiringMonomorphism ⟦_⟧ - surjective : Surjective ⟦_⟧ - - open IsSemiringMonomorphism isSemiringMonomorphism public - - isNearSemiringIsomorphism : IsNearSemiringIsomorphism ⟦_⟧ - isNearSemiringIsomorphism = record - { isNearSemiringMonomorphism = isNearSemiringMonomorphism - ; surjective = surjective - } - - open IsNearSemiringIsomorphism isNearSemiringIsomorphism public - using (+-isMonoidIsomorphism; *-isMagmaIsomorphism) - - *-isMonoidIsomorphism : *.IsMonoidIsomorphism ⟦_⟧ - *-isMonoidIsomorphism = record - { isMonoidMonomorphism = *-isMonoidMonomorphism - ; surjective = surjective - } - ------------------------------------------------------------------------- --- Morphisms over ringWithoutOne-like structures ------------------------------------------------------------------------- - -module RingWithoutOneMorphisms (R₁ : RawRingWithoutOne a ℓ₁) (R₂ : RawRingWithoutOne b ℓ₂) where - - open RawRingWithoutOne R₁ renaming - ( Carrier to A; _≈_ to _≈₁_ - ; _*_ to _*₁_ - ; *-rawMagma to *-rawMagma₁ - ; +-rawGroup to +-rawGroup₁) - - open RawRingWithoutOne R₂ renaming - ( Carrier to B; _≈_ to _≈₂_ - ; _*_ to _*₂_ - ; *-rawMagma to *-rawMagma₂ - ; +-rawGroup to +-rawGroup₂) - - private - module + = GroupMorphisms +-rawGroup₁ +-rawGroup₂ - module * = MagmaMorphisms *-rawMagma₁ *-rawMagma₂ - - open MorphismDefinitions A B _≈₂_ - open FunctionDefinitions _≈₁_ _≈₂_ - - record IsRingWithoutOneHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - +-isGroupHomomorphism : +.IsGroupHomomorphism ⟦_⟧ - *-homo : Homomorphic₂ ⟦_⟧ _*₁_ _*₂_ - - open +.IsGroupHomomorphism +-isGroupHomomorphism public - renaming (homo to +-homo; ε-homo to 0#-homo; isMagmaHomomorphism to +-isMagmaHomomorphism) - - *-isMagmaHomomorphism : *.IsMagmaHomomorphism ⟦_⟧ - *-isMagmaHomomorphism = record - { isRelHomomorphism = isRelHomomorphism - ; homo = *-homo - } - - record IsRingWithoutOneMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isRingWithoutOneHomomorphism : IsRingWithoutOneHomomorphism ⟦_⟧ - injective : Injective ⟦_⟧ - - open IsRingWithoutOneHomomorphism isRingWithoutOneHomomorphism public - - +-isGroupMonomorphism : +.IsGroupMonomorphism ⟦_⟧ - +-isGroupMonomorphism = record - { isGroupHomomorphism = +-isGroupHomomorphism - ; injective = injective - } - - open +.IsGroupMonomorphism +-isGroupMonomorphism public - using (isRelMonomorphism) - renaming (isMagmaMonomorphism to +-isMagmaMonomorphsm; isMonoidMonomorphism to +-isMonoidMonomorphism) - - *-isMagmaMonomorphism : *.IsMagmaMonomorphism ⟦_⟧ - *-isMagmaMonomorphism = record - { isMagmaHomomorphism = *-isMagmaHomomorphism - ; injective = injective - } - - record IsRingWithoutOneIsoMorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - isRingWithoutOneMonomorphism : IsRingWithoutOneMonomorphism ⟦_⟧ - surjective : Surjective ⟦_⟧ - - open IsRingWithoutOneMonomorphism isRingWithoutOneMonomorphism public - - +-isGroupIsomorphism : +.IsGroupIsomorphism ⟦_⟧ - +-isGroupIsomorphism = record - { isGroupMonomorphism = +-isGroupMonomorphism - ; surjective = surjective - } - - open +.IsGroupIsomorphism +-isGroupIsomorphism public - using (isRelIsomorphism) - renaming (isMagmaIsomorphism to +-isMagmaIsomorphism; isMonoidIsomorphism to +-isMonoidIsomorphism) - - *-isMagmaIsomorphism : *.IsMagmaIsomorphism ⟦_⟧ - *-isMagmaIsomorphism = record - { isMagmaMonomorphism = *-isMagmaMonomorphism - ; surjective = surjective - } - - ------------------------------------------------------------------------- --- Morphisms over ring-like structures ------------------------------------------------------------------------- - -module RingMorphisms (R₁ : RawRing a ℓ₁) (R₂ : RawRing b ℓ₂) where - - open RawRing R₁ renaming - ( Carrier to A; _≈_ to _≈₁_ - ; -_ to -₁_ - ; rawSemiring to rawSemiring₁ - ; *-rawMonoid to *-rawMonoid₁ - ; +-rawGroup to +-rawGroup₁) - - open RawRing R₂ renaming - ( Carrier to B; _≈_ to _≈₂_ - ; -_ to -₂_ - ; rawSemiring to rawSemiring₂ - ; *-rawMonoid to *-rawMonoid₂ - ; +-rawGroup to +-rawGroup₂) - - module + = GroupMorphisms +-rawGroup₁ +-rawGroup₂ - module * = MonoidMorphisms *-rawMonoid₁ *-rawMonoid₂ - - open MorphismDefinitions A B _≈₂_ - open FunctionDefinitions _≈₁_ _≈₂_ - open SemiringMorphisms rawSemiring₁ rawSemiring₂ - - - record IsRingHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isSemiringHomomorphism : IsSemiringHomomorphism ⟦_⟧ - -‿homo : Homomorphic₁ ⟦_⟧ -₁_ -₂_ - - open IsSemiringHomomorphism isSemiringHomomorphism public - - +-isGroupHomomorphism : +.IsGroupHomomorphism ⟦_⟧ - +-isGroupHomomorphism = record - { isMonoidHomomorphism = +-isMonoidHomomorphism - ; ⁻¹-homo = -‿homo - } - - record IsRingMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isRingHomomorphism : IsRingHomomorphism ⟦_⟧ - injective : Injective ⟦_⟧ - - open IsRingHomomorphism isRingHomomorphism public - - isSemiringMonomorphism : IsSemiringMonomorphism ⟦_⟧ - isSemiringMonomorphism = record - { isSemiringHomomorphism = isSemiringHomomorphism - ; injective = injective - } - - +-isGroupMonomorphism : +.IsGroupMonomorphism ⟦_⟧ - +-isGroupMonomorphism = record - { isGroupHomomorphism = +-isGroupHomomorphism - ; injective = injective - } - - open +.IsGroupMonomorphism +-isGroupMonomorphism - using (isRelMonomorphism) - renaming ( isMagmaMonomorphism to +-isMagmaMonomorphism - ; isMonoidMonomorphism to +-isMonoidMonomorphism - ) - - *-isMonoidMonomorphism : *.IsMonoidMonomorphism ⟦_⟧ - *-isMonoidMonomorphism = record - { isMonoidHomomorphism = *-isMonoidHomomorphism - ; injective = injective - } - - open *.IsMonoidMonomorphism *-isMonoidMonomorphism public - using () - renaming (isMagmaMonomorphism to *-isMagmaMonomorphism) - - - record IsRingIsomorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - isRingMonomorphism : IsRingMonomorphism ⟦_⟧ - surjective : Surjective ⟦_⟧ - - open IsRingMonomorphism isRingMonomorphism public - - isSemiringIsomorphism : IsSemiringIsomorphism ⟦_⟧ - isSemiringIsomorphism = record - { isSemiringMonomorphism = isSemiringMonomorphism - ; surjective = surjective - } - - +-isGroupIsomorphism : +.IsGroupIsomorphism ⟦_⟧ - +-isGroupIsomorphism = record - { isGroupMonomorphism = +-isGroupMonomorphism - ; surjective = surjective - } - - open +.IsGroupIsomorphism +-isGroupIsomorphism - using (isRelIsomorphism) - renaming ( isMagmaIsomorphism to +-isMagmaIsomorphism - ; isMonoidIsomorphism to +-isMonoidIsomorphisn - ) - - *-isMonoidIsomorphism : *.IsMonoidIsomorphism ⟦_⟧ - *-isMonoidIsomorphism = record - { isMonoidMonomorphism = *-isMonoidMonomorphism - ; surjective = surjective - } - - open *.IsMonoidIsomorphism *-isMonoidIsomorphism public - using () - renaming (isMagmaIsomorphism to *-isMagmaIsomorphisn) - ------------------------------------------------------------------------- --- Morphisms over quasigroup-like structures ------------------------------------------------------------------------- - -module QuasigroupMorphisms (Q₁ : RawQuasigroup a ℓ₁) (Q₂ : RawQuasigroup b ℓ₂) where - - open RawQuasigroup Q₁ renaming (Carrier to A; ∙-rawMagma to ∙-rawMagma₁; - \\-rawMagma to \\-rawMagma₁; //-rawMagma to //-rawMagma₁; - _≈_ to _≈₁_; _∙_ to _∙₁_; _\\_ to _\\₁_; _//_ to _//₁_) - open RawQuasigroup Q₂ renaming (Carrier to B; ∙-rawMagma to ∙-rawMagma₂; - \\-rawMagma to \\-rawMagma₂; //-rawMagma to //-rawMagma₂; - _≈_ to _≈₂_; _∙_ to _∙₂_; _\\_ to _\\₂_; _//_ to _//₂_) - - module ∙ = MagmaMorphisms ∙-rawMagma₁ ∙-rawMagma₂ - module \\ = MagmaMorphisms \\-rawMagma₁ \\-rawMagma₂ - module // = MagmaMorphisms //-rawMagma₁ //-rawMagma₂ - - open MorphismDefinitions A B _≈₂_ - open FunctionDefinitions _≈₁_ _≈₂_ - - record IsQuasigroupHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isRelHomomorphism : IsRelHomomorphism _≈₁_ _≈₂_ ⟦_⟧ - ∙-homo : Homomorphic₂ ⟦_⟧ _∙₁_ _∙₂_ - \\-homo : Homomorphic₂ ⟦_⟧ _\\₁_ _\\₂_ - //-homo : Homomorphic₂ ⟦_⟧ _//₁_ _//₂_ - - open IsRelHomomorphism isRelHomomorphism public - renaming (cong to ⟦⟧-cong) - - ∙-isMagmaHomomorphism : ∙.IsMagmaHomomorphism ⟦_⟧ - ∙-isMagmaHomomorphism = record - { isRelHomomorphism = isRelHomomorphism - ; homo = ∙-homo - } - - \\-isMagmaHomomorphism : \\.IsMagmaHomomorphism ⟦_⟧ - \\-isMagmaHomomorphism = record - { isRelHomomorphism = isRelHomomorphism - ; homo = \\-homo - } - - //-isMagmaHomomorphism : //.IsMagmaHomomorphism ⟦_⟧ - //-isMagmaHomomorphism = record - { isRelHomomorphism = isRelHomomorphism - ; homo = //-homo - } - - record IsQuasigroupMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isQuasigroupHomomorphism : IsQuasigroupHomomorphism ⟦_⟧ - injective : Injective ⟦_⟧ - - open IsQuasigroupHomomorphism isQuasigroupHomomorphism public - - - ∙-isMagmaMonomorphism : ∙.IsMagmaMonomorphism ⟦_⟧ - ∙-isMagmaMonomorphism = record - { isMagmaHomomorphism = ∙-isMagmaHomomorphism - ; injective = injective - } - - \\-isMagmaMonomorphism : \\.IsMagmaMonomorphism ⟦_⟧ - \\-isMagmaMonomorphism = record - { isMagmaHomomorphism = \\-isMagmaHomomorphism - ; injective = injective - } - - //-isMagmaMonomorphism : //.IsMagmaMonomorphism ⟦_⟧ - //-isMagmaMonomorphism = record - { isMagmaHomomorphism = //-isMagmaHomomorphism - ; injective = injective - } - - open //.IsMagmaMonomorphism //-isMagmaMonomorphism public - using (isRelMonomorphism) - - - record IsQuasigroupIsomorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - isQuasigroupMonomorphism : IsQuasigroupMonomorphism ⟦_⟧ - surjective : Surjective ⟦_⟧ - - open IsQuasigroupMonomorphism isQuasigroupMonomorphism public - - ∙-isMagmaIsomorphism : ∙.IsMagmaIsomorphism ⟦_⟧ - ∙-isMagmaIsomorphism = record - { isMagmaMonomorphism = ∙-isMagmaMonomorphism - ; surjective = surjective - } - - \\-isMagmaIsomorphism : \\.IsMagmaIsomorphism ⟦_⟧ - \\-isMagmaIsomorphism = record - { isMagmaMonomorphism = \\-isMagmaMonomorphism - ; surjective = surjective - } - - //-isMagmaIsomorphism : //.IsMagmaIsomorphism ⟦_⟧ - //-isMagmaIsomorphism = record - { isMagmaMonomorphism = //-isMagmaMonomorphism - ; surjective = surjective - } - - open //.IsMagmaIsomorphism //-isMagmaIsomorphism public - using (isRelIsomorphism) - ------------------------------------------------------------------------- --- Morphisms over loop-like structures ------------------------------------------------------------------------- - -module LoopMorphisms (L₁ : RawLoop a ℓ₁) (L₂ : RawLoop b ℓ₂) where - - open RawLoop L₁ renaming (Carrier to A; ∙-rawMagma to ∙-rawMagma₁; - \\-rawMagma to \\-rawMagma₁; //-rawMagma to //-rawMagma₁; - _≈_ to _≈₁_; _∙_ to _∙₁_; _\\_ to _\\₁_; _//_ to _//₁_; ε to ε₁) - open RawLoop L₂ renaming (Carrier to B; ∙-rawMagma to ∙-rawMagma₂; - \\-rawMagma to \\-rawMagma₂; //-rawMagma to //-rawMagma₂; - _≈_ to _≈₂_; _∙_ to _∙₂_; _\\_ to _\\₂_; _//_ to _//₂_ ; ε to ε₂) - open MorphismDefinitions A B _≈₂_ - open FunctionDefinitions _≈₁_ _≈₂_ - - open QuasigroupMorphisms (RawLoop.rawQuasigroup L₁) (RawLoop.rawQuasigroup L₂) - - record IsLoopHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isQuasigroupHomomorphism : IsQuasigroupHomomorphism ⟦_⟧ - ε-homo : Homomorphic₀ ⟦_⟧ ε₁ ε₂ - - open IsQuasigroupHomomorphism isQuasigroupHomomorphism public - - record IsLoopMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isLoopHomomorphism : IsLoopHomomorphism ⟦_⟧ - injective : Injective ⟦_⟧ - - open IsLoopHomomorphism isLoopHomomorphism public - - record IsLoopIsomorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - isLoopMonomorphism : IsLoopMonomorphism ⟦_⟧ - surjective : Surjective ⟦_⟧ - - open IsLoopMonomorphism isLoopMonomorphism public - ------------------------------------------------------------------------- --- Re-export contents of modules publicly - -open MagmaMorphisms public -open MonoidMorphisms public -open GroupMorphisms public -open NearSemiringMorphisms public -open SemiringMorphisms public -open RingWithoutOneMorphisms public -open RingMorphisms public -open QuasigroupMorphisms public -open LoopMorphisms public + record IsNearSemiringIsomorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + isNearSemiringMonomorphism : IsNearSemiringMonomorphism ⟦_⟧ + surjective : Surjective _≈₁_ _≈₂_ ⟦_⟧ + + open IsNearSemiringMonomorphism isNearSemiringMonomorphism public + + +-isMonoidIsomorphism : +.IsMonoidIsomorphism ⟦_⟧ + +-isMonoidIsomorphism = record + { isMonoidMonomorphism = +-isMonoidMonomorphism + ; surjective = surjective + } + + open +.IsMonoidIsomorphism +-isMonoidIsomorphism public + using (isRelIsomorphism) + renaming (isMagmaIsomorphism to +-isMagmaIsomorphism) + + *-isMagmaIsomorphism : *.IsMagmaIsomorphism ⟦_⟧ + *-isMagmaIsomorphism = record + { isMagmaMonomorphism = *-isMagmaMonomorphism + ; surjective = surjective + } + +------------------------------------------------------------------------ +-- Morphisms over semiring-like structures +------------------------------------------------------------------------ + +module SemiringMorphisms (R₁ : RawSemiring a ℓ₁) (R₂ : RawSemiring b ℓ₂) where + + open RawSemiring R₁ renaming + ( Carrier to A; _≈_ to _≈₁_ + ; 1# to 1#₁ + ; rawNearSemiring to rawNearSemiring₁ + ; *-rawMonoid to *-rawMonoid₁) + + open RawSemiring R₂ renaming + ( Carrier to B; _≈_ to _≈₂_ + ; 1# to 1#₂ + ; rawNearSemiring to rawNearSemiring₂ + ; *-rawMonoid to *-rawMonoid₂) + + private + module * = MonoidMorphisms *-rawMonoid₁ *-rawMonoid₂ + + open MorphismDefinitions A B _≈₂_ + open NearSemiringMorphisms rawNearSemiring₁ rawNearSemiring₂ + + record IsSemiringHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isNearSemiringHomomorphism : IsNearSemiringHomomorphism ⟦_⟧ + 1#-homo : Homomorphic₀ ⟦_⟧ 1#₁ 1#₂ + + open IsNearSemiringHomomorphism isNearSemiringHomomorphism public + + *-isMonoidHomomorphism : *.IsMonoidHomomorphism ⟦_⟧ + *-isMonoidHomomorphism = record + { isMagmaHomomorphism = *-isMagmaHomomorphism + ; ε-homo = 1#-homo + } + + record IsSemiringMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isSemiringHomomorphism : IsSemiringHomomorphism ⟦_⟧ + injective : Injective _≈₁_ _≈₂_ ⟦_⟧ + + open IsSemiringHomomorphism isSemiringHomomorphism public + + isNearSemiringMonomorphism : IsNearSemiringMonomorphism ⟦_⟧ + isNearSemiringMonomorphism = record + { isNearSemiringHomomorphism = isNearSemiringHomomorphism + ; injective = injective + } + + open IsNearSemiringMonomorphism isNearSemiringMonomorphism public + using (+-isMonoidMonomorphism; *-isMagmaMonomorphism) + + *-isMonoidMonomorphism : *.IsMonoidMonomorphism ⟦_⟧ + *-isMonoidMonomorphism = record + { isMonoidHomomorphism = *-isMonoidHomomorphism + ; injective = injective + } + + record IsSemiringIsomorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + isSemiringMonomorphism : IsSemiringMonomorphism ⟦_⟧ + surjective : Surjective _≈₁_ _≈₂_ ⟦_⟧ + + open IsSemiringMonomorphism isSemiringMonomorphism public + + isNearSemiringIsomorphism : IsNearSemiringIsomorphism ⟦_⟧ + isNearSemiringIsomorphism = record + { isNearSemiringMonomorphism = isNearSemiringMonomorphism + ; surjective = surjective + } + + open IsNearSemiringIsomorphism isNearSemiringIsomorphism public + using (+-isMonoidIsomorphism; *-isMagmaIsomorphism) + + *-isMonoidIsomorphism : *.IsMonoidIsomorphism ⟦_⟧ + *-isMonoidIsomorphism = record + { isMonoidMonomorphism = *-isMonoidMonomorphism + ; surjective = surjective + } + +------------------------------------------------------------------------ +-- Morphisms over ringWithoutOne-like structures +------------------------------------------------------------------------ + +module RingWithoutOneMorphisms (R₁ : RawRingWithoutOne a ℓ₁) (R₂ : RawRingWithoutOne b ℓ₂) where + + open RawRingWithoutOne R₁ renaming + ( Carrier to A; _≈_ to _≈₁_ + ; _*_ to _*₁_ + ; *-rawMagma to *-rawMagma₁ + ; +-rawGroup to +-rawGroup₁) + + open RawRingWithoutOne R₂ renaming + ( Carrier to B; _≈_ to _≈₂_ + ; _*_ to _*₂_ + ; *-rawMagma to *-rawMagma₂ + ; +-rawGroup to +-rawGroup₂) + + private + module + = GroupMorphisms +-rawGroup₁ +-rawGroup₂ + module * = MagmaMorphisms *-rawMagma₁ *-rawMagma₂ + + open MorphismDefinitions A B _≈₂_ + + record IsRingWithoutOneHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + +-isGroupHomomorphism : +.IsGroupHomomorphism ⟦_⟧ + *-homo : Homomorphic₂ ⟦_⟧ _*₁_ _*₂_ + + open +.IsGroupHomomorphism +-isGroupHomomorphism public + renaming (homo to +-homo; ε-homo to 0#-homo; isMagmaHomomorphism to +-isMagmaHomomorphism) + + *-isMagmaHomomorphism : *.IsMagmaHomomorphism ⟦_⟧ + *-isMagmaHomomorphism = record + { isRelHomomorphism = isRelHomomorphism + ; homo = *-homo + } + + record IsRingWithoutOneMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isRingWithoutOneHomomorphism : IsRingWithoutOneHomomorphism ⟦_⟧ + injective : Injective _≈₁_ _≈₂_ ⟦_⟧ + + open IsRingWithoutOneHomomorphism isRingWithoutOneHomomorphism public + + +-isGroupMonomorphism : +.IsGroupMonomorphism ⟦_⟧ + +-isGroupMonomorphism = record + { isGroupHomomorphism = +-isGroupHomomorphism + ; injective = injective + } + + open +.IsGroupMonomorphism +-isGroupMonomorphism public + using (isRelMonomorphism) + renaming (isMagmaMonomorphism to +-isMagmaMonomorphsm; isMonoidMonomorphism to +-isMonoidMonomorphism) + + *-isMagmaMonomorphism : *.IsMagmaMonomorphism ⟦_⟧ + *-isMagmaMonomorphism = record + { isMagmaHomomorphism = *-isMagmaHomomorphism + ; injective = injective + } + + record IsRingWithoutOneIsoMorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + isRingWithoutOneMonomorphism : IsRingWithoutOneMonomorphism ⟦_⟧ + surjective : Surjective _≈₁_ _≈₂_ ⟦_⟧ + + open IsRingWithoutOneMonomorphism isRingWithoutOneMonomorphism public + + +-isGroupIsomorphism : +.IsGroupIsomorphism ⟦_⟧ + +-isGroupIsomorphism = record + { isGroupMonomorphism = +-isGroupMonomorphism + ; surjective = surjective + } + + open +.IsGroupIsomorphism +-isGroupIsomorphism public + using (isRelIsomorphism) + renaming (isMagmaIsomorphism to +-isMagmaIsomorphism; isMonoidIsomorphism to +-isMonoidIsomorphism) + + *-isMagmaIsomorphism : *.IsMagmaIsomorphism ⟦_⟧ + *-isMagmaIsomorphism = record + { isMagmaMonomorphism = *-isMagmaMonomorphism + ; surjective = surjective + } + + +------------------------------------------------------------------------ +-- Morphisms over ring-like structures +------------------------------------------------------------------------ + +module RingMorphisms (R₁ : RawRing a ℓ₁) (R₂ : RawRing b ℓ₂) where + + open RawRing R₁ renaming + ( Carrier to A; _≈_ to _≈₁_ + ; -_ to -₁_ + ; rawSemiring to rawSemiring₁ + ; *-rawMonoid to *-rawMonoid₁ + ; +-rawGroup to +-rawGroup₁) + + open RawRing R₂ renaming + ( Carrier to B; _≈_ to _≈₂_ + ; -_ to -₂_ + ; rawSemiring to rawSemiring₂ + ; *-rawMonoid to *-rawMonoid₂ + ; +-rawGroup to +-rawGroup₂) + + module + = GroupMorphisms +-rawGroup₁ +-rawGroup₂ + module * = MonoidMorphisms *-rawMonoid₁ *-rawMonoid₂ + + open MorphismDefinitions A B _≈₂_ + open SemiringMorphisms rawSemiring₁ rawSemiring₂ + + + record IsRingHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isSemiringHomomorphism : IsSemiringHomomorphism ⟦_⟧ + -‿homo : Homomorphic₁ ⟦_⟧ -₁_ -₂_ + + open IsSemiringHomomorphism isSemiringHomomorphism public + + +-isGroupHomomorphism : +.IsGroupHomomorphism ⟦_⟧ + +-isGroupHomomorphism = record + { isMonoidHomomorphism = +-isMonoidHomomorphism + ; ⁻¹-homo = -‿homo + } + + record IsRingMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isRingHomomorphism : IsRingHomomorphism ⟦_⟧ + injective : Injective _≈₁_ _≈₂_ ⟦_⟧ + + open IsRingHomomorphism isRingHomomorphism public + + isSemiringMonomorphism : IsSemiringMonomorphism ⟦_⟧ + isSemiringMonomorphism = record + { isSemiringHomomorphism = isSemiringHomomorphism + ; injective = injective + } + + +-isGroupMonomorphism : +.IsGroupMonomorphism ⟦_⟧ + +-isGroupMonomorphism = record + { isGroupHomomorphism = +-isGroupHomomorphism + ; injective = injective + } + + open +.IsGroupMonomorphism +-isGroupMonomorphism + using (isRelMonomorphism) + renaming ( isMagmaMonomorphism to +-isMagmaMonomorphism + ; isMonoidMonomorphism to +-isMonoidMonomorphism + ) + + *-isMonoidMonomorphism : *.IsMonoidMonomorphism ⟦_⟧ + *-isMonoidMonomorphism = record + { isMonoidHomomorphism = *-isMonoidHomomorphism + ; injective = injective + } + + open *.IsMonoidMonomorphism *-isMonoidMonomorphism public + using () + renaming (isMagmaMonomorphism to *-isMagmaMonomorphism) + + + record IsRingIsomorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + isRingMonomorphism : IsRingMonomorphism ⟦_⟧ + surjective : Surjective _≈₁_ _≈₂_ ⟦_⟧ + + open IsRingMonomorphism isRingMonomorphism public + + isSemiringIsomorphism : IsSemiringIsomorphism ⟦_⟧ + isSemiringIsomorphism = record + { isSemiringMonomorphism = isSemiringMonomorphism + ; surjective = surjective + } + + +-isGroupIsomorphism : +.IsGroupIsomorphism ⟦_⟧ + +-isGroupIsomorphism = record + { isGroupMonomorphism = +-isGroupMonomorphism + ; surjective = surjective + } + + open +.IsGroupIsomorphism +-isGroupIsomorphism + using (isRelIsomorphism) + renaming ( isMagmaIsomorphism to +-isMagmaIsomorphism + ; isMonoidIsomorphism to +-isMonoidIsomorphisn + ) + + *-isMonoidIsomorphism : *.IsMonoidIsomorphism ⟦_⟧ + *-isMonoidIsomorphism = record + { isMonoidMonomorphism = *-isMonoidMonomorphism + ; surjective = surjective + } + + open *.IsMonoidIsomorphism *-isMonoidIsomorphism public + using () + renaming (isMagmaIsomorphism to *-isMagmaIsomorphisn) + +------------------------------------------------------------------------ +-- Morphisms over quasigroup-like structures +------------------------------------------------------------------------ + +module QuasigroupMorphisms (Q₁ : RawQuasigroup a ℓ₁) (Q₂ : RawQuasigroup b ℓ₂) where + + open RawQuasigroup Q₁ renaming (Carrier to A; ∙-rawMagma to ∙-rawMagma₁; + \\-rawMagma to \\-rawMagma₁; //-rawMagma to //-rawMagma₁; + _≈_ to _≈₁_; _∙_ to _∙₁_; _\\_ to _\\₁_; _//_ to _//₁_) + open RawQuasigroup Q₂ renaming (Carrier to B; ∙-rawMagma to ∙-rawMagma₂; + \\-rawMagma to \\-rawMagma₂; //-rawMagma to //-rawMagma₂; + _≈_ to _≈₂_; _∙_ to _∙₂_; _\\_ to _\\₂_; _//_ to _//₂_) + + module ∙ = MagmaMorphisms ∙-rawMagma₁ ∙-rawMagma₂ + module \\ = MagmaMorphisms \\-rawMagma₁ \\-rawMagma₂ + module // = MagmaMorphisms //-rawMagma₁ //-rawMagma₂ + + open MorphismDefinitions A B _≈₂_ + + record IsQuasigroupHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isRelHomomorphism : IsRelHomomorphism _≈₁_ _≈₂_ ⟦_⟧ + ∙-homo : Homomorphic₂ ⟦_⟧ _∙₁_ _∙₂_ + \\-homo : Homomorphic₂ ⟦_⟧ _\\₁_ _\\₂_ + //-homo : Homomorphic₂ ⟦_⟧ _//₁_ _//₂_ + + open IsRelHomomorphism isRelHomomorphism public + renaming (cong to ⟦⟧-cong) + + ∙-isMagmaHomomorphism : ∙.IsMagmaHomomorphism ⟦_⟧ + ∙-isMagmaHomomorphism = record + { isRelHomomorphism = isRelHomomorphism + ; homo = ∙-homo + } + + \\-isMagmaHomomorphism : \\.IsMagmaHomomorphism ⟦_⟧ + \\-isMagmaHomomorphism = record + { isRelHomomorphism = isRelHomomorphism + ; homo = \\-homo + } + + //-isMagmaHomomorphism : //.IsMagmaHomomorphism ⟦_⟧ + //-isMagmaHomomorphism = record + { isRelHomomorphism = isRelHomomorphism + ; homo = //-homo + } + + record IsQuasigroupMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isQuasigroupHomomorphism : IsQuasigroupHomomorphism ⟦_⟧ + injective : Injective _≈₁_ _≈₂_ ⟦_⟧ + + open IsQuasigroupHomomorphism isQuasigroupHomomorphism public + + + ∙-isMagmaMonomorphism : ∙.IsMagmaMonomorphism ⟦_⟧ + ∙-isMagmaMonomorphism = record + { isMagmaHomomorphism = ∙-isMagmaHomomorphism + ; injective = injective + } + + \\-isMagmaMonomorphism : \\.IsMagmaMonomorphism ⟦_⟧ + \\-isMagmaMonomorphism = record + { isMagmaHomomorphism = \\-isMagmaHomomorphism + ; injective = injective + } + + //-isMagmaMonomorphism : //.IsMagmaMonomorphism ⟦_⟧ + //-isMagmaMonomorphism = record + { isMagmaHomomorphism = //-isMagmaHomomorphism + ; injective = injective + } + + open //.IsMagmaMonomorphism //-isMagmaMonomorphism public + using (isRelMonomorphism) + + + record IsQuasigroupIsomorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + isQuasigroupMonomorphism : IsQuasigroupMonomorphism ⟦_⟧ + surjective : Surjective _≈₁_ _≈₂_ ⟦_⟧ + + open IsQuasigroupMonomorphism isQuasigroupMonomorphism public + + ∙-isMagmaIsomorphism : ∙.IsMagmaIsomorphism ⟦_⟧ + ∙-isMagmaIsomorphism = record + { isMagmaMonomorphism = ∙-isMagmaMonomorphism + ; surjective = surjective + } + + \\-isMagmaIsomorphism : \\.IsMagmaIsomorphism ⟦_⟧ + \\-isMagmaIsomorphism = record + { isMagmaMonomorphism = \\-isMagmaMonomorphism + ; surjective = surjective + } + + //-isMagmaIsomorphism : //.IsMagmaIsomorphism ⟦_⟧ + //-isMagmaIsomorphism = record + { isMagmaMonomorphism = //-isMagmaMonomorphism + ; surjective = surjective + } + + open //.IsMagmaIsomorphism //-isMagmaIsomorphism public + using (isRelIsomorphism) + +------------------------------------------------------------------------ +-- Morphisms over loop-like structures +------------------------------------------------------------------------ + +module LoopMorphisms (L₁ : RawLoop a ℓ₁) (L₂ : RawLoop b ℓ₂) where + + open RawLoop L₁ renaming (Carrier to A; ∙-rawMagma to ∙-rawMagma₁; + \\-rawMagma to \\-rawMagma₁; //-rawMagma to //-rawMagma₁; + _≈_ to _≈₁_; _∙_ to _∙₁_; _\\_ to _\\₁_; _//_ to _//₁_; ε to ε₁) + open RawLoop L₂ renaming (Carrier to B; ∙-rawMagma to ∙-rawMagma₂; + \\-rawMagma to \\-rawMagma₂; //-rawMagma to //-rawMagma₂; + _≈_ to _≈₂_; _∙_ to _∙₂_; _\\_ to _\\₂_; _//_ to _//₂_ ; ε to ε₂) + open MorphismDefinitions A B _≈₂_ + + open QuasigroupMorphisms (RawLoop.rawQuasigroup L₁) (RawLoop.rawQuasigroup L₂) + + record IsLoopHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isQuasigroupHomomorphism : IsQuasigroupHomomorphism ⟦_⟧ + ε-homo : Homomorphic₀ ⟦_⟧ ε₁ ε₂ + + open IsQuasigroupHomomorphism isQuasigroupHomomorphism public + + record IsLoopMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isLoopHomomorphism : IsLoopHomomorphism ⟦_⟧ + injective : Injective _≈₁_ _≈₂_ ⟦_⟧ + + open IsLoopHomomorphism isLoopHomomorphism public + + record IsLoopIsomorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + isLoopMonomorphism : IsLoopMonomorphism ⟦_⟧ + surjective : Surjective _≈₁_ _≈₂_ ⟦_⟧ + + open IsLoopMonomorphism isLoopMonomorphism public + +------------------------------------------------------------------------ +-- Morphisms over Kleene algebra structures +------------------------------------------------------------------------ +module KleeneAlgebraMorphisms (R₁ : RawKleeneAlgebra a ℓ₁) (R₂ : RawKleeneAlgebra b ℓ₂) where + + open RawKleeneAlgebra R₁ renaming + ( Carrier to A; _≈_ to _≈₁_ + ; _⋆ to _⋆₁ + ; rawSemiring to rawSemiring₁ + ) + + open RawKleeneAlgebra R₂ renaming + ( Carrier to B; _≈_ to _≈₂_ + ; _⋆ to _⋆₂ + ; rawSemiring to rawSemiring₂ + ) + + open MorphismDefinitions A B _≈₂_ + open SemiringMorphisms rawSemiring₁ rawSemiring₂ + + record IsKleeneAlgebraHomomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isSemiringHomomorphism : IsSemiringHomomorphism ⟦_⟧ + ⋆-homo : Homomorphic₁ ⟦_⟧ _⋆₁ _⋆₂ + + open IsSemiringHomomorphism isSemiringHomomorphism public + + record IsKleeneAlgebraMonomorphism (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isKleeneAlgebraHomomorphism : IsKleeneAlgebraHomomorphism ⟦_⟧ + injective : Injective _≈₁_ _≈₂_ ⟦_⟧ + + open IsKleeneAlgebraHomomorphism isKleeneAlgebraHomomorphism public + + record IsKleeneAlgebraIsomorphism (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + isKleeneAlgebraMonomorphism : IsKleeneAlgebraMonomorphism ⟦_⟧ + surjective : Surjective _≈₁_ _≈₂_ ⟦_⟧ + + open IsKleeneAlgebraMonomorphism isKleeneAlgebraMonomorphism public + +------------------------------------------------------------------------ +-- Re-export contents of modules publicly + +open MagmaMorphisms public +open MonoidMorphisms public +open GroupMorphisms public +open NearSemiringMorphisms public +open SemiringMorphisms public +open RingWithoutOneMorphisms public +open RingMorphisms public +open QuasigroupMorphisms public +open LoopMorphisms public +open KleeneAlgebraMorphisms public \ No newline at end of file diff --git a/Algebra.Morphism.html b/Algebra.Morphism.html index d3240cfc..711bd3ee 100644 --- a/Algebra.Morphism.html +++ b/Algebra.Morphism.html @@ -12,200 +12,200 @@ import Algebra.Morphism.Definitions as MorphismDefinitions open import Algebra import Algebra.Properties.Group as GroupP -open import Function hiding (Morphism) -open import Level -open import Relation.Binary -import Relation.Binary.Reasoning.Setoid as EqR +open import Function.Base +open import Level +open import Relation.Binary.Core using (Rel; _Preserves_⟶_) +import Relation.Binary.Reasoning.Setoid as EqR -private - variable - a b ℓ₁ ℓ₂ : Level - A : Set a - B : Set b +private + variable + a b ℓ₁ ℓ₂ : Level + A : Set a + B : Set b ------------------------------------------------------------------------- --- Re-export +------------------------------------------------------------------------ +-- Re-export -module Definitions {a b ℓ₁} (A : Set a) (B : Set b) (_≈_ : Rel B ℓ₁) where - open MorphismDefinitions A B _≈_ public +module Definitions {a b ℓ₁} (A : Set a) (B : Set b) (_≈_ : Rel B ℓ₁) where + open MorphismDefinitions A B _≈_ public -open import Algebra.Morphism.Structures public +open import Algebra.Morphism.Structures public ------------------------------------------------------------------------- --- DEPRECATED ------------------------------------------------------------------------- --- Please use the new definitions re-exported from --- `Algebra.Morphism.Structures` as continuing support for the below is --- no guaranteed. +------------------------------------------------------------------------ +-- DEPRECATED +------------------------------------------------------------------------ +-- Please use the new definitions re-exported from +-- `Algebra.Morphism.Structures` as continuing support for the below is +-- no guaranteed. --- Version 1.5 +-- Version 1.5 -module _ {c₁ ℓ₁ c₂ ℓ₂} - (From : Semigroup c₁ ℓ₁) - (To : Semigroup c₂ ℓ₂) where +module _ {c₁ ℓ₁ c₂ ℓ₂} + (From : Semigroup c₁ ℓ₁) + (To : Semigroup c₂ ℓ₂) where - private - module F = Semigroup From - module T = Semigroup To - open Definitions F.Carrier T.Carrier T._≈_ + private + module F = Semigroup From + module T = Semigroup To + open Definitions F.Carrier T.Carrier T._≈_ - record IsSemigroupMorphism (⟦_⟧ : Morphism) : - Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where - field - ⟦⟧-cong : ⟦_⟧ Preserves F._≈_ ⟶ T._≈_ - ∙-homo : Homomorphic₂ ⟦_⟧ F._∙_ T._∙_ + record IsSemigroupMorphism (⟦_⟧ : Morphism) : + Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where + field + ⟦⟧-cong : ⟦_⟧ Preserves F._≈_ ⟶ T._≈_ + ∙-homo : Homomorphic₂ ⟦_⟧ F._∙_ T._∙_ - IsSemigroupMorphism-syntax = IsSemigroupMorphism - syntax IsSemigroupMorphism-syntax From To F = F Is From -Semigroup⟶ To + IsSemigroupMorphism-syntax = IsSemigroupMorphism + syntax IsSemigroupMorphism-syntax From To F = F Is From -Semigroup⟶ To -module _ {c₁ ℓ₁ c₂ ℓ₂} - (From : Monoid c₁ ℓ₁) - (To : Monoid c₂ ℓ₂) where +module _ {c₁ ℓ₁ c₂ ℓ₂} + (From : Monoid c₁ ℓ₁) + (To : Monoid c₂ ℓ₂) where - private - module F = Monoid From - module T = Monoid To - open Definitions F.Carrier T.Carrier T._≈_ + private + module F = Monoid From + module T = Monoid To + open Definitions F.Carrier T.Carrier T._≈_ - record IsMonoidMorphism (⟦_⟧ : Morphism) : - Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where - field - sm-homo : IsSemigroupMorphism F.semigroup T.semigroup ⟦_⟧ - ε-homo : Homomorphic₀ ⟦_⟧ F.ε T.ε + record IsMonoidMorphism (⟦_⟧ : Morphism) : + Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where + field + sm-homo : IsSemigroupMorphism F.semigroup T.semigroup ⟦_⟧ + ε-homo : Homomorphic₀ ⟦_⟧ F.ε T.ε - open IsSemigroupMorphism sm-homo public + open IsSemigroupMorphism sm-homo public - IsMonoidMorphism-syntax = IsMonoidMorphism - syntax IsMonoidMorphism-syntax From To F = F Is From -Monoid⟶ To + IsMonoidMorphism-syntax = IsMonoidMorphism + syntax IsMonoidMorphism-syntax From To F = F Is From -Monoid⟶ To -module _ {c₁ ℓ₁ c₂ ℓ₂} - (From : CommutativeMonoid c₁ ℓ₁) - (To : CommutativeMonoid c₂ ℓ₂) where +module _ {c₁ ℓ₁ c₂ ℓ₂} + (From : CommutativeMonoid c₁ ℓ₁) + (To : CommutativeMonoid c₂ ℓ₂) where - private - module F = CommutativeMonoid From - module T = CommutativeMonoid To - open Definitions F.Carrier T.Carrier T._≈_ + private + module F = CommutativeMonoid From + module T = CommutativeMonoid To + open Definitions F.Carrier T.Carrier T._≈_ - record IsCommutativeMonoidMorphism (⟦_⟧ : Morphism) : - Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where - field - mn-homo : IsMonoidMorphism F.monoid T.monoid ⟦_⟧ + record IsCommutativeMonoidMorphism (⟦_⟧ : Morphism) : + Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where + field + mn-homo : IsMonoidMorphism F.monoid T.monoid ⟦_⟧ - open IsMonoidMorphism mn-homo public + open IsMonoidMorphism mn-homo public - IsCommutativeMonoidMorphism-syntax = IsCommutativeMonoidMorphism - syntax IsCommutativeMonoidMorphism-syntax From To F = F Is From -CommutativeMonoid⟶ To + IsCommutativeMonoidMorphism-syntax = IsCommutativeMonoidMorphism + syntax IsCommutativeMonoidMorphism-syntax From To F = F Is From -CommutativeMonoid⟶ To -module _ {c₁ ℓ₁ c₂ ℓ₂} - (From : IdempotentCommutativeMonoid c₁ ℓ₁) - (To : IdempotentCommutativeMonoid c₂ ℓ₂) where +module _ {c₁ ℓ₁ c₂ ℓ₂} + (From : IdempotentCommutativeMonoid c₁ ℓ₁) + (To : IdempotentCommutativeMonoid c₂ ℓ₂) where - private - module F = IdempotentCommutativeMonoid From - module T = IdempotentCommutativeMonoid To - open Definitions F.Carrier T.Carrier T._≈_ + private + module F = IdempotentCommutativeMonoid From + module T = IdempotentCommutativeMonoid To + open Definitions F.Carrier T.Carrier T._≈_ - record IsIdempotentCommutativeMonoidMorphism (⟦_⟧ : Morphism) : - Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where - field - mn-homo : IsMonoidMorphism F.monoid T.monoid ⟦_⟧ + record IsIdempotentCommutativeMonoidMorphism (⟦_⟧ : Morphism) : + Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where + field + mn-homo : IsMonoidMorphism F.monoid T.monoid ⟦_⟧ - open IsMonoidMorphism mn-homo public + open IsMonoidMorphism mn-homo public - isCommutativeMonoidMorphism : - IsCommutativeMonoidMorphism F.commutativeMonoid T.commutativeMonoid ⟦_⟧ - isCommutativeMonoidMorphism = record { mn-homo = mn-homo } + isCommutativeMonoidMorphism : + IsCommutativeMonoidMorphism F.commutativeMonoid T.commutativeMonoid ⟦_⟧ + isCommutativeMonoidMorphism = record { mn-homo = mn-homo } - IsIdempotentCommutativeMonoidMorphism-syntax = IsIdempotentCommutativeMonoidMorphism - syntax IsIdempotentCommutativeMonoidMorphism-syntax From To F = F Is From -IdempotentCommutativeMonoid⟶ To + IsIdempotentCommutativeMonoidMorphism-syntax = IsIdempotentCommutativeMonoidMorphism + syntax IsIdempotentCommutativeMonoidMorphism-syntax From To F = F Is From -IdempotentCommutativeMonoid⟶ To -module _ {c₁ ℓ₁ c₂ ℓ₂} - (From : Group c₁ ℓ₁) - (To : Group c₂ ℓ₂) where +module _ {c₁ ℓ₁ c₂ ℓ₂} + (From : Group c₁ ℓ₁) + (To : Group c₂ ℓ₂) where - private - module F = Group From - module T = Group To - open Definitions F.Carrier T.Carrier T._≈_ + private + module F = Group From + module T = Group To + open Definitions F.Carrier T.Carrier T._≈_ - record IsGroupMorphism (⟦_⟧ : Morphism) : - Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where - field - mn-homo : IsMonoidMorphism F.monoid T.monoid ⟦_⟧ - - open IsMonoidMorphism mn-homo public + record IsGroupMorphism (⟦_⟧ : Morphism) : + Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where + field + mn-homo : IsMonoidMorphism F.monoid T.monoid ⟦_⟧ + + open IsMonoidMorphism mn-homo public - ⁻¹-homo : Homomorphic₁ ⟦_⟧ F._⁻¹ T._⁻¹ - ⁻¹-homo x = let open EqR T.setoid in T.uniqueˡ-⁻¹ ⟦ x F.⁻¹ ⟧ ⟦ x ⟧ $ begin - ⟦ x F.⁻¹ ⟧ T.∙ ⟦ x ⟧ ≈⟨ T.sym (∙-homo (x F.⁻¹) x) ⟩ - ⟦ x F.⁻¹ F.∙ x ⟧ ≈⟨ ⟦⟧-cong (F.inverseˡ x) ⟩ - ⟦ F.ε ⟧ ≈⟨ ε-homo ⟩ - T.ε ∎ + ⁻¹-homo : Homomorphic₁ ⟦_⟧ F._⁻¹ T._⁻¹ + ⁻¹-homo x = let open EqR T.setoid in T.uniqueˡ-⁻¹ ⟦ x F.⁻¹ ⟧ ⟦ x ⟧ $ begin + ⟦ x F.⁻¹ ⟧ T.∙ ⟦ x ⟧ ≈⟨ T.sym (∙-homo (x F.⁻¹) x) ⟩ + ⟦ x F.⁻¹ F.∙ x ⟧ ≈⟨ ⟦⟧-cong (F.inverseˡ x) ⟩ + ⟦ F.ε ⟧ ≈⟨ ε-homo ⟩ + T.ε ∎ - IsGroupMorphism-syntax = IsGroupMorphism - syntax IsGroupMorphism-syntax From To F = F Is From -Group⟶ To - -module _ {c₁ ℓ₁ c₂ ℓ₂} - (From : AbelianGroup c₁ ℓ₁) - (To : AbelianGroup c₂ ℓ₂) where - - private - module F = AbelianGroup From - module T = AbelianGroup To - open Definitions F.Carrier T.Carrier T._≈_ + IsGroupMorphism-syntax = IsGroupMorphism + syntax IsGroupMorphism-syntax From To F = F Is From -Group⟶ To + +module _ {c₁ ℓ₁ c₂ ℓ₂} + (From : AbelianGroup c₁ ℓ₁) + (To : AbelianGroup c₂ ℓ₂) where + + private + module F = AbelianGroup From + module T = AbelianGroup To + open Definitions F.Carrier T.Carrier T._≈_ - record IsAbelianGroupMorphism (⟦_⟧ : Morphism) : - Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where - field - gp-homo : IsGroupMorphism F.group T.group ⟦_⟧ + record IsAbelianGroupMorphism (⟦_⟧ : Morphism) : + Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where + field + gp-homo : IsGroupMorphism F.group T.group ⟦_⟧ - open IsGroupMorphism gp-homo public + open IsGroupMorphism gp-homo public - IsAbelianGroupMorphism-syntax = IsAbelianGroupMorphism - syntax IsAbelianGroupMorphism-syntax From To F = F Is From -AbelianGroup⟶ To + IsAbelianGroupMorphism-syntax = IsAbelianGroupMorphism + syntax IsAbelianGroupMorphism-syntax From To F = F Is From -AbelianGroup⟶ To -module _ {c₁ ℓ₁ c₂ ℓ₂} - (From : Ring c₁ ℓ₁) - (To : Ring c₂ ℓ₂) where +module _ {c₁ ℓ₁ c₂ ℓ₂} + (From : Ring c₁ ℓ₁) + (To : Ring c₂ ℓ₂) where - private - module F = Ring From - module T = Ring To - open Definitions F.Carrier T.Carrier T._≈_ + private + module F = Ring From + module T = Ring To + open Definitions F.Carrier T.Carrier T._≈_ - record IsRingMorphism (⟦_⟧ : Morphism) : - Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where - field - +-abgp-homo : ⟦_⟧ Is F.+-abelianGroup -AbelianGroup⟶ T.+-abelianGroup - *-mn-homo : ⟦_⟧ Is F.*-monoid -Monoid⟶ T.*-monoid + record IsRingMorphism (⟦_⟧ : Morphism) : + Set (c₁ ⊔ ℓ₁ ⊔ c₂ ⊔ ℓ₂) where + field + +-abgp-homo : ⟦_⟧ Is F.+-abelianGroup -AbelianGroup⟶ T.+-abelianGroup + *-mn-homo : ⟦_⟧ Is F.*-monoid -Monoid⟶ T.*-monoid - IsRingMorphism-syntax = IsRingMorphism - syntax IsRingMorphism-syntax From To F = F Is From -Ring⟶ To + IsRingMorphism-syntax = IsRingMorphism + syntax IsRingMorphism-syntax From To F = F Is From -Ring⟶ To -{-# WARNING_ON_USAGE IsSemigroupMorphism -"Warning: IsSemigroupMorphism was deprecated in v1.5. +{-# WARNING_ON_USAGE IsSemigroupMorphism +"Warning: IsSemigroupMorphism was deprecated in v1.5. Please use IsSemigroupHomomorphism instead." -#-} -{-# WARNING_ON_USAGE IsMonoidMorphism -"Warning: IsMonoidMorphism was deprecated in v1.5. +#-} +{-# WARNING_ON_USAGE IsMonoidMorphism +"Warning: IsMonoidMorphism was deprecated in v1.5. Please use IsMonoidHomomorphism instead." -#-} -{-# WARNING_ON_USAGE IsCommutativeMonoidMorphism -"Warning: IsCommutativeMonoidMorphism was deprecated in v1.5. +#-} +{-# WARNING_ON_USAGE IsCommutativeMonoidMorphism +"Warning: IsCommutativeMonoidMorphism was deprecated in v1.5. Please use IsMonoidHomomorphism instead." -#-} -{-# WARNING_ON_USAGE IsIdempotentCommutativeMonoidMorphism -"Warning: IsIdempotentCommutativeMonoidMorphism was deprecated in v1.5. +#-} +{-# WARNING_ON_USAGE IsIdempotentCommutativeMonoidMorphism +"Warning: IsIdempotentCommutativeMonoidMorphism was deprecated in v1.5. Please use IsMonoidHomomorphism instead." -#-} -{-# WARNING_ON_USAGE IsGroupMorphism -"Warning: IsGroupMorphism was deprecated in v1.5. +#-} +{-# WARNING_ON_USAGE IsGroupMorphism +"Warning: IsGroupMorphism was deprecated in v1.5. Please use IsGroupHomomorphism instead." -#-} -{-# WARNING_ON_USAGE IsAbelianGroupMorphism -"Warning: IsAbelianGroupMorphism was deprecated in v1.5. +#-} +{-# WARNING_ON_USAGE IsAbelianGroupMorphism +"Warning: IsAbelianGroupMorphism was deprecated in v1.5. Please use IsGroupHomomorphism instead." -#-} +#-} \ No newline at end of file diff --git a/Algebra.Properties.AbelianGroup.html b/Algebra.Properties.AbelianGroup.html index 24c20afd..3a383b6e 100644 --- a/Algebra.Properties.AbelianGroup.html +++ b/Algebra.Properties.AbelianGroup.html @@ -10,31 +10,31 @@ open import Algebra module Algebra.Properties.AbelianGroup - {a ℓ} (G : AbelianGroup a ℓ) where + {a ℓ} (G : AbelianGroup a ℓ) where -open AbelianGroup G -open import Function -open import Relation.Binary.Reasoning.Setoid setoid +open AbelianGroup G +open import Function.Base using (_$_) +open import Relation.Binary.Reasoning.Setoid setoid ------------------------------------------------------------------------- --- Publicly re-export group properties +------------------------------------------------------------------------ +-- Publicly re-export group properties -open import Algebra.Properties.Group group public +open import Algebra.Properties.Group group public ------------------------------------------------------------------------- --- Properties of abelian groups +------------------------------------------------------------------------ +-- Properties of abelian groups -xyx⁻¹≈y : ∀ x y → x ∙ y ∙ x ⁻¹ ≈ y -xyx⁻¹≈y x y = begin - x ∙ y ∙ x ⁻¹ ≈⟨ ∙-congʳ $ comm _ _ ⟩ - y ∙ x ∙ x ⁻¹ ≈⟨ assoc _ _ _ ⟩ - y ∙ (x ∙ x ⁻¹) ≈⟨ ∙-congˡ $ inverseʳ _ ⟩ - y ∙ ε ≈⟨ identityʳ _ ⟩ - y ∎ +xyx⁻¹≈y : ∀ x y → x ∙ y ∙ x ⁻¹ ≈ y +xyx⁻¹≈y x y = begin + x ∙ y ∙ x ⁻¹ ≈⟨ ∙-congʳ $ comm _ _ ⟩ + y ∙ x ∙ x ⁻¹ ≈⟨ assoc _ _ _ ⟩ + y ∙ (x ∙ x ⁻¹) ≈⟨ ∙-congˡ $ inverseʳ _ ⟩ + y ∙ ε ≈⟨ identityʳ _ ⟩ + y ∎ -⁻¹-∙-comm : ∀ x y → x ⁻¹ ∙ y ⁻¹ ≈ (x ∙ y) ⁻¹ -⁻¹-∙-comm x y = begin - x ⁻¹ ∙ y ⁻¹ ≈˘⟨ ⁻¹-anti-homo-∙ y x ⟩ - (y ∙ x) ⁻¹ ≈⟨ ⁻¹-cong $ comm y x ⟩ - (x ∙ y) ⁻¹ ∎ +⁻¹-∙-comm : ∀ x y → x ⁻¹ ∙ y ⁻¹ ≈ (x ∙ y) ⁻¹ +⁻¹-∙-comm x y = begin + x ⁻¹ ∙ y ⁻¹ ≈⟨ ⁻¹-anti-homo-∙ y x ⟨ + (y ∙ x) ⁻¹ ≈⟨ ⁻¹-cong $ comm y x ⟩ + (x ∙ y) ⁻¹ ∎ \ No newline at end of file diff --git a/Algebra.Properties.CommutativeSemigroup.html b/Algebra.Properties.CommutativeSemigroup.html index 7b7f8ec8..cc9ae10e 100644 --- a/Algebra.Properties.CommutativeSemigroup.html +++ b/Algebra.Properties.CommutativeSemigroup.html @@ -7,170 +7,170 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Algebra using (CommutativeSemigroup) +open import Algebra using (CommutativeSemigroup) module Algebra.Properties.CommutativeSemigroup - {a ℓ} (CS : CommutativeSemigroup a ℓ) + {a ℓ} (CS : CommutativeSemigroup a ℓ) where -open CommutativeSemigroup CS +open CommutativeSemigroup CS -open import Algebra.Definitions _≈_ -open import Relation.Binary.Reasoning.Setoid setoid -open import Data.Product +open import Algebra.Definitions _≈_ +open import Relation.Binary.Reasoning.Setoid setoid +open import Data.Product.Base using (_,_) ------------------------------------------------------------------------------- --- Re-export the contents of semigroup +------------------------------------------------------------------------ +-- Re-export the contents of semigroup -open import Algebra.Properties.Semigroup semigroup public +open import Algebra.Properties.Semigroup semigroup public ------------------------------------------------------------------------------- --- Properties +------------------------------------------------------------------------ +-- Properties -interchange : Interchangable _∙_ _∙_ -interchange a b c d = begin - (a ∙ b) ∙ (c ∙ d) ≈⟨ assoc a b (c ∙ d) ⟩ - a ∙ (b ∙ (c ∙ d)) ≈˘⟨ ∙-congˡ (assoc b c d) ⟩ - a ∙ ((b ∙ c) ∙ d) ≈⟨ ∙-congˡ (∙-congʳ (comm b c)) ⟩ - a ∙ ((c ∙ b) ∙ d) ≈⟨ ∙-congˡ (assoc c b d) ⟩ - a ∙ (c ∙ (b ∙ d)) ≈˘⟨ assoc a c (b ∙ d) ⟩ - (a ∙ c) ∙ (b ∙ d) ∎ +interchange : Interchangable _∙_ _∙_ +interchange a b c d = begin + (a ∙ b) ∙ (c ∙ d) ≈⟨ assoc a b (c ∙ d) ⟩ + a ∙ (b ∙ (c ∙ d)) ≈⟨ ∙-congˡ (assoc b c d) ⟨ + a ∙ ((b ∙ c) ∙ d) ≈⟨ ∙-congˡ (∙-congʳ (comm b c)) ⟩ + a ∙ ((c ∙ b) ∙ d) ≈⟨ ∙-congˡ (assoc c b d) ⟩ + a ∙ (c ∙ (b ∙ d)) ≈⟨ assoc a c (b ∙ d) ⟨ + (a ∙ c) ∙ (b ∙ d) ∎ ------------------------------------------------------------------------------- --- Permutation laws for _∙_ for three factors. +------------------------------------------------------------------------ +-- Permutation laws for _∙_ for three factors. --- There are five nontrivial permutations. +-- There are five nontrivial permutations. ------------------------------------------------------------------------------- --- Partitions (1,1). +------------------------------------------------------------------------ +-- Partitions (1,1). -x∙yz≈y∙xz : ∀ x y z → x ∙ (y ∙ z) ≈ y ∙ (x ∙ z) -x∙yz≈y∙xz x y z = begin - x ∙ (y ∙ z) ≈⟨ sym (assoc x y z) ⟩ - (x ∙ y) ∙ z ≈⟨ ∙-congʳ (comm x y) ⟩ - (y ∙ x) ∙ z ≈⟨ assoc y x z ⟩ - y ∙ (x ∙ z) ∎ +x∙yz≈y∙xz : ∀ x y z → x ∙ (y ∙ z) ≈ y ∙ (x ∙ z) +x∙yz≈y∙xz x y z = begin + x ∙ (y ∙ z) ≈⟨ sym (assoc x y z) ⟩ + (x ∙ y) ∙ z ≈⟨ ∙-congʳ (comm x y) ⟩ + (y ∙ x) ∙ z ≈⟨ assoc y x z ⟩ + y ∙ (x ∙ z) ∎ -x∙yz≈z∙yx : ∀ x y z → x ∙ (y ∙ z) ≈ z ∙ (y ∙ x) -x∙yz≈z∙yx x y z = begin - x ∙ (y ∙ z) ≈⟨ ∙-congˡ (comm y z) ⟩ - x ∙ (z ∙ y) ≈⟨ x∙yz≈y∙xz x z y ⟩ - z ∙ (x ∙ y) ≈⟨ ∙-congˡ (comm x y) ⟩ - z ∙ (y ∙ x) ∎ +x∙yz≈z∙yx : ∀ x y z → x ∙ (y ∙ z) ≈ z ∙ (y ∙ x) +x∙yz≈z∙yx x y z = begin + x ∙ (y ∙ z) ≈⟨ ∙-congˡ (comm y z) ⟩ + x ∙ (z ∙ y) ≈⟨ x∙yz≈y∙xz x z y ⟩ + z ∙ (x ∙ y) ≈⟨ ∙-congˡ (comm x y) ⟩ + z ∙ (y ∙ x) ∎ -x∙yz≈x∙zy : ∀ x y z → x ∙ (y ∙ z) ≈ x ∙ (z ∙ y) -x∙yz≈x∙zy _ y z = ∙-congˡ (comm y z) +x∙yz≈x∙zy : ∀ x y z → x ∙ (y ∙ z) ≈ x ∙ (z ∙ y) +x∙yz≈x∙zy _ y z = ∙-congˡ (comm y z) -x∙yz≈y∙zx : ∀ x y z → x ∙ (y ∙ z) ≈ y ∙ (z ∙ x) -x∙yz≈y∙zx x y z = begin - x ∙ (y ∙ z) ≈⟨ comm x _ ⟩ - (y ∙ z) ∙ x ≈⟨ assoc y z x ⟩ - y ∙ (z ∙ x) ∎ +x∙yz≈y∙zx : ∀ x y z → x ∙ (y ∙ z) ≈ y ∙ (z ∙ x) +x∙yz≈y∙zx x y z = begin + x ∙ (y ∙ z) ≈⟨ comm x _ ⟩ + (y ∙ z) ∙ x ≈⟨ assoc y z x ⟩ + y ∙ (z ∙ x) ∎ -x∙yz≈z∙xy : ∀ x y z → x ∙ (y ∙ z) ≈ z ∙ (x ∙ y) -x∙yz≈z∙xy x y z = begin - x ∙ (y ∙ z) ≈⟨ sym (assoc x y z) ⟩ - (x ∙ y) ∙ z ≈⟨ comm _ z ⟩ - z ∙ (x ∙ y) ∎ +x∙yz≈z∙xy : ∀ x y z → x ∙ (y ∙ z) ≈ z ∙ (x ∙ y) +x∙yz≈z∙xy x y z = begin + x ∙ (y ∙ z) ≈⟨ sym (assoc x y z) ⟩ + (x ∙ y) ∙ z ≈⟨ comm _ z ⟩ + z ∙ (x ∙ y) ∎ ------------------------------------------------------------------------------- --- Partitions (1,2). +------------------------------------------------------------------------ +-- Partitions (1,2). --- These permutation laws are proved by composing the proofs for --- partitions (1,1) with \p → trans p (sym (assoc _ _ _)). +-- These permutation laws are proved by composing the proofs for +-- partitions (1,1) with \p → trans p (sym (assoc _ _ _)). -x∙yz≈yx∙z : ∀ x y z → x ∙ (y ∙ z) ≈ (y ∙ x) ∙ z -x∙yz≈yx∙z x y z = trans (x∙yz≈y∙xz x y z) (sym (assoc y x z)) +x∙yz≈yx∙z : ∀ x y z → x ∙ (y ∙ z) ≈ (y ∙ x) ∙ z +x∙yz≈yx∙z x y z = trans (x∙yz≈y∙xz x y z) (sym (assoc y x z)) -x∙yz≈zy∙x : ∀ x y z → x ∙ (y ∙ z) ≈ (z ∙ y) ∙ x -x∙yz≈zy∙x x y z = trans (x∙yz≈z∙yx x y z) (sym (assoc z y x)) +x∙yz≈zy∙x : ∀ x y z → x ∙ (y ∙ z) ≈ (z ∙ y) ∙ x +x∙yz≈zy∙x x y z = trans (x∙yz≈z∙yx x y z) (sym (assoc z y x)) -x∙yz≈xz∙y : ∀ x y z → x ∙ (y ∙ z) ≈ (x ∙ z) ∙ y -x∙yz≈xz∙y x y z = trans (x∙yz≈x∙zy x y z) (sym (assoc x z y)) +x∙yz≈xz∙y : ∀ x y z → x ∙ (y ∙ z) ≈ (x ∙ z) ∙ y +x∙yz≈xz∙y x y z = trans (x∙yz≈x∙zy x y z) (sym (assoc x z y)) -x∙yz≈yz∙x : ∀ x y z → x ∙ (y ∙ z) ≈ (y ∙ z) ∙ x -x∙yz≈yz∙x x y z = trans (x∙yz≈y∙zx _ _ _) (sym (assoc y z x)) +x∙yz≈yz∙x : ∀ x y z → x ∙ (y ∙ z) ≈ (y ∙ z) ∙ x +x∙yz≈yz∙x x y z = trans (x∙yz≈y∙zx _ _ _) (sym (assoc y z x)) -x∙yz≈zx∙y : ∀ x y z → x ∙ (y ∙ z) ≈ (z ∙ x) ∙ y -x∙yz≈zx∙y x y z = trans (x∙yz≈z∙xy x y z) (sym (assoc z x y)) +x∙yz≈zx∙y : ∀ x y z → x ∙ (y ∙ z) ≈ (z ∙ x) ∙ y +x∙yz≈zx∙y x y z = trans (x∙yz≈z∙xy x y z) (sym (assoc z x y)) ------------------------------------------------------------------------------- --- Partitions (2,1). +------------------------------------------------------------------------ +-- Partitions (2,1). --- Their laws are proved by composing proofs for partitions (1,1) with --- trans (assoc x y z). +-- Their laws are proved by composing proofs for partitions (1,1) with +-- trans (assoc x y z). -xy∙z≈y∙xz : ∀ x y z → (x ∙ y) ∙ z ≈ y ∙ (x ∙ z) -xy∙z≈y∙xz x y z = trans (assoc x y z) (x∙yz≈y∙xz x y z) +xy∙z≈y∙xz : ∀ x y z → (x ∙ y) ∙ z ≈ y ∙ (x ∙ z) +xy∙z≈y∙xz x y z = trans (assoc x y z) (x∙yz≈y∙xz x y z) -xy∙z≈z∙yx : ∀ x y z → (x ∙ y) ∙ z ≈ z ∙ (y ∙ x) -xy∙z≈z∙yx x y z = trans (assoc x y z) (x∙yz≈z∙yx x y z) +xy∙z≈z∙yx : ∀ x y z → (x ∙ y) ∙ z ≈ z ∙ (y ∙ x) +xy∙z≈z∙yx x y z = trans (assoc x y z) (x∙yz≈z∙yx x y z) -xy∙z≈x∙zy : ∀ x y z → (x ∙ y) ∙ z ≈ x ∙ (z ∙ y) -xy∙z≈x∙zy x y z = trans (assoc x y z) (x∙yz≈x∙zy x y z) +xy∙z≈x∙zy : ∀ x y z → (x ∙ y) ∙ z ≈ x ∙ (z ∙ y) +xy∙z≈x∙zy x y z = trans (assoc x y z) (x∙yz≈x∙zy x y z) -xy∙z≈y∙zx : ∀ x y z → (x ∙ y) ∙ z ≈ y ∙ (z ∙ x) -xy∙z≈y∙zx x y z = trans (assoc x y z) (x∙yz≈y∙zx x y z) +xy∙z≈y∙zx : ∀ x y z → (x ∙ y) ∙ z ≈ y ∙ (z ∙ x) +xy∙z≈y∙zx x y z = trans (assoc x y z) (x∙yz≈y∙zx x y z) -xy∙z≈z∙xy : ∀ x y z → (x ∙ y) ∙ z ≈ z ∙ (x ∙ y) -xy∙z≈z∙xy x y z = trans (assoc x y z) (x∙yz≈z∙xy x y z) +xy∙z≈z∙xy : ∀ x y z → (x ∙ y) ∙ z ≈ z ∙ (x ∙ y) +xy∙z≈z∙xy x y z = trans (assoc x y z) (x∙yz≈z∙xy x y z) ------------------------------------------------------------------------------- --- Partitions (2,2). +------------------------------------------------------------------------ +-- Partitions (2,2). --- These proofs are by composing with the proofs for (2,1). +-- These proofs are by composing with the proofs for (2,1). -xy∙z≈yx∙z : ∀ x y z → (x ∙ y) ∙ z ≈ (y ∙ x) ∙ z -xy∙z≈yx∙z x y z = trans (xy∙z≈y∙xz _ _ _) (sym (assoc y x z)) +xy∙z≈yx∙z : ∀ x y z → (x ∙ y) ∙ z ≈ (y ∙ x) ∙ z +xy∙z≈yx∙z x y z = trans (xy∙z≈y∙xz _ _ _) (sym (assoc y x z)) -xy∙z≈zy∙x : ∀ x y z → (x ∙ y) ∙ z ≈ (z ∙ y) ∙ x -xy∙z≈zy∙x x y z = trans (xy∙z≈z∙yx x y z) (sym (assoc z y x)) +xy∙z≈zy∙x : ∀ x y z → (x ∙ y) ∙ z ≈ (z ∙ y) ∙ x +xy∙z≈zy∙x x y z = trans (xy∙z≈z∙yx x y z) (sym (assoc z y x)) -xy∙z≈xz∙y : ∀ x y z → (x ∙ y) ∙ z ≈ (x ∙ z) ∙ y -xy∙z≈xz∙y x y z = trans (xy∙z≈x∙zy x y z) (sym (assoc x z y)) +xy∙z≈xz∙y : ∀ x y z → (x ∙ y) ∙ z ≈ (x ∙ z) ∙ y +xy∙z≈xz∙y x y z = trans (xy∙z≈x∙zy x y z) (sym (assoc x z y)) -xy∙z≈yz∙x : ∀ x y z → (x ∙ y) ∙ z ≈ (y ∙ z) ∙ x -xy∙z≈yz∙x x y z = trans (xy∙z≈y∙zx x y z) (sym (assoc y z x)) +xy∙z≈yz∙x : ∀ x y z → (x ∙ y) ∙ z ≈ (y ∙ z) ∙ x +xy∙z≈yz∙x x y z = trans (xy∙z≈y∙zx x y z) (sym (assoc y z x)) -xy∙z≈zx∙y : ∀ x y z → (x ∙ y) ∙ z ≈ (z ∙ x) ∙ y -xy∙z≈zx∙y x y z = trans (xy∙z≈z∙xy x y z) (sym (assoc z x y)) +xy∙z≈zx∙y : ∀ x y z → (x ∙ y) ∙ z ≈ (z ∙ x) ∙ y +xy∙z≈zx∙y x y z = trans (xy∙z≈z∙xy x y z) (sym (assoc z x y)) ------------------------------------------------------------------------------- --- commutative semigroup has Jordan identity +------------------------------------------------------------------------ +-- commutative semigroup has Jordan identity -xy∙xx≈x∙yxx : ∀ x y → (x ∙ y) ∙ (x ∙ x) ≈ x ∙ (y ∙ (x ∙ x)) -xy∙xx≈x∙yxx x y = assoc x y ((x ∙ x)) +xy∙xx≈x∙yxx : ∀ x y → (x ∙ y) ∙ (x ∙ x) ≈ x ∙ (y ∙ (x ∙ x)) +xy∙xx≈x∙yxx x y = assoc x y ((x ∙ x)) ------------------------------------------------------------------------------- --- commutative semigroup is left/right/middle semiMedial +------------------------------------------------------------------------ +-- commutative semigroup is left/right/middle semiMedial -semimedialˡ : LeftSemimedial _∙_ -semimedialˡ x y z = begin - (x ∙ x) ∙ (y ∙ z) ≈⟨ assoc x x (y ∙ z) ⟩ - x ∙ (x ∙ (y ∙ z)) ≈⟨ ∙-congˡ (sym (assoc x y z)) ⟩ - x ∙ ((x ∙ y) ∙ z) ≈⟨ ∙-congˡ (∙-congʳ (comm x y)) ⟩ - x ∙ ((y ∙ x) ∙ z) ≈⟨ ∙-congˡ (assoc y x z) ⟩ - x ∙ (y ∙ (x ∙ z)) ≈⟨ sym (assoc x y ((x ∙ z))) ⟩ - (x ∙ y) ∙ (x ∙ z) ∎ +semimedialˡ : LeftSemimedial _∙_ +semimedialˡ x y z = begin + (x ∙ x) ∙ (y ∙ z) ≈⟨ assoc x x (y ∙ z) ⟩ + x ∙ (x ∙ (y ∙ z)) ≈⟨ ∙-congˡ (sym (assoc x y z)) ⟩ + x ∙ ((x ∙ y) ∙ z) ≈⟨ ∙-congˡ (∙-congʳ (comm x y)) ⟩ + x ∙ ((y ∙ x) ∙ z) ≈⟨ ∙-congˡ (assoc y x z) ⟩ + x ∙ (y ∙ (x ∙ z)) ≈⟨ sym (assoc x y ((x ∙ z))) ⟩ + (x ∙ y) ∙ (x ∙ z) ∎ -semimedialʳ : RightSemimedial _∙_ -semimedialʳ x y z = begin - (y ∙ z) ∙ (x ∙ x) ≈⟨ assoc y z (x ∙ x) ⟩ - y ∙ (z ∙ (x ∙ x)) ≈⟨ ∙-congˡ (sym (assoc z x x)) ⟩ - y ∙ ((z ∙ x) ∙ x) ≈⟨ ∙-congˡ (∙-congʳ (comm z x)) ⟩ - y ∙ ((x ∙ z) ∙ x) ≈⟨ ∙-congˡ (assoc x z x) ⟩ - y ∙ (x ∙ (z ∙ x)) ≈⟨ sym (assoc y x ((z ∙ x))) ⟩ - (y ∙ x) ∙ (z ∙ x) ∎ +semimedialʳ : RightSemimedial _∙_ +semimedialʳ x y z = begin + (y ∙ z) ∙ (x ∙ x) ≈⟨ assoc y z (x ∙ x) ⟩ + y ∙ (z ∙ (x ∙ x)) ≈⟨ ∙-congˡ (sym (assoc z x x)) ⟩ + y ∙ ((z ∙ x) ∙ x) ≈⟨ ∙-congˡ (∙-congʳ (comm z x)) ⟩ + y ∙ ((x ∙ z) ∙ x) ≈⟨ ∙-congˡ (assoc x z x) ⟩ + y ∙ (x ∙ (z ∙ x)) ≈⟨ sym (assoc y x ((z ∙ x))) ⟩ + (y ∙ x) ∙ (z ∙ x) ∎ -middleSemimedial : ∀ x y z → (x ∙ y) ∙ (z ∙ x) ≈ (x ∙ z) ∙ (y ∙ x) -middleSemimedial x y z = begin - (x ∙ y) ∙ (z ∙ x) ≈⟨ assoc x y ((z ∙ x)) ⟩ - x ∙ (y ∙ (z ∙ x)) ≈⟨ ∙-congˡ (sym (assoc y z x)) ⟩ - x ∙ ((y ∙ z) ∙ x) ≈⟨ ∙-congˡ (∙-congʳ (comm y z)) ⟩ - x ∙ ((z ∙ y) ∙ x) ≈⟨ ∙-congˡ ( assoc z y x) ⟩ - x ∙ (z ∙ (y ∙ x)) ≈⟨ sym (assoc x z ((y ∙ x))) ⟩ - (x ∙ z) ∙ (y ∙ x) ∎ +middleSemimedial : ∀ x y z → (x ∙ y) ∙ (z ∙ x) ≈ (x ∙ z) ∙ (y ∙ x) +middleSemimedial x y z = begin + (x ∙ y) ∙ (z ∙ x) ≈⟨ assoc x y ((z ∙ x)) ⟩ + x ∙ (y ∙ (z ∙ x)) ≈⟨ ∙-congˡ (sym (assoc y z x)) ⟩ + x ∙ ((y ∙ z) ∙ x) ≈⟨ ∙-congˡ (∙-congʳ (comm y z)) ⟩ + x ∙ ((z ∙ y) ∙ x) ≈⟨ ∙-congˡ ( assoc z y x) ⟩ + x ∙ (z ∙ (y ∙ x)) ≈⟨ sym (assoc x z ((y ∙ x))) ⟩ + (x ∙ z) ∙ (y ∙ x) ∎ -semimedial : Semimedial _∙_ -semimedial = semimedialˡ , semimedialʳ +semimedial : Semimedial _∙_ +semimedial = semimedialˡ , semimedialʳ \ No newline at end of file diff --git a/Algebra.Properties.Group.html b/Algebra.Properties.Group.html index 369258c0..9ca955fe 100644 --- a/Algebra.Properties.Group.html +++ b/Algebra.Properties.Group.html @@ -9,102 +9,102 @@ open import Algebra.Bundles -module Algebra.Properties.Group {g₁ g₂} (G : Group g₁ g₂) where - -open Group G -open import Algebra.Definitions _≈_ -open import Relation.Binary.Reasoning.Setoid setoid -open import Function -open import Data.Product - -ε⁻¹≈ε : ε ⁻¹ ≈ ε -ε⁻¹≈ε = begin - ε ⁻¹ ≈⟨ sym $ identityʳ (ε ⁻¹) ⟩ - ε ⁻¹ ∙ ε ≈⟨ inverseˡ ε ⟩ - ε ∎ - -private - - left-helper : ∀ x y → x ≈ (x ∙ y) ∙ y ⁻¹ - left-helper x y = begin - x ≈⟨ sym (identityʳ x) ⟩ - x ∙ ε ≈⟨ ∙-congˡ $ sym (inverseʳ y) ⟩ - x ∙ (y ∙ y ⁻¹) ≈⟨ sym (assoc x y (y ⁻¹)) ⟩ - (x ∙ y) ∙ y ⁻¹ ∎ - - right-helper : ∀ x y → y ≈ x ⁻¹ ∙ (x ∙ y) - right-helper x y = begin - y ≈⟨ sym (identityˡ y) ⟩ - ε ∙ y ≈⟨ ∙-congʳ $ sym (inverseˡ x) ⟩ - (x ⁻¹ ∙ x) ∙ y ≈⟨ assoc (x ⁻¹) x y ⟩ - x ⁻¹ ∙ (x ∙ y) ∎ - -∙-cancelˡ : LeftCancellative _∙_ -∙-cancelˡ x y z eq = begin - y ≈⟨ right-helper x y ⟩ - x ⁻¹ ∙ (x ∙ y) ≈⟨ ∙-congˡ eq ⟩ - x ⁻¹ ∙ (x ∙ z) ≈˘⟨ right-helper x z ⟩ - z ∎ - -∙-cancelʳ : RightCancellative _∙_ -∙-cancelʳ x y z eq = begin - y ≈⟨ left-helper y x ⟩ - y ∙ x ∙ x ⁻¹ ≈⟨ ∙-congʳ eq ⟩ - z ∙ x ∙ x ⁻¹ ≈˘⟨ left-helper z x ⟩ - z ∎ - -∙-cancel : Cancellative _∙_ -∙-cancel = ∙-cancelˡ , ∙-cancelʳ - -⁻¹-involutive : ∀ x → x ⁻¹ ⁻¹ ≈ x -⁻¹-involutive x = begin - x ⁻¹ ⁻¹ ≈˘⟨ identityʳ _ ⟩ - x ⁻¹ ⁻¹ ∙ ε ≈˘⟨ ∙-congˡ $ inverseˡ _ ⟩ - x ⁻¹ ⁻¹ ∙ (x ⁻¹ ∙ x) ≈˘⟨ right-helper (x ⁻¹) x ⟩ - x ∎ - -⁻¹-injective : ∀ {x y} → x ⁻¹ ≈ y ⁻¹ → x ≈ y -⁻¹-injective {x} {y} eq = ∙-cancelʳ _ _ _ ( begin - x ∙ x ⁻¹ ≈⟨ inverseʳ x ⟩ - ε ≈˘⟨ inverseʳ y ⟩ - y ∙ y ⁻¹ ≈˘⟨ ∙-congˡ eq ⟩ - y ∙ x ⁻¹ ∎ ) - -⁻¹-anti-homo-∙ : ∀ x y → (x ∙ y) ⁻¹ ≈ y ⁻¹ ∙ x ⁻¹ -⁻¹-anti-homo-∙ x y = ∙-cancelˡ _ _ _ ( begin - x ∙ y ∙ (x ∙ y) ⁻¹ ≈⟨ inverseʳ _ ⟩ - ε ≈˘⟨ inverseʳ _ ⟩ - x ∙ x ⁻¹ ≈⟨ ∙-congʳ (left-helper x y) ⟩ - (x ∙ y) ∙ y ⁻¹ ∙ x ⁻¹ ≈⟨ assoc (x ∙ y) (y ⁻¹) (x ⁻¹) ⟩ - x ∙ y ∙ (y ⁻¹ ∙ x ⁻¹) ∎ ) - -identityˡ-unique : ∀ x y → x ∙ y ≈ y → x ≈ ε -identityˡ-unique x y eq = begin - x ≈⟨ left-helper x y ⟩ - (x ∙ y) ∙ y ⁻¹ ≈⟨ ∙-congʳ eq ⟩ - y ∙ y ⁻¹ ≈⟨ inverseʳ y ⟩ - ε ∎ - -identityʳ-unique : ∀ x y → x ∙ y ≈ x → y ≈ ε -identityʳ-unique x y eq = begin - y ≈⟨ right-helper x y ⟩ - x ⁻¹ ∙ (x ∙ y) ≈⟨ refl ⟨ ∙-cong ⟩ eq ⟩ - x ⁻¹ ∙ x ≈⟨ inverseˡ x ⟩ - ε ∎ - -identity-unique : ∀ {x} → Identity x _∙_ → x ≈ ε -identity-unique {x} id = identityˡ-unique x x (proj₂ id x) - -inverseˡ-unique : ∀ x y → x ∙ y ≈ ε → x ≈ y ⁻¹ -inverseˡ-unique x y eq = begin - x ≈⟨ left-helper x y ⟩ - (x ∙ y) ∙ y ⁻¹ ≈⟨ ∙-congʳ eq ⟩ - ε ∙ y ⁻¹ ≈⟨ identityˡ (y ⁻¹) ⟩ - y ⁻¹ ∎ - -inverseʳ-unique : ∀ x y → x ∙ y ≈ ε → y ≈ x ⁻¹ -inverseʳ-unique x y eq = begin - y ≈⟨ sym (⁻¹-involutive y) ⟩ - y ⁻¹ ⁻¹ ≈⟨ ⁻¹-cong (sym (inverseˡ-unique x y eq)) ⟩ - x ⁻¹ ∎ +module Algebra.Properties.Group {g₁ g₂} (G : Group g₁ g₂) where + +open Group G +open import Algebra.Definitions _≈_ +open import Relation.Binary.Reasoning.Setoid setoid +open import Function.Base using (_$_; _⟨_⟩_) +open import Data.Product.Base using (_,_; proj₂) + +ε⁻¹≈ε : ε ⁻¹ ≈ ε +ε⁻¹≈ε = begin + ε ⁻¹ ≈⟨ sym $ identityʳ (ε ⁻¹) ⟩ + ε ⁻¹ ∙ ε ≈⟨ inverseˡ ε ⟩ + ε ∎ + +private + + left-helper : ∀ x y → x ≈ (x ∙ y) ∙ y ⁻¹ + left-helper x y = begin + x ≈⟨ sym (identityʳ x) ⟩ + x ∙ ε ≈⟨ ∙-congˡ $ sym (inverseʳ y) ⟩ + x ∙ (y ∙ y ⁻¹) ≈⟨ sym (assoc x y (y ⁻¹)) ⟩ + (x ∙ y) ∙ y ⁻¹ ∎ + + right-helper : ∀ x y → y ≈ x ⁻¹ ∙ (x ∙ y) + right-helper x y = begin + y ≈⟨ sym (identityˡ y) ⟩ + ε ∙ y ≈⟨ ∙-congʳ $ sym (inverseˡ x) ⟩ + (x ⁻¹ ∙ x) ∙ y ≈⟨ assoc (x ⁻¹) x y ⟩ + x ⁻¹ ∙ (x ∙ y) ∎ + +∙-cancelˡ : LeftCancellative _∙_ +∙-cancelˡ x y z eq = begin + y ≈⟨ right-helper x y ⟩ + x ⁻¹ ∙ (x ∙ y) ≈⟨ ∙-congˡ eq ⟩ + x ⁻¹ ∙ (x ∙ z) ≈⟨ right-helper x z ⟨ + z ∎ + +∙-cancelʳ : RightCancellative _∙_ +∙-cancelʳ x y z eq = begin + y ≈⟨ left-helper y x ⟩ + y ∙ x ∙ x ⁻¹ ≈⟨ ∙-congʳ eq ⟩ + z ∙ x ∙ x ⁻¹ ≈⟨ left-helper z x ⟨ + z ∎ + +∙-cancel : Cancellative _∙_ +∙-cancel = ∙-cancelˡ , ∙-cancelʳ + +⁻¹-involutive : ∀ x → x ⁻¹ ⁻¹ ≈ x +⁻¹-involutive x = begin + x ⁻¹ ⁻¹ ≈⟨ identityʳ _ ⟨ + x ⁻¹ ⁻¹ ∙ ε ≈⟨ ∙-congˡ $ inverseˡ _ ⟨ + x ⁻¹ ⁻¹ ∙ (x ⁻¹ ∙ x) ≈⟨ right-helper (x ⁻¹) x ⟨ + x ∎ + +⁻¹-injective : ∀ {x y} → x ⁻¹ ≈ y ⁻¹ → x ≈ y +⁻¹-injective {x} {y} eq = ∙-cancelʳ _ _ _ ( begin + x ∙ x ⁻¹ ≈⟨ inverseʳ x ⟩ + ε ≈⟨ inverseʳ y ⟨ + y ∙ y ⁻¹ ≈⟨ ∙-congˡ eq ⟨ + y ∙ x ⁻¹ ∎ ) + +⁻¹-anti-homo-∙ : ∀ x y → (x ∙ y) ⁻¹ ≈ y ⁻¹ ∙ x ⁻¹ +⁻¹-anti-homo-∙ x y = ∙-cancelˡ _ _ _ ( begin + x ∙ y ∙ (x ∙ y) ⁻¹ ≈⟨ inverseʳ _ ⟩ + ε ≈⟨ inverseʳ _ ⟨ + x ∙ x ⁻¹ ≈⟨ ∙-congʳ (left-helper x y) ⟩ + (x ∙ y) ∙ y ⁻¹ ∙ x ⁻¹ ≈⟨ assoc (x ∙ y) (y ⁻¹) (x ⁻¹) ⟩ + x ∙ y ∙ (y ⁻¹ ∙ x ⁻¹) ∎ ) + +identityˡ-unique : ∀ x y → x ∙ y ≈ y → x ≈ ε +identityˡ-unique x y eq = begin + x ≈⟨ left-helper x y ⟩ + (x ∙ y) ∙ y ⁻¹ ≈⟨ ∙-congʳ eq ⟩ + y ∙ y ⁻¹ ≈⟨ inverseʳ y ⟩ + ε ∎ + +identityʳ-unique : ∀ x y → x ∙ y ≈ x → y ≈ ε +identityʳ-unique x y eq = begin + y ≈⟨ right-helper x y ⟩ + x ⁻¹ ∙ (x ∙ y) ≈⟨ refl ⟨ ∙-cong ⟩ eq ⟩ + x ⁻¹ ∙ x ≈⟨ inverseˡ x ⟩ + ε ∎ + +identity-unique : ∀ {x} → Identity x _∙_ → x ≈ ε +identity-unique {x} id = identityˡ-unique x x (proj₂ id x) + +inverseˡ-unique : ∀ x y → x ∙ y ≈ ε → x ≈ y ⁻¹ +inverseˡ-unique x y eq = begin + x ≈⟨ left-helper x y ⟩ + (x ∙ y) ∙ y ⁻¹ ≈⟨ ∙-congʳ eq ⟩ + ε ∙ y ⁻¹ ≈⟨ identityˡ (y ⁻¹) ⟩ + y ⁻¹ ∎ + +inverseʳ-unique : ∀ x y → x ∙ y ≈ ε → y ≈ x ⁻¹ +inverseʳ-unique x y eq = begin + y ≈⟨ sym (⁻¹-involutive y) ⟩ + y ⁻¹ ⁻¹ ≈⟨ ⁻¹-cong (sym (inverseˡ-unique x y eq)) ⟩ + x ⁻¹ ∎ \ No newline at end of file diff --git a/Algebra.Properties.Monoid.Mult.html b/Algebra.Properties.Monoid.Mult.html index b59fce60..6f2bb1ac 100644 --- a/Algebra.Properties.Monoid.Mult.html +++ b/Algebra.Properties.Monoid.Mult.html @@ -7,70 +7,70 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Algebra.Bundles using (Monoid) -open import Data.Nat.Base as ℕ using (ℕ; zero; suc; NonZero) -open import Relation.Binary -open import Relation.Binary.PropositionalEquality as P using (_≡_) - -module Algebra.Properties.Monoid.Mult {a ℓ} (M : Monoid a ℓ) where - --- View of the monoid operator as addition -open Monoid M - renaming - ( _∙_ to _+_ - ; ∙-cong to +-cong - ; ∙-congʳ to +-congʳ - ; ∙-congˡ to +-congˡ - ; identityˡ to +-identityˡ - ; identityʳ to +-identityʳ - ; assoc to +-assoc - ; ε to 0# - ) - -open import Relation.Binary.Reasoning.Setoid setoid - -open import Algebra.Definitions _≈_ - ------------------------------------------------------------------------- --- Definition - -open import Algebra.Definitions.RawMonoid rawMonoid public - using (_×_) - ------------------------------------------------------------------------- --- Properties of _×_ - -×-congʳ : ∀ n → (n ×_) Preserves _≈_ ⟶ _≈_ -×-congʳ 0 x≈x′ = refl -×-congʳ (suc n) x≈x′ = +-cong x≈x′ (×-congʳ n x≈x′) - -×-cong : _×_ Preserves₂ _≡_ ⟶ _≈_ ⟶ _≈_ -×-cong {n} P.refl x≈x′ = ×-congʳ n x≈x′ - -×-congˡ : ∀ {x} → (_× x) Preserves _≡_ ⟶ _≈_ -×-congˡ m≡n = ×-cong m≡n refl - --- _×_ is homomorphic with respect to _ℕ+_/_+_. - -×-homo-+ : ∀ x m n → (m ℕ.+ n) × x ≈ m × x + n × x -×-homo-+ x 0 n = sym (+-identityˡ (n × x)) -×-homo-+ x (suc m) n = begin - x + (m ℕ.+ n) × x ≈⟨ +-cong refl (×-homo-+ x m n) ⟩ - x + (m × x + n × x) ≈⟨ sym (+-assoc x (m × x) (n × x)) ⟩ - x + m × x + n × x ∎ - -×-idem : ∀ {c} → _+_ IdempotentOn c → - ∀ n → .{{_ : NonZero n}} → n × c ≈ c -×-idem {c} idem (suc zero) = +-identityʳ c -×-idem {c} idem (suc n@(suc _)) = begin - c + (n × c) ≈⟨ +-congˡ (×-idem idem n ) ⟩ - c + c ≈⟨ idem ⟩ - c ∎ - -×-assocˡ : ∀ x m n → m × (n × x) ≈ (m ℕ.* n) × x -×-assocˡ x zero n = refl -×-assocˡ x (suc m) n = begin - n × x + m × n × x ≈⟨ +-congˡ (×-assocˡ x m n) ⟩ - n × x + (m ℕ.* n) × x ≈˘⟨ ×-homo-+ x n (m ℕ.* n) ⟩ - (suc m ℕ.* n) × x ∎ +open import Algebra.Bundles using (Monoid) +open import Data.Nat.Base as ℕ using (ℕ; zero; suc; NonZero) +open import Relation.Binary.Core using (_Preserves_⟶_; _Preserves₂_⟶_⟶_) +open import Relation.Binary.PropositionalEquality.Core as P using (_≡_) + +module Algebra.Properties.Monoid.Mult {a ℓ} (M : Monoid a ℓ) where + +-- View of the monoid operator as addition +open Monoid M + renaming + ( _∙_ to _+_ + ; ∙-cong to +-cong + ; ∙-congʳ to +-congʳ + ; ∙-congˡ to +-congˡ + ; identityˡ to +-identityˡ + ; identityʳ to +-identityʳ + ; assoc to +-assoc + ; ε to 0# + ) + +open import Relation.Binary.Reasoning.Setoid setoid + +open import Algebra.Definitions _≈_ + +------------------------------------------------------------------------ +-- Definition + +open import Algebra.Definitions.RawMonoid rawMonoid public + using (_×_) + +------------------------------------------------------------------------ +-- Properties of _×_ + +×-congʳ : ∀ n → (n ×_) Preserves _≈_ ⟶ _≈_ +×-congʳ 0 x≈x′ = refl +×-congʳ (suc n) x≈x′ = +-cong x≈x′ (×-congʳ n x≈x′) + +×-cong : _×_ Preserves₂ _≡_ ⟶ _≈_ ⟶ _≈_ +×-cong {n} P.refl x≈x′ = ×-congʳ n x≈x′ + +×-congˡ : ∀ {x} → (_× x) Preserves _≡_ ⟶ _≈_ +×-congˡ m≡n = ×-cong m≡n refl + +-- _×_ is homomorphic with respect to _ℕ+_/_+_. + +×-homo-+ : ∀ x m n → (m ℕ.+ n) × x ≈ m × x + n × x +×-homo-+ x 0 n = sym (+-identityˡ (n × x)) +×-homo-+ x (suc m) n = begin + x + (m ℕ.+ n) × x ≈⟨ +-cong refl (×-homo-+ x m n) ⟩ + x + (m × x + n × x) ≈⟨ sym (+-assoc x (m × x) (n × x)) ⟩ + x + m × x + n × x ∎ + +×-idem : ∀ {c} → _+_ IdempotentOn c → + ∀ n → .{{_ : NonZero n}} → n × c ≈ c +×-idem {c} idem (suc zero) = +-identityʳ c +×-idem {c} idem (suc n@(suc _)) = begin + c + (n × c) ≈⟨ +-congˡ (×-idem idem n ) ⟩ + c + c ≈⟨ idem ⟩ + c ∎ + +×-assocˡ : ∀ x m n → m × (n × x) ≈ (m ℕ.* n) × x +×-assocˡ x zero n = refl +×-assocˡ x (suc m) n = begin + n × x + m × n × x ≈⟨ +-congˡ (×-assocˡ x m n) ⟩ + n × x + (m ℕ.* n) × x ≈⟨ ×-homo-+ x n (m ℕ.* n) ⟨ + (suc m ℕ.* n) × x ∎ \ No newline at end of file diff --git a/Algebra.Properties.Ring.html b/Algebra.Properties.Ring.html index 56c55e1e..3450ac41 100644 --- a/Algebra.Properties.Ring.html +++ b/Algebra.Properties.Ring.html @@ -7,81 +7,28 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Algebra using (Ring) +open import Algebra using (Ring) -module Algebra.Properties.Ring {r₁ r₂} (R : Ring r₁ r₂) where +module Algebra.Properties.Ring {r₁ r₂} (R : Ring r₁ r₂) where -open Ring R +open Ring R -import Algebra.Properties.AbelianGroup as AbelianGroupProperties -open import Function.Base using (_$_) -open import Relation.Binary.Reasoning.Setoid setoid -open import Algebra.Definitions _≈_ -open import Data.Product +import Algebra.Properties.RingWithoutOne as RingWithoutOneProperties +open import Function.Base using (_$_) +open import Relation.Binary.Reasoning.Setoid setoid +open import Algebra.Definitions _≈_ ------------------------------------------------------------------------- --- Export properties of abelian groups +------------------------------------------------------------------------ +-- Export properties of rings without a 1#. -open AbelianGroupProperties +-abelianGroup public - renaming - ( ε⁻¹≈ε to -0#≈0# - ; ∙-cancelˡ to +-cancelˡ - ; ∙-cancelʳ to +-cancelʳ - ; ∙-cancel to +-cancel - ; ⁻¹-involutive to -‿involutive - ; ⁻¹-injective to -‿injective - ; ⁻¹-anti-homo-∙ to -‿anti-homo-+ - ; identityˡ-unique to +-identityˡ-unique - ; identityʳ-unique to +-identityʳ-unique - ; identity-unique to +-identity-unique - ; inverseˡ-unique to +-inverseˡ-unique - ; inverseʳ-unique to +-inverseʳ-unique - ; ⁻¹-∙-comm to -‿+-comm - ) +open RingWithoutOneProperties ringWithoutOne public ------------------------------------------------------------------------- --- Properties of -_ +------------------------------------------------------------------------ +-- Extra properties of 1# --‿distribˡ-* : ∀ x y → - (x * y) ≈ - x * y --‿distribˡ-* x y = sym $ begin - - x * y ≈⟨ sym $ +-identityʳ _ ⟩ - - x * y + 0# ≈⟨ +-congˡ $ sym (-‿inverseʳ _) ⟩ - - x * y + (x * y + - (x * y)) ≈⟨ sym $ +-assoc _ _ _ ⟩ - - x * y + x * y + - (x * y) ≈⟨ +-congʳ $ sym (distribʳ _ _ _) ⟩ - (- x + x) * y + - (x * y) ≈⟨ +-congʳ $ *-congʳ $ -‿inverseˡ _ ⟩ - 0# * y + - (x * y) ≈⟨ +-congʳ $ zeroˡ _ ⟩ - 0# + - (x * y) ≈⟨ +-identityˡ _ ⟩ - - (x * y) ∎ - --‿distribʳ-* : ∀ x y → - (x * y) ≈ x * - y --‿distribʳ-* x y = sym $ begin - x * - y ≈⟨ sym $ +-identityˡ _ ⟩ - 0# + x * - y ≈⟨ +-congʳ $ sym (-‿inverseˡ _) ⟩ - - (x * y) + x * y + x * - y ≈⟨ +-assoc _ _ _ ⟩ - - (x * y) + (x * y + x * - y) ≈⟨ +-congˡ $ sym (distribˡ _ _ _) ⟩ - - (x * y) + x * (y + - y) ≈⟨ +-congˡ $ *-congˡ $ -‿inverseʳ _ ⟩ - - (x * y) + x * 0# ≈⟨ +-congˡ $ zeroʳ _ ⟩ - - (x * y) + 0# ≈⟨ +-identityʳ _ ⟩ - - (x * y) ∎ - --1*x≈-x : ∀ x → - 1# * x ≈ - x --1*x≈-x x = begin - - 1# * x ≈⟨ sym (-‿distribˡ-* 1# x ) ⟩ - - (1# * x) ≈⟨ -‿cong ( *-identityˡ x ) ⟩ - - x ∎ - -x+x≈x⇒x≈0 : ∀ x → x + x ≈ x → x ≈ 0# -x+x≈x⇒x≈0 x eq = +-identityˡ-unique x x eq - -x[y-z]≈xy-xz : ∀ x y z → x * (y - z) ≈ x * y - x * z -x[y-z]≈xy-xz x y z = begin - x * (y - z) ≈⟨ distribˡ x y (- z) ⟩ - x * y + x * - z ≈⟨ +-congˡ (sym (-‿distribʳ-* x z)) ⟩ - x * y - x * z ∎ - -[y-z]x≈yx-zx : ∀ x y z → (y - z) * x ≈ (y * x) - (z * x) -[y-z]x≈yx-zx x y z = begin - (y - z) * x ≈⟨ distribʳ x y (- z) ⟩ - y * x + - z * x ≈⟨ +-congˡ (sym (-‿distribˡ-* z x)) ⟩ - y * x - z * x ∎ +-1*x≈-x : ∀ x → - 1# * x ≈ - x +-1*x≈-x x = begin + - 1# * x ≈⟨ -‿distribˡ-* 1# x ⟨ + - (1# * x) ≈⟨ -‿cong ( *-identityˡ x ) ⟩ + - x ∎ \ No newline at end of file diff --git a/Algebra.Properties.RingWithoutOne.html b/Algebra.Properties.RingWithoutOne.html new file mode 100644 index 00000000..ca20e9fb --- /dev/null +++ b/Algebra.Properties.RingWithoutOne.html @@ -0,0 +1,76 @@ + +Algebra.Properties.RingWithoutOne
------------------------------------------------------------------------
+-- The Agda standard library
+--
+-- Some basic properties of RingWithoutOne
+------------------------------------------------------------------------
+
+{-# OPTIONS --cubical-compatible --safe #-}
+
+open import Algebra
+
+module Algebra.Properties.RingWithoutOne {r₁ r₂} (R : RingWithoutOne r₁ r₂) where
+
+open RingWithoutOne R
+
+import Algebra.Properties.AbelianGroup as AbelianGroupProperties
+open import Function.Base using (_$_)
+open import Relation.Binary.Reasoning.Setoid setoid
+
+------------------------------------------------------------------------
+-- Export properties of abelian groups
+
+open AbelianGroupProperties +-abelianGroup public
+  renaming
+  ( ε⁻¹≈ε            to -0#≈0#
+  ; ∙-cancelˡ        to +-cancelˡ
+  ; ∙-cancelʳ        to +-cancelʳ
+  ; ∙-cancel         to +-cancel
+  ; ⁻¹-involutive    to -‿involutive
+  ; ⁻¹-injective     to -‿injective
+  ; ⁻¹-anti-homo-∙   to -‿anti-homo-+
+  ; identityˡ-unique to +-identityˡ-unique
+  ; identityʳ-unique to +-identityʳ-unique
+  ; identity-unique  to +-identity-unique
+  ; inverseˡ-unique  to +-inverseˡ-unique
+  ; inverseʳ-unique  to +-inverseʳ-unique
+  ; ⁻¹-∙-comm        to -‿+-comm
+  )
+
+-‿distribˡ-* : ∀ x y → - (x * y) ≈ - x * y
+-‿distribˡ-* x y = sym $ begin
+  - x * y                        ≈⟨ +-identityʳ (- x * y) ⟨
+  - x * y + 0#                   ≈⟨ +-congˡ $ -‿inverseʳ (x * y) ⟨
+  - x * y + (x * y + - (x * y))  ≈⟨ +-assoc (- x * y) (x * y) (- (x * y)) ⟨
+  - x * y + x * y + - (x * y)    ≈⟨ +-congʳ $ distribʳ y (- x) x ⟨
+  (- x + x) * y + - (x * y)      ≈⟨ +-congʳ $ *-congʳ $ -‿inverseˡ x ⟩
+  0# * y + - (x * y)             ≈⟨ +-congʳ $ zeroˡ y ⟩
+  0# + - (x * y)                 ≈⟨ +-identityˡ (- (x * y)) ⟩
+  - (x * y)                      ∎
+
+-‿distribʳ-* : ∀ x y → - (x * y) ≈ x * - y
+-‿distribʳ-* x y = sym $ begin
+  x * - y                        ≈⟨ +-identityˡ (x * - y) ⟨
+  0# + x * - y                   ≈⟨ +-congʳ $ -‿inverseˡ (x * y) ⟨
+  - (x * y) + x * y + x * - y    ≈⟨ +-assoc (- (x * y)) (x * y) (x * - y) ⟩
+  - (x * y) + (x * y + x * - y)  ≈⟨ +-congˡ $ distribˡ x y (- y) ⟨
+  - (x * y) + x * (y + - y)      ≈⟨ +-congˡ $ *-congˡ $ -‿inverseʳ y ⟩
+  - (x * y) + x * 0#             ≈⟨ +-congˡ $ zeroʳ x ⟩
+  - (x * y) + 0#                 ≈⟨ +-identityʳ (- (x * y)) ⟩
+  - (x * y)                      ∎
+
+x+x≈x⇒x≈0 : ∀ x → x + x ≈ x → x ≈ 0#
+x+x≈x⇒x≈0 x eq = +-identityˡ-unique x x eq
+
+x[y-z]≈xy-xz : ∀ x y z → x * (y - z) ≈ x * y - x * z
+x[y-z]≈xy-xz x y z = begin
+  x * (y - z)      ≈⟨ distribˡ x y (- z) ⟩
+  x * y + x * - z  ≈⟨ +-congˡ (sym (-‿distribʳ-* x z)) ⟩
+  x * y - x * z    ∎
+
+[y-z]x≈yx-zx : ∀ x y z → (y - z) * x ≈ (y * x) - (z * x)
+[y-z]x≈yx-zx x y z = begin
+  (y - z) * x      ≈⟨ distribʳ x y (- z) ⟩
+  y * x + - z * x  ≈⟨ +-congˡ (sym (-‿distribˡ-* z x)) ⟩
+  y * x - z * x    ∎
+
\ No newline at end of file diff --git a/Algebra.Properties.Semigroup.html b/Algebra.Properties.Semigroup.html index afb542b1..ec325ee7 100644 --- a/Algebra.Properties.Semigroup.html +++ b/Algebra.Properties.Semigroup.html @@ -7,26 +7,26 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Algebra using (Semigroup) +open import Algebra using (Semigroup) -module Algebra.Properties.Semigroup {a ℓ} (S : Semigroup a ℓ) where +module Algebra.Properties.Semigroup {a ℓ} (S : Semigroup a ℓ) where -open Semigroup S -open import Algebra.Definitions _≈_ -open import Data.Product +open Semigroup S +open import Algebra.Definitions _≈_ +open import Data.Product.Base using (_,_) -x∙yz≈xy∙z : ∀ x y z → x ∙ (y ∙ z) ≈ (x ∙ y) ∙ z -x∙yz≈xy∙z x y z = sym (assoc x y z) +x∙yz≈xy∙z : ∀ x y z → x ∙ (y ∙ z) ≈ (x ∙ y) ∙ z +x∙yz≈xy∙z x y z = sym (assoc x y z) -alternativeˡ : LeftAlternative _∙_ -alternativeˡ x y = assoc x x y +alternativeˡ : LeftAlternative _∙_ +alternativeˡ x y = assoc x x y -alternativeʳ : RightAlternative _∙_ -alternativeʳ x y = sym (assoc x y y) +alternativeʳ : RightAlternative _∙_ +alternativeʳ x y = sym (assoc x y y) -alternative : Alternative _∙_ -alternative = alternativeˡ , alternativeʳ +alternative : Alternative _∙_ +alternative = alternativeˡ , alternativeʳ -flexible : Flexible _∙_ -flexible x y = assoc x y x +flexible : Flexible _∙_ +flexible x y = assoc x y x \ No newline at end of file diff --git a/Algebra.Properties.Semiring.Exp.html b/Algebra.Properties.Semiring.Exp.html index df497354..0884a1da 100644 --- a/Algebra.Properties.Semiring.Exp.html +++ b/Algebra.Properties.Semiring.Exp.html @@ -9,66 +9,66 @@ open import Algebra open import Data.Nat.Base as ℕ using (ℕ; zero; suc) -open import Relation.Binary -open import Relation.Binary.PropositionalEquality as P using (_≡_) -import Data.Nat.Properties as ℕ +open import Relation.Binary.Core using (_Preserves_⟶_; _Preserves₂_⟶_⟶_) +open import Relation.Binary.PropositionalEquality.Core as P using (_≡_) +import Data.Nat.Properties as ℕ -module Algebra.Properties.Semiring.Exp - {a ℓ} (S : Semiring a ℓ) where +module Algebra.Properties.Semiring.Exp + {a ℓ} (S : Semiring a ℓ) where -open Semiring S -open import Relation.Binary.Reasoning.Setoid setoid -import Algebra.Properties.Monoid.Mult *-monoid as Mult +open Semiring S +open import Relation.Binary.Reasoning.Setoid setoid +import Algebra.Properties.Monoid.Mult *-monoid as Mult ------------------------------------------------------------------------- --- Definition +------------------------------------------------------------------------ +-- Definition -open import Algebra.Definitions.RawSemiring rawSemiring public - using (_^_) +open import Algebra.Definitions.RawSemiring rawSemiring public + using (_^_) ------------------------------------------------------------------------- --- Properties +------------------------------------------------------------------------ +-- Properties -^-congˡ : ∀ n → (_^ n) Preserves _≈_ ⟶ _≈_ -^-congˡ = Mult.×-congʳ +^-congˡ : ∀ n → (_^ n) Preserves _≈_ ⟶ _≈_ +^-congˡ = Mult.×-congʳ -^-cong : _^_ Preserves₂ _≈_ ⟶ _≡_ ⟶ _≈_ -^-cong x≈y u≡v = Mult.×-cong u≡v x≈y +^-cong : _^_ Preserves₂ _≈_ ⟶ _≡_ ⟶ _≈_ +^-cong x≈y u≡v = Mult.×-cong u≡v x≈y -^-congʳ : ∀ x → (x ^_) Preserves _≡_ ⟶ _≈_ -^-congʳ x = Mult.×-congˡ +^-congʳ : ∀ x → (x ^_) Preserves _≡_ ⟶ _≈_ +^-congʳ x = Mult.×-congˡ --- xᵐ⁺ⁿ ≈ xᵐxⁿ -^-homo-* : ∀ x m n → x ^ (m ℕ.+ n) ≈ (x ^ m) * (x ^ n) -^-homo-* = Mult.×-homo-+ +-- xᵐ⁺ⁿ ≈ xᵐxⁿ +^-homo-* : ∀ x m n → x ^ (m ℕ.+ n) ≈ (x ^ m) * (x ^ n) +^-homo-* = Mult.×-homo-+ --- (xᵐ)ⁿ≈xᵐ*ⁿ -^-assocʳ : ∀ x m n → (x ^ m) ^ n ≈ x ^ (m ℕ.* n) -^-assocʳ x m n rewrite ℕ.*-comm m n = Mult.×-assocˡ x n m +-- (xᵐ)ⁿ≈xᵐ*ⁿ +^-assocʳ : ∀ x m n → (x ^ m) ^ n ≈ x ^ (m ℕ.* n) +^-assocʳ x m n rewrite ℕ.*-comm m n = Mult.×-assocˡ x n m ------------------------------------------------------------------------- --- A lemma using commutativity, needed for the Binomial Theorem +------------------------------------------------------------------------ +-- A lemma using commutativity, needed for the Binomial Theorem -y*x^m*y^n≈x^m*y^[n+1] : ∀ {x} {y} (x*y≈y*x : x * y ≈ y * x) → - ∀ m n → y * (x ^ m * y ^ n) ≈ x ^ m * y ^ suc n -y*x^m*y^n≈x^m*y^[n+1] {x} {y} x*y≈y*x = helper - where - helper : ∀ m n → y * (x ^ m * y ^ n) ≈ x ^ m * y ^ suc n - helper zero n = begin - y * (x ^ ℕ.zero * y ^ n) ≡⟨⟩ - y * (1# * y ^ n) ≈⟨ *-congˡ (*-identityˡ (y ^ n)) ⟩ - y * (y ^ n) ≡⟨⟩ - y ^ (suc n) ≈˘⟨ *-identityˡ (y ^ suc n) ⟩ - 1# * y ^ (suc n) ≡⟨⟩ - x ^ ℕ.zero * y ^ (suc n) ∎ - helper (suc m) n = begin - y * (x ^ suc m * y ^ n) ≡⟨⟩ - y * ((x * x ^ m) * y ^ n) ≈⟨ *-congˡ (*-assoc x (x ^ m) (y ^ n)) ⟩ - y * (x * (x ^ m * y ^ n)) ≈˘⟨ *-assoc y x (x ^ m * y ^ n) ⟩ - y * x * (x ^ m * y ^ n) ≈˘⟨ *-congʳ x*y≈y*x ⟩ - x * y * (x ^ m * y ^ n) ≈⟨ *-assoc x y _ ⟩ - x * (y * (x ^ m * y ^ n)) ≈⟨ *-congˡ (helper m n) ⟩ - x * (x ^ m * y ^ suc n) ≈˘⟨ *-assoc x (x ^ m) (y ^ suc n) ⟩ - (x * x ^ m) * y ^ suc n ≡⟨⟩ - x ^ suc m * y ^ suc n ∎ +y*x^m*y^n≈x^m*y^[n+1] : ∀ {x} {y} (x*y≈y*x : x * y ≈ y * x) → + ∀ m n → y * (x ^ m * y ^ n) ≈ x ^ m * y ^ suc n +y*x^m*y^n≈x^m*y^[n+1] {x} {y} x*y≈y*x = helper + where + helper : ∀ m n → y * (x ^ m * y ^ n) ≈ x ^ m * y ^ suc n + helper zero n = begin + y * (x ^ ℕ.zero * y ^ n) ≡⟨⟩ + y * (1# * y ^ n) ≈⟨ *-congˡ (*-identityˡ (y ^ n)) ⟩ + y * (y ^ n) ≡⟨⟩ + y ^ (suc n) ≈⟨ *-identityˡ (y ^ suc n) ⟨ + 1# * y ^ (suc n) ≡⟨⟩ + x ^ ℕ.zero * y ^ (suc n) ∎ + helper (suc m) n = begin + y * (x ^ suc m * y ^ n) ≡⟨⟩ + y * ((x * x ^ m) * y ^ n) ≈⟨ *-congˡ (*-assoc x (x ^ m) (y ^ n)) ⟩ + y * (x * (x ^ m * y ^ n)) ≈⟨ *-assoc y x (x ^ m * y ^ n) ⟨ + y * x * (x ^ m * y ^ n) ≈⟨ *-congʳ x*y≈y*x ⟨ + x * y * (x ^ m * y ^ n) ≈⟨ *-assoc x y _ ⟩ + x * (y * (x ^ m * y ^ n)) ≈⟨ *-congˡ (helper m n) ⟩ + x * (x ^ m * y ^ suc n) ≈⟨ *-assoc x (x ^ m) (y ^ suc n) ⟨ + (x * x ^ m) * y ^ suc n ≡⟨⟩ + x ^ suc m * y ^ suc n ∎ \ No newline at end of file diff --git a/Algebra.Solver.Ring.AlmostCommutativeRing.html b/Algebra.Solver.Ring.AlmostCommutativeRing.html index 8e792da1..3cb0afe5 100644 --- a/Algebra.Solver.Ring.AlmostCommutativeRing.html +++ b/Algebra.Solver.Ring.AlmostCommutativeRing.html @@ -15,137 +15,137 @@ open import Algebra.Definitions import Algebra.Morphism as Morphism import Algebra.Morphism.Definitions as MorphismDefinitions -open import Function hiding (Morphism) -open import Level -open import Relation.Binary - - -record IsAlmostCommutativeRing {a ℓ} {A : Set a} (_≈_ : Rel A ℓ) - (_+_ _*_ : Op₂ A) (-_ : Op₁ A) - (0# 1# : A) : Set (a ⊔ ℓ) where - field - isCommutativeSemiring : IsCommutativeSemiring _≈_ _+_ _*_ 0# 1# - -‿cong : Congruent₁ _≈_ -_ - -‿*-distribˡ : ∀ x y → ((- x) * y) ≈ (- (x * y)) - -‿+-comm : ∀ x y → ((- x) + (- y)) ≈ (- (x + y)) - - open IsCommutativeSemiring isCommutativeSemiring public - - -record AlmostCommutativeRing c ℓ : Set (suc (c ⊔ ℓ)) where - infix 8 -_ - infixl 7 _*_ - infixl 6 _+_ - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - _+_ : Op₂ Carrier - _*_ : Op₂ Carrier - -_ : Op₁ Carrier - 0# : Carrier - 1# : Carrier - isAlmostCommutativeRing : IsAlmostCommutativeRing _≈_ _+_ _*_ -_ 0# 1# - - open IsAlmostCommutativeRing isAlmostCommutativeRing public - - commutativeSemiring : CommutativeSemiring _ _ - commutativeSemiring = record - { isCommutativeSemiring = isCommutativeSemiring - } - - open CommutativeSemiring commutativeSemiring public - using - ( +-magma; +-semigroup - ; *-magma; *-semigroup; *-commutativeSemigroup - ; +-monoid; +-commutativeMonoid - ; *-monoid; *-commutativeMonoid - ; semiring - ) - - rawRing : RawRing _ _ - rawRing = record - { _≈_ = _≈_ - ; _+_ = _+_ - ; _*_ = _*_ - ; -_ = -_ - ; 0# = 0# - ; 1# = 1# - } - - ------------------------------------------------------------------------- --- Homomorphisms - -record _-Raw-AlmostCommutative⟶_ - {r₁ r₂ r₃ r₄} - (From : RawRing r₁ r₄) - (To : AlmostCommutativeRing r₂ r₃) : Set (r₁ ⊔ r₂ ⊔ r₃) where - private - module F = RawRing From - module T = AlmostCommutativeRing To - open MorphismDefinitions F.Carrier T.Carrier T._≈_ - field - ⟦_⟧ : Morphism - +-homo : Homomorphic₂ ⟦_⟧ F._+_ T._+_ - *-homo : Homomorphic₂ ⟦_⟧ F._*_ T._*_ - -‿homo : Homomorphic₁ ⟦_⟧ F.-_ T.-_ - 0-homo : Homomorphic₀ ⟦_⟧ F.0# T.0# - 1-homo : Homomorphic₀ ⟦_⟧ F.1# T.1# - --raw-almostCommutative⟶ : - ∀ {r₁ r₂} (R : AlmostCommutativeRing r₁ r₂) → - AlmostCommutativeRing.rawRing R -Raw-AlmostCommutative⟶ R --raw-almostCommutative⟶ R = record - { ⟦_⟧ = id - ; +-homo = λ _ _ → refl - ; *-homo = λ _ _ → refl - ; -‿homo = λ _ → refl - ; 0-homo = refl - ; 1-homo = refl - } - where open AlmostCommutativeRing R - -Induced-equivalence : ∀ {c₁ c₂ ℓ₁ ℓ₂} {Coeff : RawRing c₁ ℓ₁} - {R : AlmostCommutativeRing c₂ ℓ₂} → - Coeff -Raw-AlmostCommutative⟶ R → - Rel (RawRing.Carrier Coeff) ℓ₂ -Induced-equivalence {R = R} morphism a b = ⟦ a ⟧ ≈ ⟦ b ⟧ - where - open AlmostCommutativeRing R - open _-Raw-AlmostCommutative⟶_ morphism - ------------------------------------------------------------------------- --- Conversions - --- Commutative rings are almost commutative rings. - -fromCommutativeRing : ∀ {r₁ r₂} → CommutativeRing r₁ r₂ → AlmostCommutativeRing r₁ r₂ -fromCommutativeRing CR = record - { isAlmostCommutativeRing = record - { isCommutativeSemiring = isCommutativeSemiring - ; -‿cong = -‿cong - ; -‿*-distribˡ = λ x y → sym (-‿distribˡ-* x y) - ; -‿+-comm = ⁻¹-∙-comm - } - } - where - open CommutativeRing CR - open import Algebra.Properties.Ring ring - open import Algebra.Properties.AbelianGroup +-abelianGroup - --- Commutative semirings can be viewed as almost commutative rings by --- using identity as the "almost negation". - -fromCommutativeSemiring : ∀ {r₁ r₂} → CommutativeSemiring r₁ r₂ → AlmostCommutativeRing _ _ -fromCommutativeSemiring CS = record - { -_ = id - ; isAlmostCommutativeRing = record - { isCommutativeSemiring = isCommutativeSemiring - ; -‿cong = id - ; -‿*-distribˡ = λ _ _ → refl - ; -‿+-comm = λ _ _ → refl - } - } - where open CommutativeSemiring CS +open import Function.Base using (id) +open import Level +open import Relation.Binary.Core using (Rel) + + +record IsAlmostCommutativeRing {a ℓ} {A : Set a} (_≈_ : Rel A ℓ) + (_+_ _*_ : Op₂ A) (-_ : Op₁ A) + (0# 1# : A) : Set (a ⊔ ℓ) where + field + isCommutativeSemiring : IsCommutativeSemiring _≈_ _+_ _*_ 0# 1# + -‿cong : Congruent₁ _≈_ -_ + -‿*-distribˡ : ∀ x y → ((- x) * y) ≈ (- (x * y)) + -‿+-comm : ∀ x y → ((- x) + (- y)) ≈ (- (x + y)) + + open IsCommutativeSemiring isCommutativeSemiring public + + +record AlmostCommutativeRing c ℓ : Set (suc (c ⊔ ℓ)) where + infix 8 -_ + infixl 7 _*_ + infixl 6 _+_ + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + _+_ : Op₂ Carrier + _*_ : Op₂ Carrier + -_ : Op₁ Carrier + 0# : Carrier + 1# : Carrier + isAlmostCommutativeRing : IsAlmostCommutativeRing _≈_ _+_ _*_ -_ 0# 1# + + open IsAlmostCommutativeRing isAlmostCommutativeRing public + + commutativeSemiring : CommutativeSemiring _ _ + commutativeSemiring = record + { isCommutativeSemiring = isCommutativeSemiring + } + + open CommutativeSemiring commutativeSemiring public + using + ( +-magma; +-semigroup + ; *-magma; *-semigroup; *-commutativeSemigroup + ; +-monoid; +-commutativeMonoid + ; *-monoid; *-commutativeMonoid + ; semiring + ) + + rawRing : RawRing _ _ + rawRing = record + { _≈_ = _≈_ + ; _+_ = _+_ + ; _*_ = _*_ + ; -_ = -_ + ; 0# = 0# + ; 1# = 1# + } + + +------------------------------------------------------------------------ +-- Homomorphisms + +record _-Raw-AlmostCommutative⟶_ + {r₁ r₂ r₃ r₄} + (From : RawRing r₁ r₄) + (To : AlmostCommutativeRing r₂ r₃) : Set (r₁ ⊔ r₂ ⊔ r₃) where + private + module F = RawRing From + module T = AlmostCommutativeRing To + open MorphismDefinitions F.Carrier T.Carrier T._≈_ + field + ⟦_⟧ : Morphism + +-homo : Homomorphic₂ ⟦_⟧ F._+_ T._+_ + *-homo : Homomorphic₂ ⟦_⟧ F._*_ T._*_ + -‿homo : Homomorphic₁ ⟦_⟧ F.-_ T.-_ + 0-homo : Homomorphic₀ ⟦_⟧ F.0# T.0# + 1-homo : Homomorphic₀ ⟦_⟧ F.1# T.1# + +-raw-almostCommutative⟶ : + ∀ {r₁ r₂} (R : AlmostCommutativeRing r₁ r₂) → + AlmostCommutativeRing.rawRing R -Raw-AlmostCommutative⟶ R +-raw-almostCommutative⟶ R = record + { ⟦_⟧ = id + ; +-homo = λ _ _ → refl + ; *-homo = λ _ _ → refl + ; -‿homo = λ _ → refl + ; 0-homo = refl + ; 1-homo = refl + } + where open AlmostCommutativeRing R + +Induced-equivalence : ∀ {c₁ c₂ ℓ₁ ℓ₂} {Coeff : RawRing c₁ ℓ₁} + {R : AlmostCommutativeRing c₂ ℓ₂} → + Coeff -Raw-AlmostCommutative⟶ R → + Rel (RawRing.Carrier Coeff) ℓ₂ +Induced-equivalence {R = R} morphism a b = ⟦ a ⟧ ≈ ⟦ b ⟧ + where + open AlmostCommutativeRing R + open _-Raw-AlmostCommutative⟶_ morphism + +------------------------------------------------------------------------ +-- Conversions + +-- Commutative rings are almost commutative rings. + +fromCommutativeRing : ∀ {r₁ r₂} → CommutativeRing r₁ r₂ → AlmostCommutativeRing r₁ r₂ +fromCommutativeRing CR = record + { isAlmostCommutativeRing = record + { isCommutativeSemiring = isCommutativeSemiring + ; -‿cong = -‿cong + ; -‿*-distribˡ = λ x y → sym (-‿distribˡ-* x y) + ; -‿+-comm = ⁻¹-∙-comm + } + } + where + open CommutativeRing CR + open import Algebra.Properties.Ring ring + open import Algebra.Properties.AbelianGroup +-abelianGroup + +-- Commutative semirings can be viewed as almost commutative rings by +-- using identity as the "almost negation". + +fromCommutativeSemiring : ∀ {r₁ r₂} → CommutativeSemiring r₁ r₂ → AlmostCommutativeRing _ _ +fromCommutativeSemiring CS = record + { -_ = id + ; isAlmostCommutativeRing = record + { isCommutativeSemiring = isCommutativeSemiring + ; -‿cong = id + ; -‿*-distribˡ = λ _ _ → refl + ; -‿+-comm = λ _ _ → refl + } + } + where open CommutativeSemiring CS \ No newline at end of file diff --git a/Algebra.Solver.Ring.Lemmas.html b/Algebra.Solver.Ring.Lemmas.html index 7aada6ec..c8c42307 100644 --- a/Algebra.Solver.Ring.Lemmas.html +++ b/Algebra.Solver.Ring.Lemmas.html @@ -14,103 +14,103 @@ module Algebra.Solver.Ring.Lemmas {r₁ r₂ r₃ r₄} - (coeff : RawRing r₁ r₄) - (r : AlmostCommutativeRing r₂ r₃) - (morphism : coeff -Raw-AlmostCommutative⟶ r) + (coeff : RawRing r₁ r₄) + (r : AlmostCommutativeRing r₂ r₃) + (morphism : coeff -Raw-AlmostCommutative⟶ r) where private - module C = RawRing coeff -open AlmostCommutativeRing r + module C = RawRing coeff +open AlmostCommutativeRing r open import Algebra.Morphism -open _-Raw-AlmostCommutative⟶_ morphism -open import Relation.Binary.Reasoning.Setoid setoid -open import Function +open _-Raw-AlmostCommutative⟶_ morphism +open import Relation.Binary.Reasoning.Setoid setoid +open import Function.Base using (_⟨_⟩_; _$_) -lemma₀ : ∀ a b c x → - (a + b) * x + c ≈ a * x + (b * x + c) -lemma₀ a b c x = begin - (a + b) * x + c ≈⟨ distribʳ _ _ _ ⟨ +-cong ⟩ refl ⟩ - (a * x + b * x) + c ≈⟨ +-assoc _ _ _ ⟩ - a * x + (b * x + c) ∎ +lemma₀ : ∀ a b c x → + (a + b) * x + c ≈ a * x + (b * x + c) +lemma₀ a b c x = begin + (a + b) * x + c ≈⟨ distribʳ _ _ _ ⟨ +-cong ⟩ refl ⟩ + (a * x + b * x) + c ≈⟨ +-assoc _ _ _ ⟩ + a * x + (b * x + c) ∎ -lemma₁ : ∀ a b c d x → - (a + b) * x + (c + d) ≈ (a * x + c) + (b * x + d) -lemma₁ a b c d x = begin - (a + b) * x + (c + d) ≈⟨ lemma₀ _ _ _ _ ⟩ - a * x + (b * x + (c + d)) ≈⟨ refl ⟨ +-cong ⟩ sym (+-assoc _ _ _) ⟩ - a * x + ((b * x + c) + d) ≈⟨ refl ⟨ +-cong ⟩ (+-comm _ _ ⟨ +-cong ⟩ refl) ⟩ - a * x + ((c + b * x) + d) ≈⟨ refl ⟨ +-cong ⟩ +-assoc _ _ _ ⟩ - a * x + (c + (b * x + d)) ≈⟨ sym $ +-assoc _ _ _ ⟩ - (a * x + c) + (b * x + d) ∎ +lemma₁ : ∀ a b c d x → + (a + b) * x + (c + d) ≈ (a * x + c) + (b * x + d) +lemma₁ a b c d x = begin + (a + b) * x + (c + d) ≈⟨ lemma₀ _ _ _ _ ⟩ + a * x + (b * x + (c + d)) ≈⟨ refl ⟨ +-cong ⟩ sym (+-assoc _ _ _) ⟩ + a * x + ((b * x + c) + d) ≈⟨ refl ⟨ +-cong ⟩ (+-comm _ _ ⟨ +-cong ⟩ refl) ⟩ + a * x + ((c + b * x) + d) ≈⟨ refl ⟨ +-cong ⟩ +-assoc _ _ _ ⟩ + a * x + (c + (b * x + d)) ≈⟨ sym $ +-assoc _ _ _ ⟩ + (a * x + c) + (b * x + d) ∎ -lemma₂ : ∀ a b c x → a * c * x + b * c ≈ (a * x + b) * c -lemma₂ a b c x = begin - a * c * x + b * c ≈⟨ lem ⟨ +-cong ⟩ refl ⟩ - a * x * c + b * c ≈⟨ sym $ distribʳ _ _ _ ⟩ - (a * x + b) * c ∎ - where - lem = begin - a * c * x ≈⟨ *-assoc _ _ _ ⟩ - a * (c * x) ≈⟨ refl ⟨ *-cong ⟩ *-comm _ _ ⟩ - a * (x * c) ≈⟨ sym $ *-assoc _ _ _ ⟩ - a * x * c ∎ +lemma₂ : ∀ a b c x → a * c * x + b * c ≈ (a * x + b) * c +lemma₂ a b c x = begin + a * c * x + b * c ≈⟨ lem ⟨ +-cong ⟩ refl ⟩ + a * x * c + b * c ≈⟨ sym $ distribʳ _ _ _ ⟩ + (a * x + b) * c ∎ + where + lem = begin + a * c * x ≈⟨ *-assoc _ _ _ ⟩ + a * (c * x) ≈⟨ refl ⟨ *-cong ⟩ *-comm _ _ ⟩ + a * (x * c) ≈⟨ sym $ *-assoc _ _ _ ⟩ + a * x * c ∎ -lemma₃ : ∀ a b c x → a * b * x + a * c ≈ a * (b * x + c) -lemma₃ a b c x = begin - a * b * x + a * c ≈⟨ *-assoc _ _ _ ⟨ +-cong ⟩ refl ⟩ - a * (b * x) + a * c ≈⟨ sym $ distribˡ _ _ _ ⟩ - a * (b * x + c) ∎ +lemma₃ : ∀ a b c x → a * b * x + a * c ≈ a * (b * x + c) +lemma₃ a b c x = begin + a * b * x + a * c ≈⟨ *-assoc _ _ _ ⟨ +-cong ⟩ refl ⟩ + a * (b * x) + a * c ≈⟨ sym $ distribˡ _ _ _ ⟩ + a * (b * x + c) ∎ -lemma₄ : ∀ a b c d x → - (a * c * x + (a * d + b * c)) * x + b * d ≈ - (a * x + b) * (c * x + d) -lemma₄ a b c d x = begin - (a * c * x + (a * d + b * c)) * x + b * d ≈⟨ distribʳ _ _ _ ⟨ +-cong ⟩ refl ⟩ - (a * c * x * x + (a * d + b * c) * x) + b * d ≈⟨ refl ⟨ +-cong ⟩ ((refl ⟨ +-cong ⟩ refl) ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ refl ⟩ - (a * c * x * x + (a * d + b * c) * x) + b * d ≈⟨ +-assoc _ _ _ ⟩ - a * c * x * x + ((a * d + b * c) * x + b * d) ≈⟨ lem₁ ⟨ +-cong ⟩ (lem₂ ⟨ +-cong ⟩ refl) ⟩ - a * x * (c * x) + (a * x * d + b * (c * x) + b * d) ≈⟨ refl ⟨ +-cong ⟩ +-assoc _ _ _ ⟩ - a * x * (c * x) + (a * x * d + (b * (c * x) + b * d)) ≈⟨ sym $ +-assoc _ _ _ ⟩ - a * x * (c * x) + a * x * d + (b * (c * x) + b * d) ≈⟨ sym $ distribˡ _ _ _ ⟨ +-cong ⟩ distribˡ _ _ _ ⟩ - a * x * (c * x + d) + b * (c * x + d) ≈⟨ sym $ distribʳ _ _ _ ⟩ - (a * x + b) * (c * x + d) ∎ - where - lem₁′ = begin - a * c * x ≈⟨ *-assoc _ _ _ ⟩ - a * (c * x) ≈⟨ refl ⟨ *-cong ⟩ *-comm _ _ ⟩ - a * (x * c) ≈⟨ sym $ *-assoc _ _ _ ⟩ - a * x * c ∎ +lemma₄ : ∀ a b c d x → + (a * c * x + (a * d + b * c)) * x + b * d ≈ + (a * x + b) * (c * x + d) +lemma₄ a b c d x = begin + (a * c * x + (a * d + b * c)) * x + b * d ≈⟨ distribʳ _ _ _ ⟨ +-cong ⟩ refl ⟩ + (a * c * x * x + (a * d + b * c) * x) + b * d ≈⟨ refl ⟨ +-cong ⟩ ((refl ⟨ +-cong ⟩ refl) ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ refl ⟩ + (a * c * x * x + (a * d + b * c) * x) + b * d ≈⟨ +-assoc _ _ _ ⟩ + a * c * x * x + ((a * d + b * c) * x + b * d) ≈⟨ lem₁ ⟨ +-cong ⟩ (lem₂ ⟨ +-cong ⟩ refl) ⟩ + a * x * (c * x) + (a * x * d + b * (c * x) + b * d) ≈⟨ refl ⟨ +-cong ⟩ +-assoc _ _ _ ⟩ + a * x * (c * x) + (a * x * d + (b * (c * x) + b * d)) ≈⟨ sym $ +-assoc _ _ _ ⟩ + a * x * (c * x) + a * x * d + (b * (c * x) + b * d) ≈⟨ sym $ distribˡ _ _ _ ⟨ +-cong ⟩ distribˡ _ _ _ ⟩ + a * x * (c * x + d) + b * (c * x + d) ≈⟨ sym $ distribʳ _ _ _ ⟩ + (a * x + b) * (c * x + d) ∎ + where + lem₁′ = begin + a * c * x ≈⟨ *-assoc _ _ _ ⟩ + a * (c * x) ≈⟨ refl ⟨ *-cong ⟩ *-comm _ _ ⟩ + a * (x * c) ≈⟨ sym $ *-assoc _ _ _ ⟩ + a * x * c ∎ - lem₁ = begin - a * c * x * x ≈⟨ lem₁′ ⟨ *-cong ⟩ refl ⟩ - a * x * c * x ≈⟨ *-assoc _ _ _ ⟩ - a * x * (c * x) ∎ + lem₁ = begin + a * c * x * x ≈⟨ lem₁′ ⟨ *-cong ⟩ refl ⟩ + a * x * c * x ≈⟨ *-assoc _ _ _ ⟩ + a * x * (c * x) ∎ - lem₂ = begin - (a * d + b * c) * x ≈⟨ distribʳ _ _ _ ⟩ - a * d * x + b * c * x ≈⟨ *-assoc _ _ _ ⟨ +-cong ⟩ *-assoc _ _ _ ⟩ - a * (d * x) + b * (c * x) ≈⟨ (refl ⟨ *-cong ⟩ *-comm _ _) ⟨ +-cong ⟩ refl ⟩ - a * (x * d) + b * (c * x) ≈⟨ sym $ *-assoc _ _ _ ⟨ +-cong ⟩ refl ⟩ - a * x * d + b * (c * x) ∎ + lem₂ = begin + (a * d + b * c) * x ≈⟨ distribʳ _ _ _ ⟩ + a * d * x + b * c * x ≈⟨ *-assoc _ _ _ ⟨ +-cong ⟩ *-assoc _ _ _ ⟩ + a * (d * x) + b * (c * x) ≈⟨ (refl ⟨ *-cong ⟩ *-comm _ _) ⟨ +-cong ⟩ refl ⟩ + a * (x * d) + b * (c * x) ≈⟨ sym $ *-assoc _ _ _ ⟨ +-cong ⟩ refl ⟩ + a * x * d + b * (c * x) ∎ -lemma₅ : ∀ x → (0# * x + 1#) * x + 0# ≈ x -lemma₅ x = begin - (0# * x + 1#) * x + 0# ≈⟨ ((zeroˡ _ ⟨ +-cong ⟩ refl) ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ refl ⟩ - (0# + 1#) * x + 0# ≈⟨ (+-identityˡ _ ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ refl ⟩ - 1# * x + 0# ≈⟨ +-identityʳ _ ⟩ - 1# * x ≈⟨ *-identityˡ _ ⟩ - x ∎ +lemma₅ : ∀ x → (0# * x + 1#) * x + 0# ≈ x +lemma₅ x = begin + (0# * x + 1#) * x + 0# ≈⟨ ((zeroˡ _ ⟨ +-cong ⟩ refl) ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ refl ⟩ + (0# + 1#) * x + 0# ≈⟨ (+-identityˡ _ ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ refl ⟩ + 1# * x + 0# ≈⟨ +-identityʳ _ ⟩ + 1# * x ≈⟨ *-identityˡ _ ⟩ + x ∎ -lemma₆ : ∀ a x → 0# * x + a ≈ a -lemma₆ a x = begin - 0# * x + a ≈⟨ zeroˡ _ ⟨ +-cong ⟩ refl ⟩ - 0# + a ≈⟨ +-identityˡ _ ⟩ - a ∎ +lemma₆ : ∀ a x → 0# * x + a ≈ a +lemma₆ a x = begin + 0# * x + a ≈⟨ zeroˡ _ ⟨ +-cong ⟩ refl ⟩ + 0# + a ≈⟨ +-identityˡ _ ⟩ + a ∎ -lemma₇ : ∀ x → - 1# * x ≈ - x -lemma₇ x = begin - - 1# * x ≈⟨ -‿*-distribˡ _ _ ⟩ - - (1# * x) ≈⟨ -‿cong (*-identityˡ _) ⟩ - - x ∎ +lemma₇ : ∀ x → - 1# * x ≈ - x +lemma₇ x = begin + - 1# * x ≈⟨ -‿*-distribˡ _ _ ⟩ + - (1# * x) ≈⟨ -‿cong (*-identityˡ _) ⟩ + - x ∎ \ No newline at end of file diff --git a/Algebra.Solver.Ring.Simple.html b/Algebra.Solver.Ring.Simple.html index af7726a5..88683559 100644 --- a/Algebra.Solver.Ring.Simple.html +++ b/Algebra.Solver.Ring.Simple.html @@ -9,15 +9,15 @@ {-# OPTIONS --cubical-compatible --safe #-} open import Algebra.Solver.Ring.AlmostCommutativeRing -open import Relation.Binary -open import Relation.Binary.Consequences using (dec⇒weaklyDec) +open import Relation.Binary.Definitions using (Decidable) +open import Relation.Binary.Consequences using (dec⇒weaklyDec) -module Algebra.Solver.Ring.Simple - {r₁ r₂} (R : AlmostCommutativeRing r₁ r₂) - (_≟_ : Decidable (AlmostCommutativeRing._≈_ R)) - where +module Algebra.Solver.Ring.Simple + {r₁ r₂} (R : AlmostCommutativeRing r₁ r₂) + (_≟_ : Decidable (AlmostCommutativeRing._≈_ R)) + where -open AlmostCommutativeRing R -import Algebra.Solver.Ring as RS -open RS rawRing R (-raw-almostCommutative⟶ R) (dec⇒weaklyDec _≟_) public +open AlmostCommutativeRing R +import Algebra.Solver.Ring as RS +open RS rawRing R (-raw-almostCommutative⟶ R) (dec⇒weaklyDec _≟_) public \ No newline at end of file diff --git a/Algebra.Solver.Ring.html b/Algebra.Solver.Ring.html index 6c8937b3..c8ba7131 100644 --- a/Algebra.Solver.Ring.html +++ b/Algebra.Solver.Ring.html @@ -20,534 +20,535 @@ open import Algebra.Bundles open import Algebra.Solver.Ring.AlmostCommutativeRing -open import Relation.Binary.Definitions using (WeaklyDecidable) +open import Relation.Binary.Definitions using (WeaklyDecidable) module Algebra.Solver.Ring {r₁ r₂ r₃ r₄} - (Coeff : RawRing r₁ r₄) -- Coefficient "ring". - (R : AlmostCommutativeRing r₂ r₃) -- Main "ring". - (morphism : Coeff -Raw-AlmostCommutative⟶ R) - (_coeff≟_ : WeaklyDecidable (Induced-equivalence morphism)) + (Coeff : RawRing r₁ r₄) -- Coefficient "ring". + (R : AlmostCommutativeRing r₂ r₃) -- Main "ring". + (morphism : Coeff -Raw-AlmostCommutative⟶ R) + (_coeff≟_ : WeaklyDecidable (Induced-equivalence morphism)) where open import Algebra.Core open import Algebra.Solver.Ring.Lemmas Coeff R morphism -private module C = RawRing Coeff -open AlmostCommutativeRing R - renaming (zero to *-zero; zeroˡ to *-zeroˡ; zeroʳ to *-zeroʳ) -open import Algebra.Definitions _≈_ +private module C = RawRing Coeff +open AlmostCommutativeRing R + renaming (zero to *-zero; zeroˡ to *-zeroˡ; zeroʳ to *-zeroʳ) +open import Algebra.Definitions _≈_ open import Algebra.Morphism -open _-Raw-AlmostCommutative⟶_ morphism renaming (⟦_⟧ to ⟦_⟧′) -open import Algebra.Properties.Semiring.Exp semiring - -open import Relation.Binary -open import Relation.Nullary.Decidable using (yes; no) -open import Relation.Binary.Reasoning.Setoid setoid -import Relation.Binary.PropositionalEquality as PropEq -import Relation.Binary.Reflection as Reflection - -open import Data.Nat.Base using (ℕ; suc; zero) -open import Data.Fin.Base using (Fin; zero; suc) -open import Data.Vec.Base using (Vec; []; _∷_; lookup) -open import Data.Maybe.Base using (just; nothing) -open import Function -open import Level using (_⊔_) - -infix 9 :-_ -H_ -N_ -infixr 9 _:×_ _:^_ _^N_ -infix 8 _*x+_ _*x+HN_ _*x+H_ -infixl 8 _:*_ _*N_ _*H_ _*NH_ _*HN_ -infixl 7 _:+_ _:-_ _+H_ _+N_ -infix 4 _≈H_ _≈N_ - ------------------------------------------------------------------------- --- Polynomials - -data Op : Set where - [+] : Op - [*] : Op - --- The polynomials are indexed by the number of variables. - -data Polynomial (m : ℕ) : Set r₁ where - op : (o : Op) (p₁ : Polynomial m) (p₂ : Polynomial m) → Polynomial m - con : (c : C.Carrier) → Polynomial m - var : (x : Fin m) → Polynomial m - _:^_ : (p : Polynomial m) (n : ℕ) → Polynomial m - :-_ : (p : Polynomial m) → Polynomial m - --- Short-hand notation. - -_:+_ : ∀ {n} → Polynomial n → Polynomial n → Polynomial n -_:+_ = op [+] - -_:*_ : ∀ {n} → Polynomial n → Polynomial n → Polynomial n -_:*_ = op [*] - -_:-_ : ∀ {n} → Polynomial n → Polynomial n → Polynomial n -x :- y = x :+ :- y - -_:×_ : ∀ {n} → ℕ → Polynomial n → Polynomial n -zero :× p = con C.0# -suc m :× p = p :+ m :× p - --- Semantics. - -sem : Op → Op₂ Carrier -sem [+] = _+_ -sem [*] = _*_ - -⟦_⟧ : ∀ {n} → Polynomial n → Vec Carrier n → Carrier -⟦ op o p₁ p₂ ⟧ ρ = ⟦ p₁ ⟧ ρ ⟨ sem o ⟩ ⟦ p₂ ⟧ ρ -⟦ con c ⟧ ρ = ⟦ c ⟧′ -⟦ var x ⟧ ρ = lookup ρ x -⟦ p :^ n ⟧ ρ = ⟦ p ⟧ ρ ^ n -⟦ :- p ⟧ ρ = - ⟦ p ⟧ ρ - ------------------------------------------------------------------------- --- Normal forms of polynomials - --- A univariate polynomial of degree d, --- --- p = a_d x^d + a_{d-1}x^{d-1} + … + a_0, --- --- is represented in Horner normal form by --- --- p = ((a_d x + a_{d-1})x + …)x + a_0. --- --- Note that Horner normal forms can be represented as lists, with the --- empty list standing for the zero polynomial of degree "-1". --- --- Given this representation of univariate polynomials over an --- arbitrary ring, polynomials in any number of variables over the --- ring C can be represented via the isomorphisms --- --- C[] ≅ C --- --- and --- --- C[X_0,...X_{n+1}] ≅ C[X_0,...,X_n][X_{n+1}]. - -mutual - - -- The polynomial representations are indexed by the polynomial's - -- degree. - - data HNF : ℕ → Set r₁ where - ∅ : ∀ {n} → HNF (suc n) - _*x+_ : ∀ {n} → HNF (suc n) → Normal n → HNF (suc n) - - data Normal : ℕ → Set r₁ where - con : C.Carrier → Normal zero - poly : ∀ {n} → HNF (suc n) → Normal (suc n) - - -- Note that the data types above do /not/ ensure uniqueness of - -- normal forms: the zero polynomial of degree one can be - -- represented using both ∅ and ∅ *x+ con C.0#. +open _-Raw-AlmostCommutative⟶_ morphism renaming (⟦_⟧ to ⟦_⟧′) +open import Algebra.Properties.Semiring.Exp semiring + +open import Relation.Nullary.Decidable using (yes; no) +open import Relation.Binary.Reasoning.Setoid setoid +import Relation.Binary.PropositionalEquality.Core as PropEq +import Relation.Binary.Reflection as Reflection + +open import Data.Nat.Base using (ℕ; suc; zero) +open import Data.Fin.Base using (Fin; zero; suc) +open import Data.Vec.Base using (Vec; []; _∷_; lookup) +open import Data.Maybe.Base using (just; nothing) +open import Function.Base using (_⟨_⟩_; _$_) +open import Level using (_⊔_) + +infix 9 :-_ -H_ -N_ +infixr 9 _:×_ _:^_ _^N_ +infix 8 _*x+_ _*x+HN_ _*x+H_ +infixl 8 _:*_ _*N_ _*H_ _*NH_ _*HN_ +infixl 7 _:+_ _:-_ _+H_ _+N_ +infix 4 _≈H_ _≈N_ + +------------------------------------------------------------------------ +-- Polynomials + +data Op : Set where + [+] : Op + [*] : Op + +-- The polynomials are indexed by the number of variables. + +data Polynomial (m : ℕ) : Set r₁ where + op : (o : Op) (p₁ : Polynomial m) (p₂ : Polynomial m) → Polynomial m + con : (c : C.Carrier) → Polynomial m + var : (x : Fin m) → Polynomial m + _:^_ : (p : Polynomial m) (n : ℕ) → Polynomial m + :-_ : (p : Polynomial m) → Polynomial m + +-- Short-hand notation. + +_:+_ : ∀ {n} → Polynomial n → Polynomial n → Polynomial n +_:+_ = op [+] -mutual +_:*_ : ∀ {n} → Polynomial n → Polynomial n → Polynomial n +_:*_ = op [*] + +_:-_ : ∀ {n} → Polynomial n → Polynomial n → Polynomial n +x :- y = x :+ :- y + +_:×_ : ∀ {n} → ℕ → Polynomial n → Polynomial n +zero :× p = con C.0# +suc m :× p = p :+ m :× p + +-- Semantics. + +sem : Op → Op₂ Carrier +sem [+] = _+_ +sem [*] = _*_ + +⟦_⟧ : ∀ {n} → Polynomial n → Vec Carrier n → Carrier +⟦ op o p₁ p₂ ⟧ ρ = ⟦ p₁ ⟧ ρ ⟨ sem o ⟩ ⟦ p₂ ⟧ ρ +⟦ con c ⟧ ρ = ⟦ c ⟧′ +⟦ var x ⟧ ρ = lookup ρ x +⟦ p :^ n ⟧ ρ = ⟦ p ⟧ ρ ^ n +⟦ :- p ⟧ ρ = - ⟦ p ⟧ ρ + +------------------------------------------------------------------------ +-- Normal forms of polynomials + +-- A univariate polynomial of degree d, +-- +-- p = a_d x^d + a_{d-1}x^{d-1} + … + a_0, +-- +-- is represented in Horner normal form by +-- +-- p = ((a_d x + a_{d-1})x + …)x + a_0. +-- +-- Note that Horner normal forms can be represented as lists, with the +-- empty list standing for the zero polynomial of degree "-1". +-- +-- Given this representation of univariate polynomials over an +-- arbitrary ring, polynomials in any number of variables over the +-- ring C can be represented via the isomorphisms +-- +-- C[] ≅ C +-- +-- and +-- +-- C[X_0,...X_{n+1}] ≅ C[X_0,...,X_n][X_{n+1}]. + +mutual + + -- The polynomial representations are indexed by the polynomial's + -- degree. - -- Semantics. + data HNF : ℕ → Set r₁ where + ∅ : ∀ {n} → HNF (suc n) + _*x+_ : ∀ {n} → HNF (suc n) → Normal n → HNF (suc n) - ⟦_⟧H : ∀ {n} → HNF (suc n) → Vec Carrier (suc n) → Carrier - ⟦ ∅ ⟧H _ = 0# - ⟦ p *x+ c ⟧H (x ∷ ρ) = ⟦ p ⟧H (x ∷ ρ) * x + ⟦ c ⟧N ρ + data Normal : ℕ → Set r₁ where + con : C.Carrier → Normal zero + poly : ∀ {n} → HNF (suc n) → Normal (suc n) - ⟦_⟧N : ∀ {n} → Normal n → Vec Carrier n → Carrier - ⟦ con c ⟧N _ = ⟦ c ⟧′ - ⟦ poly p ⟧N ρ = ⟦ p ⟧H ρ + -- Note that the data types above do /not/ ensure uniqueness of + -- normal forms: the zero polynomial of degree one can be + -- represented using both ∅ and ∅ *x+ con C.0#. ------------------------------------------------------------------------- --- Equality and decidability +mutual -mutual + -- Semantics. - -- Equality. + ⟦_⟧H : ∀ {n} → HNF (suc n) → Vec Carrier (suc n) → Carrier + ⟦ ∅ ⟧H _ = 0# + ⟦ p *x+ c ⟧H (x ∷ ρ) = ⟦ p ⟧H (x ∷ ρ) * x + ⟦ c ⟧N ρ - data _≈H_ : ∀ {n} → HNF n → HNF n → Set (r₁ ⊔ r₃) where - ∅ : ∀ {n} → _≈H_ {suc n} ∅ ∅ - _*x+_ : ∀ {n} {p₁ p₂ : HNF (suc n)} {c₁ c₂ : Normal n} → - p₁ ≈H p₂ → c₁ ≈N c₂ → (p₁ *x+ c₁) ≈H (p₂ *x+ c₂) + ⟦_⟧N : ∀ {n} → Normal n → Vec Carrier n → Carrier + ⟦ con c ⟧N _ = ⟦ c ⟧′ + ⟦ poly p ⟧N ρ = ⟦ p ⟧H ρ - data _≈N_ : ∀ {n} → Normal n → Normal n → Set (r₁ ⊔ r₃) where - con : ∀ {c₁ c₂} → ⟦ c₁ ⟧′ ≈ ⟦ c₂ ⟧′ → con c₁ ≈N con c₂ - poly : ∀ {n} {p₁ p₂ : HNF (suc n)} → p₁ ≈H p₂ → poly p₁ ≈N poly p₂ +------------------------------------------------------------------------ +-- Equality and decidability -mutual +mutual - -- Equality is weakly decidable. + -- Equality. - _≟H_ : ∀ {n} → WeaklyDecidable (_≈H_ {n = n}) - ∅ ≟H ∅ = just ∅ - ∅ ≟H (_ *x+ _) = nothing - (_ *x+ _) ≟H ∅ = nothing - (p₁ *x+ c₁) ≟H (p₂ *x+ c₂) with p₁ ≟H p₂ | c₁ ≟N c₂ - ... | just p₁≈p₂ | just c₁≈c₂ = just (p₁≈p₂ *x+ c₁≈c₂) - ... | _ | nothing = nothing - ... | nothing | _ = nothing - - _≟N_ : ∀ {n} → WeaklyDecidable (_≈N_ {n = n}) - con c₁ ≟N con c₂ with c₁ coeff≟ c₂ - ... | just c₁≈c₂ = just (con c₁≈c₂) - ... | nothing = nothing - poly p₁ ≟N poly p₂ with p₁ ≟H p₂ - ... | just p₁≈p₂ = just (poly p₁≈p₂) - ... | nothing = nothing - -mutual + data _≈H_ : ∀ {n} → HNF n → HNF n → Set (r₁ ⊔ r₃) where + ∅ : ∀ {n} → _≈H_ {suc n} ∅ ∅ + _*x+_ : ∀ {n} {p₁ p₂ : HNF (suc n)} {c₁ c₂ : Normal n} → + p₁ ≈H p₂ → c₁ ≈N c₂ → (p₁ *x+ c₁) ≈H (p₂ *x+ c₂) - -- The semantics respect the equality relations defined above. + data _≈N_ : ∀ {n} → Normal n → Normal n → Set (r₁ ⊔ r₃) where + con : ∀ {c₁ c₂} → ⟦ c₁ ⟧′ ≈ ⟦ c₂ ⟧′ → con c₁ ≈N con c₂ + poly : ∀ {n} {p₁ p₂ : HNF (suc n)} → p₁ ≈H p₂ → poly p₁ ≈N poly p₂ - ⟦_⟧H-cong : ∀ {n} {p₁ p₂ : HNF (suc n)} → - p₁ ≈H p₂ → ∀ ρ → ⟦ p₁ ⟧H ρ ≈ ⟦ p₂ ⟧H ρ - ⟦ ∅ ⟧H-cong _ = refl - ⟦ p₁≈p₂ *x+ c₁≈c₂ ⟧H-cong (x ∷ ρ) = - (⟦ p₁≈p₂ ⟧H-cong (x ∷ ρ) ⟨ *-cong ⟩ refl) - ⟨ +-cong ⟩ - ⟦ c₁≈c₂ ⟧N-cong ρ +mutual - ⟦_⟧N-cong : - ∀ {n} {p₁ p₂ : Normal n} → - p₁ ≈N p₂ → ∀ ρ → ⟦ p₁ ⟧N ρ ≈ ⟦ p₂ ⟧N ρ - ⟦ con c₁≈c₂ ⟧N-cong _ = c₁≈c₂ - ⟦ poly p₁≈p₂ ⟧N-cong ρ = ⟦ p₁≈p₂ ⟧H-cong ρ + -- Equality is weakly decidable. ------------------------------------------------------------------------- --- Ring operations on Horner normal forms + infix 4 _≟H_ _≟N_ --- Zero. + _≟H_ : ∀ {n} → WeaklyDecidable (_≈H_ {n = n}) + ∅ ≟H ∅ = just ∅ + ∅ ≟H (_ *x+ _) = nothing + (_ *x+ _) ≟H ∅ = nothing + (p₁ *x+ c₁) ≟H (p₂ *x+ c₂) with p₁ ≟H p₂ | c₁ ≟N c₂ + ... | just p₁≈p₂ | just c₁≈c₂ = just (p₁≈p₂ *x+ c₁≈c₂) + ... | _ | nothing = nothing + ... | nothing | _ = nothing + + _≟N_ : ∀ {n} → WeaklyDecidable (_≈N_ {n = n}) + con c₁ ≟N con c₂ with c₁ coeff≟ c₂ + ... | just c₁≈c₂ = just (con c₁≈c₂) + ... | nothing = nothing + poly p₁ ≟N poly p₂ with p₁ ≟H p₂ + ... | just p₁≈p₂ = just (poly p₁≈p₂) + ... | nothing = nothing -0H : ∀ {n} → HNF (suc n) -0H = ∅ +mutual -0N : ∀ {n} → Normal n -0N {zero} = con C.0# -0N {suc n} = poly 0H + -- The semantics respect the equality relations defined above. -mutual + ⟦_⟧H-cong : ∀ {n} {p₁ p₂ : HNF (suc n)} → + p₁ ≈H p₂ → ∀ ρ → ⟦ p₁ ⟧H ρ ≈ ⟦ p₂ ⟧H ρ + ⟦ ∅ ⟧H-cong _ = refl + ⟦ p₁≈p₂ *x+ c₁≈c₂ ⟧H-cong (x ∷ ρ) = + (⟦ p₁≈p₂ ⟧H-cong (x ∷ ρ) ⟨ *-cong ⟩ refl) + ⟨ +-cong ⟩ + ⟦ c₁≈c₂ ⟧N-cong ρ - -- One. + ⟦_⟧N-cong : + ∀ {n} {p₁ p₂ : Normal n} → + p₁ ≈N p₂ → ∀ ρ → ⟦ p₁ ⟧N ρ ≈ ⟦ p₂ ⟧N ρ + ⟦ con c₁≈c₂ ⟧N-cong _ = c₁≈c₂ + ⟦ poly p₁≈p₂ ⟧N-cong ρ = ⟦ p₁≈p₂ ⟧H-cong ρ - 1H : ∀ {n} → HNF (suc n) - 1H {n} = ∅ *x+ 1N {n} +------------------------------------------------------------------------ +-- Ring operations on Horner normal forms - 1N : ∀ {n} → Normal n - 1N {zero} = con C.1# - 1N {suc n} = poly 1H +-- Zero. --- A simplifying variant of _*x+_. +0H : ∀ {n} → HNF (suc n) +0H = ∅ -_*x+HN_ : ∀ {n} → HNF (suc n) → Normal n → HNF (suc n) -(p *x+ c′) *x+HN c = (p *x+ c′) *x+ c -∅ *x+HN c with c ≟N 0N -... | just c≈0 = ∅ -... | nothing = ∅ *x+ c +0N : ∀ {n} → Normal n +0N {zero} = con C.0# +0N {suc n} = poly 0H -mutual +mutual - -- Addition. + -- One. - _+H_ : ∀ {n} → HNF (suc n) → HNF (suc n) → HNF (suc n) - ∅ +H p = p - p +H ∅ = p - (p₁ *x+ c₁) +H (p₂ *x+ c₂) = (p₁ +H p₂) *x+HN (c₁ +N c₂) + 1H : ∀ {n} → HNF (suc n) + 1H {n} = ∅ *x+ 1N {n} - _+N_ : ∀ {n} → Normal n → Normal n → Normal n - con c₁ +N con c₂ = con (c₁ C.+ c₂) - poly p₁ +N poly p₂ = poly (p₁ +H p₂) + 1N : ∀ {n} → Normal n + 1N {zero} = con C.1# + 1N {suc n} = poly 1H --- Multiplication. +-- A simplifying variant of _*x+_. -_*x+H_ : ∀ {n} → HNF (suc n) → HNF (suc n) → HNF (suc n) -p₁ *x+H (p₂ *x+ c) = (p₁ +H p₂) *x+HN c -∅ *x+H ∅ = ∅ -(p₁ *x+ c) *x+H ∅ = (p₁ *x+ c) *x+ 0N +_*x+HN_ : ∀ {n} → HNF (suc n) → Normal n → HNF (suc n) +(p *x+ c′) *x+HN c = (p *x+ c′) *x+ c +∅ *x+HN c with c ≟N 0N +... | just c≈0 = ∅ +... | nothing = ∅ *x+ c -mutual +mutual - _*NH_ : ∀ {n} → Normal n → HNF (suc n) → HNF (suc n) - c *NH ∅ = ∅ - c *NH (p *x+ c′) with c ≟N 0N - ... | just c≈0 = ∅ - ... | nothing = (c *NH p) *x+ (c *N c′) + -- Addition. - _*HN_ : ∀ {n} → HNF (suc n) → Normal n → HNF (suc n) - ∅ *HN c = ∅ - (p *x+ c′) *HN c with c ≟N 0N - ... | just c≈0 = ∅ - ... | nothing = (p *HN c) *x+ (c′ *N c) + _+H_ : ∀ {n} → HNF (suc n) → HNF (suc n) → HNF (suc n) + ∅ +H p = p + p +H ∅ = p + (p₁ *x+ c₁) +H (p₂ *x+ c₂) = (p₁ +H p₂) *x+HN (c₁ +N c₂) - _*H_ : ∀ {n} → HNF (suc n) → HNF (suc n) → HNF (suc n) - ∅ *H _ = ∅ - (_ *x+ _) *H ∅ = ∅ - (p₁ *x+ c₁) *H (p₂ *x+ c₂) = - ((p₁ *H p₂) *x+H (p₁ *HN c₂ +H c₁ *NH p₂)) *x+HN (c₁ *N c₂) + _+N_ : ∀ {n} → Normal n → Normal n → Normal n + con c₁ +N con c₂ = con (c₁ C.+ c₂) + poly p₁ +N poly p₂ = poly (p₁ +H p₂) - _*N_ : ∀ {n} → Normal n → Normal n → Normal n - con c₁ *N con c₂ = con (c₁ C.* c₂) - poly p₁ *N poly p₂ = poly (p₁ *H p₂) +-- Multiplication. --- Exponentiation. +_*x+H_ : ∀ {n} → HNF (suc n) → HNF (suc n) → HNF (suc n) +p₁ *x+H (p₂ *x+ c) = (p₁ +H p₂) *x+HN c +∅ *x+H ∅ = ∅ +(p₁ *x+ c) *x+H ∅ = (p₁ *x+ c) *x+ 0N -_^N_ : ∀ {n} → Normal n → ℕ → Normal n -p ^N zero = 1N -p ^N suc n = p *N (p ^N n) +mutual -mutual + _*NH_ : ∀ {n} → Normal n → HNF (suc n) → HNF (suc n) + c *NH ∅ = ∅ + c *NH (p *x+ c′) with c ≟N 0N + ... | just c≈0 = ∅ + ... | nothing = (c *NH p) *x+ (c *N c′) - -- Negation. + _*HN_ : ∀ {n} → HNF (suc n) → Normal n → HNF (suc n) + ∅ *HN c = ∅ + (p *x+ c′) *HN c with c ≟N 0N + ... | just c≈0 = ∅ + ... | nothing = (p *HN c) *x+ (c′ *N c) - -H_ : ∀ {n} → HNF (suc n) → HNF (suc n) - -H p = (-N 1N) *NH p - - -N_ : ∀ {n} → Normal n → Normal n - -N con c = con (C.- c) - -N poly p = poly (-H p) + _*H_ : ∀ {n} → HNF (suc n) → HNF (suc n) → HNF (suc n) + ∅ *H _ = ∅ + (_ *x+ _) *H ∅ = ∅ + (p₁ *x+ c₁) *H (p₂ *x+ c₂) = + ((p₁ *H p₂) *x+H (p₁ *HN c₂ +H c₁ *NH p₂)) *x+HN (c₁ *N c₂) ------------------------------------------------------------------------- --- Normalisation + _*N_ : ∀ {n} → Normal n → Normal n → Normal n + con c₁ *N con c₂ = con (c₁ C.* c₂) + poly p₁ *N poly p₂ = poly (p₁ *H p₂) -normalise-con : ∀ {n} → C.Carrier → Normal n -normalise-con {zero} c = con c -normalise-con {suc n} c = poly (∅ *x+HN normalise-con c) +-- Exponentiation. -normalise-var : ∀ {n} → Fin n → Normal n -normalise-var zero = poly ((∅ *x+ 1N) *x+ 0N) -normalise-var (suc i) = poly (∅ *x+HN normalise-var i) - -normalise : ∀ {n} → Polynomial n → Normal n -normalise (op [+] t₁ t₂) = normalise t₁ +N normalise t₂ -normalise (op [*] t₁ t₂) = normalise t₁ *N normalise t₂ -normalise (con c) = normalise-con c -normalise (var i) = normalise-var i -normalise (t :^ k) = normalise t ^N k -normalise (:- t) = -N normalise t - --- Evaluation after normalisation. - -⟦_⟧↓ : ∀ {n} → Polynomial n → Vec Carrier n → Carrier -⟦ p ⟧↓ ρ = ⟦ normalise p ⟧N ρ - ------------------------------------------------------------------------- --- Homomorphism lemmas - -0N-homo : ∀ {n} ρ → ⟦ 0N {n} ⟧N ρ ≈ 0# -0N-homo [] = 0-homo -0N-homo (x ∷ ρ) = refl - --- If c is equal to 0N, then c is semantically equal to 0#. - -0≈⟦0⟧ : ∀ {n} {c : Normal n} → c ≈N 0N → ∀ ρ → 0# ≈ ⟦ c ⟧N ρ -0≈⟦0⟧ {c = c} c≈0 ρ = sym (begin - ⟦ c ⟧N ρ ≈⟨ ⟦ c≈0 ⟧N-cong ρ ⟩ - ⟦ 0N ⟧N ρ ≈⟨ 0N-homo ρ ⟩ - 0# ∎) - -1N-homo : ∀ {n} ρ → ⟦ 1N {n} ⟧N ρ ≈ 1# -1N-homo [] = 1-homo -1N-homo (x ∷ ρ) = begin - 0# * x + ⟦ 1N ⟧N ρ ≈⟨ refl ⟨ +-cong ⟩ 1N-homo ρ ⟩ - 0# * x + 1# ≈⟨ lemma₆ _ _ ⟩ - 1# ∎ - --- _*x+HN_ is equal to _*x+_. - -*x+HN≈*x+ : ∀ {n} (p : HNF (suc n)) (c : Normal n) → - ∀ ρ → ⟦ p *x+HN c ⟧H ρ ≈ ⟦ p *x+ c ⟧H ρ -*x+HN≈*x+ (p *x+ c′) c ρ = refl -*x+HN≈*x+ ∅ c (x ∷ ρ) with c ≟N 0N -... | just c≈0 = begin - 0# ≈⟨ 0≈⟦0⟧ c≈0 ρ ⟩ - ⟦ c ⟧N ρ ≈⟨ sym $ lemma₆ _ _ ⟩ - 0# * x + ⟦ c ⟧N ρ ∎ -... | nothing = refl - -∅*x+HN-homo : ∀ {n} (c : Normal n) x ρ → - ⟦ ∅ *x+HN c ⟧H (x ∷ ρ) ≈ ⟦ c ⟧N ρ -∅*x+HN-homo c x ρ with c ≟N 0N -... | just c≈0 = 0≈⟦0⟧ c≈0 ρ -... | nothing = lemma₆ _ _ - -mutual - - +H-homo : ∀ {n} (p₁ p₂ : HNF (suc n)) → - ∀ ρ → ⟦ p₁ +H p₂ ⟧H ρ ≈ ⟦ p₁ ⟧H ρ + ⟦ p₂ ⟧H ρ - +H-homo ∅ p₂ ρ = sym (+-identityˡ _) - +H-homo (p₁ *x+ x₁) ∅ ρ = sym (+-identityʳ _) - +H-homo (p₁ *x+ c₁) (p₂ *x+ c₂) (x ∷ ρ) = begin - ⟦ (p₁ +H p₂) *x+HN (c₁ +N c₂) ⟧H (x ∷ ρ) ≈⟨ *x+HN≈*x+ (p₁ +H p₂) (c₁ +N c₂) (x ∷ ρ) ⟩ - - ⟦ p₁ +H p₂ ⟧H (x ∷ ρ) * x + ⟦ c₁ +N c₂ ⟧N ρ ≈⟨ (+H-homo p₁ p₂ (x ∷ ρ) ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ +N-homo c₁ c₂ ρ ⟩ - - (⟦ p₁ ⟧H (x ∷ ρ) + ⟦ p₂ ⟧H (x ∷ ρ)) * x + (⟦ c₁ ⟧N ρ + ⟦ c₂ ⟧N ρ) ≈⟨ lemma₁ _ _ _ _ _ ⟩ - - (⟦ p₁ ⟧H (x ∷ ρ) * x + ⟦ c₁ ⟧N ρ) + - (⟦ p₂ ⟧H (x ∷ ρ) * x + ⟦ c₂ ⟧N ρ) ∎ - - +N-homo : ∀ {n} (p₁ p₂ : Normal n) → - ∀ ρ → ⟦ p₁ +N p₂ ⟧N ρ ≈ ⟦ p₁ ⟧N ρ + ⟦ p₂ ⟧N ρ - +N-homo (con c₁) (con c₂) _ = +-homo _ _ - +N-homo (poly p₁) (poly p₂) ρ = +H-homo p₁ p₂ ρ - -*x+H-homo : - ∀ {n} (p₁ p₂ : HNF (suc n)) x ρ → - ⟦ p₁ *x+H p₂ ⟧H (x ∷ ρ) ≈ - ⟦ p₁ ⟧H (x ∷ ρ) * x + ⟦ p₂ ⟧H (x ∷ ρ) -*x+H-homo ∅ ∅ _ _ = sym $ lemma₆ _ _ -*x+H-homo (p *x+ c) ∅ x ρ = begin - ⟦ p *x+ c ⟧H (x ∷ ρ) * x + ⟦ 0N ⟧N ρ ≈⟨ refl ⟨ +-cong ⟩ 0N-homo ρ ⟩ - ⟦ p *x+ c ⟧H (x ∷ ρ) * x + 0# ∎ -*x+H-homo p₁ (p₂ *x+ c₂) x ρ = begin - ⟦ (p₁ +H p₂) *x+HN c₂ ⟧H (x ∷ ρ) ≈⟨ *x+HN≈*x+ (p₁ +H p₂) c₂ (x ∷ ρ) ⟩ - ⟦ p₁ +H p₂ ⟧H (x ∷ ρ) * x + ⟦ c₂ ⟧N ρ ≈⟨ (+H-homo p₁ p₂ (x ∷ ρ) ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ refl ⟩ - (⟦ p₁ ⟧H (x ∷ ρ) + ⟦ p₂ ⟧H (x ∷ ρ)) * x + ⟦ c₂ ⟧N ρ ≈⟨ lemma₀ _ _ _ _ ⟩ - ⟦ p₁ ⟧H (x ∷ ρ) * x + (⟦ p₂ ⟧H (x ∷ ρ) * x + ⟦ c₂ ⟧N ρ) ∎ - -mutual - - *NH-homo : - ∀ {n} (c : Normal n) (p : HNF (suc n)) x ρ → - ⟦ c *NH p ⟧H (x ∷ ρ) ≈ ⟦ c ⟧N ρ * ⟦ p ⟧H (x ∷ ρ) - *NH-homo c ∅ x ρ = sym (*-zeroʳ _) - *NH-homo c (p *x+ c′) x ρ with c ≟N 0N - ... | just c≈0 = begin - 0# ≈⟨ sym (*-zeroˡ _) ⟩ - 0# * (⟦ p ⟧H (x ∷ ρ) * x + ⟦ c′ ⟧N ρ) ≈⟨ 0≈⟦0⟧ c≈0 ρ ⟨ *-cong ⟩ refl ⟩ - ⟦ c ⟧N ρ * (⟦ p ⟧H (x ∷ ρ) * x + ⟦ c′ ⟧N ρ) ∎ - ... | nothing = begin - ⟦ c *NH p ⟧H (x ∷ ρ) * x + ⟦ c *N c′ ⟧N ρ ≈⟨ (*NH-homo c p x ρ ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ *N-homo c c′ ρ ⟩ - (⟦ c ⟧N ρ * ⟦ p ⟧H (x ∷ ρ)) * x + (⟦ c ⟧N ρ * ⟦ c′ ⟧N ρ) ≈⟨ lemma₃ _ _ _ _ ⟩ - ⟦ c ⟧N ρ * (⟦ p ⟧H (x ∷ ρ) * x + ⟦ c′ ⟧N ρ) ∎ - - *HN-homo : - ∀ {n} (p : HNF (suc n)) (c : Normal n) x ρ → - ⟦ p *HN c ⟧H (x ∷ ρ) ≈ ⟦ p ⟧H (x ∷ ρ) * ⟦ c ⟧N ρ - *HN-homo ∅ c x ρ = sym (*-zeroˡ _) - *HN-homo (p *x+ c′) c x ρ with c ≟N 0N - ... | just c≈0 = begin - 0# ≈⟨ sym (*-zeroʳ _) ⟩ - (⟦ p ⟧H (x ∷ ρ) * x + ⟦ c′ ⟧N ρ) * 0# ≈⟨ refl ⟨ *-cong ⟩ 0≈⟦0⟧ c≈0 ρ ⟩ - (⟦ p ⟧H (x ∷ ρ) * x + ⟦ c′ ⟧N ρ) * ⟦ c ⟧N ρ ∎ - ... | nothing = begin - ⟦ p *HN c ⟧H (x ∷ ρ) * x + ⟦ c′ *N c ⟧N ρ ≈⟨ (*HN-homo p c x ρ ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ *N-homo c′ c ρ ⟩ - (⟦ p ⟧H (x ∷ ρ) * ⟦ c ⟧N ρ) * x + (⟦ c′ ⟧N ρ * ⟦ c ⟧N ρ) ≈⟨ lemma₂ _ _ _ _ ⟩ - (⟦ p ⟧H (x ∷ ρ) * x + ⟦ c′ ⟧N ρ) * ⟦ c ⟧N ρ ∎ - - *H-homo : ∀ {n} (p₁ p₂ : HNF (suc n)) → - ∀ ρ → ⟦ p₁ *H p₂ ⟧H ρ ≈ ⟦ p₁ ⟧H ρ * ⟦ p₂ ⟧H ρ - *H-homo ∅ p₂ ρ = sym $ *-zeroˡ _ - *H-homo (p₁ *x+ c₁) ∅ ρ = sym $ *-zeroʳ _ - *H-homo (p₁ *x+ c₁) (p₂ *x+ c₂) (x ∷ ρ) = begin - ⟦ ((p₁ *H p₂) *x+H ((p₁ *HN c₂) +H (c₁ *NH p₂))) *x+HN - (c₁ *N c₂) ⟧H (x ∷ ρ) ≈⟨ *x+HN≈*x+ ((p₁ *H p₂) *x+H ((p₁ *HN c₂) +H (c₁ *NH p₂))) - (c₁ *N c₂) (x ∷ ρ) ⟩ - ⟦ (p₁ *H p₂) *x+H - ((p₁ *HN c₂) +H (c₁ *NH p₂)) ⟧H (x ∷ ρ) * x + - ⟦ c₁ *N c₂ ⟧N ρ ≈⟨ (*x+H-homo (p₁ *H p₂) ((p₁ *HN c₂) +H (c₁ *NH p₂)) x ρ - ⟨ *-cong ⟩ - refl) - ⟨ +-cong ⟩ - *N-homo c₁ c₂ ρ ⟩ - (⟦ p₁ *H p₂ ⟧H (x ∷ ρ) * x + - ⟦ (p₁ *HN c₂) +H (c₁ *NH p₂) ⟧H (x ∷ ρ)) * x + - ⟦ c₁ ⟧N ρ * ⟦ c₂ ⟧N ρ ≈⟨ (((*H-homo p₁ p₂ (x ∷ ρ) ⟨ *-cong ⟩ refl) - ⟨ +-cong ⟩ - (+H-homo (p₁ *HN c₂) (c₁ *NH p₂) (x ∷ ρ))) - ⟨ *-cong ⟩ - refl) - ⟨ +-cong ⟩ - refl ⟩ - (⟦ p₁ ⟧H (x ∷ ρ) * ⟦ p₂ ⟧H (x ∷ ρ) * x + - (⟦ p₁ *HN c₂ ⟧H (x ∷ ρ) + ⟦ c₁ *NH p₂ ⟧H (x ∷ ρ))) * x + - ⟦ c₁ ⟧N ρ * ⟦ c₂ ⟧N ρ ≈⟨ ((refl ⟨ +-cong ⟩ (*HN-homo p₁ c₂ x ρ ⟨ +-cong ⟩ *NH-homo c₁ p₂ x ρ)) - ⟨ *-cong ⟩ - refl) - ⟨ +-cong ⟩ - refl ⟩ - (⟦ p₁ ⟧H (x ∷ ρ) * ⟦ p₂ ⟧H (x ∷ ρ) * x + - (⟦ p₁ ⟧H (x ∷ ρ) * ⟦ c₂ ⟧N ρ + ⟦ c₁ ⟧N ρ * ⟦ p₂ ⟧H (x ∷ ρ))) * x + - (⟦ c₁ ⟧N ρ * ⟦ c₂ ⟧N ρ) ≈⟨ lemma₄ _ _ _ _ _ ⟩ - - (⟦ p₁ ⟧H (x ∷ ρ) * x + ⟦ c₁ ⟧N ρ) * - (⟦ p₂ ⟧H (x ∷ ρ) * x + ⟦ c₂ ⟧N ρ) ∎ - - *N-homo : ∀ {n} (p₁ p₂ : Normal n) → - ∀ ρ → ⟦ p₁ *N p₂ ⟧N ρ ≈ ⟦ p₁ ⟧N ρ * ⟦ p₂ ⟧N ρ - *N-homo (con c₁) (con c₂) _ = *-homo _ _ - *N-homo (poly p₁) (poly p₂) ρ = *H-homo p₁ p₂ ρ - -^N-homo : ∀ {n} (p : Normal n) (k : ℕ) → - ∀ ρ → ⟦ p ^N k ⟧N ρ ≈ ⟦ p ⟧N ρ ^ k -^N-homo p zero ρ = 1N-homo ρ -^N-homo p (suc k) ρ = begin - ⟦ p *N (p ^N k) ⟧N ρ ≈⟨ *N-homo p (p ^N k) ρ ⟩ - ⟦ p ⟧N ρ * ⟦ p ^N k ⟧N ρ ≈⟨ refl ⟨ *-cong ⟩ ^N-homo p k ρ ⟩ - ⟦ p ⟧N ρ * (⟦ p ⟧N ρ ^ k) ∎ - -mutual - - -H‿-homo : ∀ {n} (p : HNF (suc n)) → - ∀ ρ → ⟦ -H p ⟧H ρ ≈ - ⟦ p ⟧H ρ - -H‿-homo p (x ∷ ρ) = begin - ⟦ (-N 1N) *NH p ⟧H (x ∷ ρ) ≈⟨ *NH-homo (-N 1N) p x ρ ⟩ - ⟦ -N 1N ⟧N ρ * ⟦ p ⟧H (x ∷ ρ) ≈⟨ trans (-N‿-homo 1N ρ) (-‿cong (1N-homo ρ)) ⟨ *-cong ⟩ refl ⟩ - - 1# * ⟦ p ⟧H (x ∷ ρ) ≈⟨ lemma₇ _ ⟩ - - ⟦ p ⟧H (x ∷ ρ) ∎ - - -N‿-homo : ∀ {n} (p : Normal n) → - ∀ ρ → ⟦ -N p ⟧N ρ ≈ - ⟦ p ⟧N ρ - -N‿-homo (con c) _ = -‿homo _ - -N‿-homo (poly p) ρ = -H‿-homo p ρ - ------------------------------------------------------------------------- --- Correctness - -correct-con : ∀ {n} (c : C.Carrier) (ρ : Vec Carrier n) → - ⟦ normalise-con c ⟧N ρ ≈ ⟦ c ⟧′ -correct-con c [] = refl -correct-con c (x ∷ ρ) = begin - ⟦ ∅ *x+HN normalise-con c ⟧H (x ∷ ρ) ≈⟨ ∅*x+HN-homo (normalise-con c) x ρ ⟩ - ⟦ normalise-con c ⟧N ρ ≈⟨ correct-con c ρ ⟩ - ⟦ c ⟧′ ∎ - -correct-var : ∀ {n} (i : Fin n) → - ∀ ρ → ⟦ normalise-var i ⟧N ρ ≈ lookup ρ i -correct-var (suc i) (x ∷ ρ) = begin - ⟦ ∅ *x+HN normalise-var i ⟧H (x ∷ ρ) ≈⟨ ∅*x+HN-homo (normalise-var i) x ρ ⟩ - ⟦ normalise-var i ⟧N ρ ≈⟨ correct-var i ρ ⟩ - lookup ρ i ∎ -correct-var zero (x ∷ ρ) = begin - (0# * x + ⟦ 1N ⟧N ρ) * x + ⟦ 0N ⟧N ρ ≈⟨ ((refl ⟨ +-cong ⟩ 1N-homo ρ) ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ 0N-homo ρ ⟩ - (0# * x + 1#) * x + 0# ≈⟨ lemma₅ _ ⟩ - x ∎ - -correct : ∀ {n} (p : Polynomial n) → ∀ ρ → ⟦ p ⟧↓ ρ ≈ ⟦ p ⟧ ρ -correct (op [+] p₁ p₂) ρ = begin - ⟦ normalise p₁ +N normalise p₂ ⟧N ρ ≈⟨ +N-homo (normalise p₁) (normalise p₂) ρ ⟩ - ⟦ p₁ ⟧↓ ρ + ⟦ p₂ ⟧↓ ρ ≈⟨ correct p₁ ρ ⟨ +-cong ⟩ correct p₂ ρ ⟩ - ⟦ p₁ ⟧ ρ + ⟦ p₂ ⟧ ρ ∎ -correct (op [*] p₁ p₂) ρ = begin - ⟦ normalise p₁ *N normalise p₂ ⟧N ρ ≈⟨ *N-homo (normalise p₁) (normalise p₂) ρ ⟩ - ⟦ p₁ ⟧↓ ρ * ⟦ p₂ ⟧↓ ρ ≈⟨ correct p₁ ρ ⟨ *-cong ⟩ correct p₂ ρ ⟩ - ⟦ p₁ ⟧ ρ * ⟦ p₂ ⟧ ρ ∎ -correct (con c) ρ = correct-con c ρ -correct (var i) ρ = correct-var i ρ -correct (p :^ k) ρ = begin - ⟦ normalise p ^N k ⟧N ρ ≈⟨ ^N-homo (normalise p) k ρ ⟩ - ⟦ p ⟧↓ ρ ^ k ≈⟨ correct p ρ ⟨ ^-cong ⟩ PropEq.refl {x = k} ⟩ - ⟦ p ⟧ ρ ^ k ∎ -correct (:- p) ρ = begin - ⟦ -N normalise p ⟧N ρ ≈⟨ -N‿-homo (normalise p) ρ ⟩ - - ⟦ p ⟧↓ ρ ≈⟨ -‿cong (correct p ρ) ⟩ - - ⟦ p ⟧ ρ ∎ - ------------------------------------------------------------------------- --- "Tactic. - -open Reflection setoid var ⟦_⟧ ⟦_⟧↓ correct public - using (prove; solve) renaming (_⊜_ to _:=_) - --- For examples of how solve and _:=_ can be used to --- semi-automatically prove ring equalities, see, for instance, --- Data.Digit or Data.Nat.DivMod. +_^N_ : ∀ {n} → Normal n → ℕ → Normal n +p ^N zero = 1N +p ^N suc n = p *N (p ^N n) + +mutual + + -- Negation. + + -H_ : ∀ {n} → HNF (suc n) → HNF (suc n) + -H p = (-N 1N) *NH p + + -N_ : ∀ {n} → Normal n → Normal n + -N con c = con (C.- c) + -N poly p = poly (-H p) + +------------------------------------------------------------------------ +-- Normalisation + +normalise-con : ∀ {n} → C.Carrier → Normal n +normalise-con {zero} c = con c +normalise-con {suc n} c = poly (∅ *x+HN normalise-con c) + +normalise-var : ∀ {n} → Fin n → Normal n +normalise-var zero = poly ((∅ *x+ 1N) *x+ 0N) +normalise-var (suc i) = poly (∅ *x+HN normalise-var i) + +normalise : ∀ {n} → Polynomial n → Normal n +normalise (op [+] t₁ t₂) = normalise t₁ +N normalise t₂ +normalise (op [*] t₁ t₂) = normalise t₁ *N normalise t₂ +normalise (con c) = normalise-con c +normalise (var i) = normalise-var i +normalise (t :^ k) = normalise t ^N k +normalise (:- t) = -N normalise t + +-- Evaluation after normalisation. + +⟦_⟧↓ : ∀ {n} → Polynomial n → Vec Carrier n → Carrier +⟦ p ⟧↓ ρ = ⟦ normalise p ⟧N ρ + +------------------------------------------------------------------------ +-- Homomorphism lemmas + +0N-homo : ∀ {n} ρ → ⟦ 0N {n} ⟧N ρ ≈ 0# +0N-homo [] = 0-homo +0N-homo (x ∷ ρ) = refl + +-- If c is equal to 0N, then c is semantically equal to 0#. + +0≈⟦0⟧ : ∀ {n} {c : Normal n} → c ≈N 0N → ∀ ρ → 0# ≈ ⟦ c ⟧N ρ +0≈⟦0⟧ {c = c} c≈0 ρ = sym (begin + ⟦ c ⟧N ρ ≈⟨ ⟦ c≈0 ⟧N-cong ρ ⟩ + ⟦ 0N ⟧N ρ ≈⟨ 0N-homo ρ ⟩ + 0# ∎) + +1N-homo : ∀ {n} ρ → ⟦ 1N {n} ⟧N ρ ≈ 1# +1N-homo [] = 1-homo +1N-homo (x ∷ ρ) = begin + 0# * x + ⟦ 1N ⟧N ρ ≈⟨ refl ⟨ +-cong ⟩ 1N-homo ρ ⟩ + 0# * x + 1# ≈⟨ lemma₆ _ _ ⟩ + 1# ∎ + +-- _*x+HN_ is equal to _*x+_. + +*x+HN≈*x+ : ∀ {n} (p : HNF (suc n)) (c : Normal n) → + ∀ ρ → ⟦ p *x+HN c ⟧H ρ ≈ ⟦ p *x+ c ⟧H ρ +*x+HN≈*x+ (p *x+ c′) c ρ = refl +*x+HN≈*x+ ∅ c (x ∷ ρ) with c ≟N 0N +... | just c≈0 = begin + 0# ≈⟨ 0≈⟦0⟧ c≈0 ρ ⟩ + ⟦ c ⟧N ρ ≈⟨ sym $ lemma₆ _ _ ⟩ + 0# * x + ⟦ c ⟧N ρ ∎ +... | nothing = refl + +∅*x+HN-homo : ∀ {n} (c : Normal n) x ρ → + ⟦ ∅ *x+HN c ⟧H (x ∷ ρ) ≈ ⟦ c ⟧N ρ +∅*x+HN-homo c x ρ with c ≟N 0N +... | just c≈0 = 0≈⟦0⟧ c≈0 ρ +... | nothing = lemma₆ _ _ + +mutual + + +H-homo : ∀ {n} (p₁ p₂ : HNF (suc n)) → + ∀ ρ → ⟦ p₁ +H p₂ ⟧H ρ ≈ ⟦ p₁ ⟧H ρ + ⟦ p₂ ⟧H ρ + +H-homo ∅ p₂ ρ = sym (+-identityˡ _) + +H-homo (p₁ *x+ x₁) ∅ ρ = sym (+-identityʳ _) + +H-homo (p₁ *x+ c₁) (p₂ *x+ c₂) (x ∷ ρ) = begin + ⟦ (p₁ +H p₂) *x+HN (c₁ +N c₂) ⟧H (x ∷ ρ) ≈⟨ *x+HN≈*x+ (p₁ +H p₂) (c₁ +N c₂) (x ∷ ρ) ⟩ + + ⟦ p₁ +H p₂ ⟧H (x ∷ ρ) * x + ⟦ c₁ +N c₂ ⟧N ρ ≈⟨ (+H-homo p₁ p₂ (x ∷ ρ) ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ +N-homo c₁ c₂ ρ ⟩ + + (⟦ p₁ ⟧H (x ∷ ρ) + ⟦ p₂ ⟧H (x ∷ ρ)) * x + (⟦ c₁ ⟧N ρ + ⟦ c₂ ⟧N ρ) ≈⟨ lemma₁ _ _ _ _ _ ⟩ + + (⟦ p₁ ⟧H (x ∷ ρ) * x + ⟦ c₁ ⟧N ρ) + + (⟦ p₂ ⟧H (x ∷ ρ) * x + ⟦ c₂ ⟧N ρ) ∎ + + +N-homo : ∀ {n} (p₁ p₂ : Normal n) → + ∀ ρ → ⟦ p₁ +N p₂ ⟧N ρ ≈ ⟦ p₁ ⟧N ρ + ⟦ p₂ ⟧N ρ + +N-homo (con c₁) (con c₂) _ = +-homo _ _ + +N-homo (poly p₁) (poly p₂) ρ = +H-homo p₁ p₂ ρ + +*x+H-homo : + ∀ {n} (p₁ p₂ : HNF (suc n)) x ρ → + ⟦ p₁ *x+H p₂ ⟧H (x ∷ ρ) ≈ + ⟦ p₁ ⟧H (x ∷ ρ) * x + ⟦ p₂ ⟧H (x ∷ ρ) +*x+H-homo ∅ ∅ _ _ = sym $ lemma₆ _ _ +*x+H-homo (p *x+ c) ∅ x ρ = begin + ⟦ p *x+ c ⟧H (x ∷ ρ) * x + ⟦ 0N ⟧N ρ ≈⟨ refl ⟨ +-cong ⟩ 0N-homo ρ ⟩ + ⟦ p *x+ c ⟧H (x ∷ ρ) * x + 0# ∎ +*x+H-homo p₁ (p₂ *x+ c₂) x ρ = begin + ⟦ (p₁ +H p₂) *x+HN c₂ ⟧H (x ∷ ρ) ≈⟨ *x+HN≈*x+ (p₁ +H p₂) c₂ (x ∷ ρ) ⟩ + ⟦ p₁ +H p₂ ⟧H (x ∷ ρ) * x + ⟦ c₂ ⟧N ρ ≈⟨ (+H-homo p₁ p₂ (x ∷ ρ) ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ refl ⟩ + (⟦ p₁ ⟧H (x ∷ ρ) + ⟦ p₂ ⟧H (x ∷ ρ)) * x + ⟦ c₂ ⟧N ρ ≈⟨ lemma₀ _ _ _ _ ⟩ + ⟦ p₁ ⟧H (x ∷ ρ) * x + (⟦ p₂ ⟧H (x ∷ ρ) * x + ⟦ c₂ ⟧N ρ) ∎ + +mutual + + *NH-homo : + ∀ {n} (c : Normal n) (p : HNF (suc n)) x ρ → + ⟦ c *NH p ⟧H (x ∷ ρ) ≈ ⟦ c ⟧N ρ * ⟦ p ⟧H (x ∷ ρ) + *NH-homo c ∅ x ρ = sym (*-zeroʳ _) + *NH-homo c (p *x+ c′) x ρ with c ≟N 0N + ... | just c≈0 = begin + 0# ≈⟨ sym (*-zeroˡ _) ⟩ + 0# * (⟦ p ⟧H (x ∷ ρ) * x + ⟦ c′ ⟧N ρ) ≈⟨ 0≈⟦0⟧ c≈0 ρ ⟨ *-cong ⟩ refl ⟩ + ⟦ c ⟧N ρ * (⟦ p ⟧H (x ∷ ρ) * x + ⟦ c′ ⟧N ρ) ∎ + ... | nothing = begin + ⟦ c *NH p ⟧H (x ∷ ρ) * x + ⟦ c *N c′ ⟧N ρ ≈⟨ (*NH-homo c p x ρ ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ *N-homo c c′ ρ ⟩ + (⟦ c ⟧N ρ * ⟦ p ⟧H (x ∷ ρ)) * x + (⟦ c ⟧N ρ * ⟦ c′ ⟧N ρ) ≈⟨ lemma₃ _ _ _ _ ⟩ + ⟦ c ⟧N ρ * (⟦ p ⟧H (x ∷ ρ) * x + ⟦ c′ ⟧N ρ) ∎ + + *HN-homo : + ∀ {n} (p : HNF (suc n)) (c : Normal n) x ρ → + ⟦ p *HN c ⟧H (x ∷ ρ) ≈ ⟦ p ⟧H (x ∷ ρ) * ⟦ c ⟧N ρ + *HN-homo ∅ c x ρ = sym (*-zeroˡ _) + *HN-homo (p *x+ c′) c x ρ with c ≟N 0N + ... | just c≈0 = begin + 0# ≈⟨ sym (*-zeroʳ _) ⟩ + (⟦ p ⟧H (x ∷ ρ) * x + ⟦ c′ ⟧N ρ) * 0# ≈⟨ refl ⟨ *-cong ⟩ 0≈⟦0⟧ c≈0 ρ ⟩ + (⟦ p ⟧H (x ∷ ρ) * x + ⟦ c′ ⟧N ρ) * ⟦ c ⟧N ρ ∎ + ... | nothing = begin + ⟦ p *HN c ⟧H (x ∷ ρ) * x + ⟦ c′ *N c ⟧N ρ ≈⟨ (*HN-homo p c x ρ ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ *N-homo c′ c ρ ⟩ + (⟦ p ⟧H (x ∷ ρ) * ⟦ c ⟧N ρ) * x + (⟦ c′ ⟧N ρ * ⟦ c ⟧N ρ) ≈⟨ lemma₂ _ _ _ _ ⟩ + (⟦ p ⟧H (x ∷ ρ) * x + ⟦ c′ ⟧N ρ) * ⟦ c ⟧N ρ ∎ + + *H-homo : ∀ {n} (p₁ p₂ : HNF (suc n)) → + ∀ ρ → ⟦ p₁ *H p₂ ⟧H ρ ≈ ⟦ p₁ ⟧H ρ * ⟦ p₂ ⟧H ρ + *H-homo ∅ p₂ ρ = sym $ *-zeroˡ _ + *H-homo (p₁ *x+ c₁) ∅ ρ = sym $ *-zeroʳ _ + *H-homo (p₁ *x+ c₁) (p₂ *x+ c₂) (x ∷ ρ) = begin + ⟦ ((p₁ *H p₂) *x+H ((p₁ *HN c₂) +H (c₁ *NH p₂))) *x+HN + (c₁ *N c₂) ⟧H (x ∷ ρ) ≈⟨ *x+HN≈*x+ ((p₁ *H p₂) *x+H ((p₁ *HN c₂) +H (c₁ *NH p₂))) + (c₁ *N c₂) (x ∷ ρ) ⟩ + ⟦ (p₁ *H p₂) *x+H + ((p₁ *HN c₂) +H (c₁ *NH p₂)) ⟧H (x ∷ ρ) * x + + ⟦ c₁ *N c₂ ⟧N ρ ≈⟨ (*x+H-homo (p₁ *H p₂) ((p₁ *HN c₂) +H (c₁ *NH p₂)) x ρ + ⟨ *-cong ⟩ + refl) + ⟨ +-cong ⟩ + *N-homo c₁ c₂ ρ ⟩ + (⟦ p₁ *H p₂ ⟧H (x ∷ ρ) * x + + ⟦ (p₁ *HN c₂) +H (c₁ *NH p₂) ⟧H (x ∷ ρ)) * x + + ⟦ c₁ ⟧N ρ * ⟦ c₂ ⟧N ρ ≈⟨ (((*H-homo p₁ p₂ (x ∷ ρ) ⟨ *-cong ⟩ refl) + ⟨ +-cong ⟩ + (+H-homo (p₁ *HN c₂) (c₁ *NH p₂) (x ∷ ρ))) + ⟨ *-cong ⟩ + refl) + ⟨ +-cong ⟩ + refl ⟩ + (⟦ p₁ ⟧H (x ∷ ρ) * ⟦ p₂ ⟧H (x ∷ ρ) * x + + (⟦ p₁ *HN c₂ ⟧H (x ∷ ρ) + ⟦ c₁ *NH p₂ ⟧H (x ∷ ρ))) * x + + ⟦ c₁ ⟧N ρ * ⟦ c₂ ⟧N ρ ≈⟨ ((refl ⟨ +-cong ⟩ (*HN-homo p₁ c₂ x ρ ⟨ +-cong ⟩ *NH-homo c₁ p₂ x ρ)) + ⟨ *-cong ⟩ + refl) + ⟨ +-cong ⟩ + refl ⟩ + (⟦ p₁ ⟧H (x ∷ ρ) * ⟦ p₂ ⟧H (x ∷ ρ) * x + + (⟦ p₁ ⟧H (x ∷ ρ) * ⟦ c₂ ⟧N ρ + ⟦ c₁ ⟧N ρ * ⟦ p₂ ⟧H (x ∷ ρ))) * x + + (⟦ c₁ ⟧N ρ * ⟦ c₂ ⟧N ρ) ≈⟨ lemma₄ _ _ _ _ _ ⟩ + + (⟦ p₁ ⟧H (x ∷ ρ) * x + ⟦ c₁ ⟧N ρ) * + (⟦ p₂ ⟧H (x ∷ ρ) * x + ⟦ c₂ ⟧N ρ) ∎ + + *N-homo : ∀ {n} (p₁ p₂ : Normal n) → + ∀ ρ → ⟦ p₁ *N p₂ ⟧N ρ ≈ ⟦ p₁ ⟧N ρ * ⟦ p₂ ⟧N ρ + *N-homo (con c₁) (con c₂) _ = *-homo _ _ + *N-homo (poly p₁) (poly p₂) ρ = *H-homo p₁ p₂ ρ + +^N-homo : ∀ {n} (p : Normal n) (k : ℕ) → + ∀ ρ → ⟦ p ^N k ⟧N ρ ≈ ⟦ p ⟧N ρ ^ k +^N-homo p zero ρ = 1N-homo ρ +^N-homo p (suc k) ρ = begin + ⟦ p *N (p ^N k) ⟧N ρ ≈⟨ *N-homo p (p ^N k) ρ ⟩ + ⟦ p ⟧N ρ * ⟦ p ^N k ⟧N ρ ≈⟨ refl ⟨ *-cong ⟩ ^N-homo p k ρ ⟩ + ⟦ p ⟧N ρ * (⟦ p ⟧N ρ ^ k) ∎ + +mutual + + -H‿-homo : ∀ {n} (p : HNF (suc n)) → + ∀ ρ → ⟦ -H p ⟧H ρ ≈ - ⟦ p ⟧H ρ + -H‿-homo p (x ∷ ρ) = begin + ⟦ (-N 1N) *NH p ⟧H (x ∷ ρ) ≈⟨ *NH-homo (-N 1N) p x ρ ⟩ + ⟦ -N 1N ⟧N ρ * ⟦ p ⟧H (x ∷ ρ) ≈⟨ trans (-N‿-homo 1N ρ) (-‿cong (1N-homo ρ)) ⟨ *-cong ⟩ refl ⟩ + - 1# * ⟦ p ⟧H (x ∷ ρ) ≈⟨ lemma₇ _ ⟩ + - ⟦ p ⟧H (x ∷ ρ) ∎ + + -N‿-homo : ∀ {n} (p : Normal n) → + ∀ ρ → ⟦ -N p ⟧N ρ ≈ - ⟦ p ⟧N ρ + -N‿-homo (con c) _ = -‿homo _ + -N‿-homo (poly p) ρ = -H‿-homo p ρ + +------------------------------------------------------------------------ +-- Correctness + +correct-con : ∀ {n} (c : C.Carrier) (ρ : Vec Carrier n) → + ⟦ normalise-con c ⟧N ρ ≈ ⟦ c ⟧′ +correct-con c [] = refl +correct-con c (x ∷ ρ) = begin + ⟦ ∅ *x+HN normalise-con c ⟧H (x ∷ ρ) ≈⟨ ∅*x+HN-homo (normalise-con c) x ρ ⟩ + ⟦ normalise-con c ⟧N ρ ≈⟨ correct-con c ρ ⟩ + ⟦ c ⟧′ ∎ + +correct-var : ∀ {n} (i : Fin n) → + ∀ ρ → ⟦ normalise-var i ⟧N ρ ≈ lookup ρ i +correct-var (suc i) (x ∷ ρ) = begin + ⟦ ∅ *x+HN normalise-var i ⟧H (x ∷ ρ) ≈⟨ ∅*x+HN-homo (normalise-var i) x ρ ⟩ + ⟦ normalise-var i ⟧N ρ ≈⟨ correct-var i ρ ⟩ + lookup ρ i ∎ +correct-var zero (x ∷ ρ) = begin + (0# * x + ⟦ 1N ⟧N ρ) * x + ⟦ 0N ⟧N ρ ≈⟨ ((refl ⟨ +-cong ⟩ 1N-homo ρ) ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ 0N-homo ρ ⟩ + (0# * x + 1#) * x + 0# ≈⟨ lemma₅ _ ⟩ + x ∎ + +correct : ∀ {n} (p : Polynomial n) → ∀ ρ → ⟦ p ⟧↓ ρ ≈ ⟦ p ⟧ ρ +correct (op [+] p₁ p₂) ρ = begin + ⟦ normalise p₁ +N normalise p₂ ⟧N ρ ≈⟨ +N-homo (normalise p₁) (normalise p₂) ρ ⟩ + ⟦ p₁ ⟧↓ ρ + ⟦ p₂ ⟧↓ ρ ≈⟨ correct p₁ ρ ⟨ +-cong ⟩ correct p₂ ρ ⟩ + ⟦ p₁ ⟧ ρ + ⟦ p₂ ⟧ ρ ∎ +correct (op [*] p₁ p₂) ρ = begin + ⟦ normalise p₁ *N normalise p₂ ⟧N ρ ≈⟨ *N-homo (normalise p₁) (normalise p₂) ρ ⟩ + ⟦ p₁ ⟧↓ ρ * ⟦ p₂ ⟧↓ ρ ≈⟨ correct p₁ ρ ⟨ *-cong ⟩ correct p₂ ρ ⟩ + ⟦ p₁ ⟧ ρ * ⟦ p₂ ⟧ ρ ∎ +correct (con c) ρ = correct-con c ρ +correct (var i) ρ = correct-var i ρ +correct (p :^ k) ρ = begin + ⟦ normalise p ^N k ⟧N ρ ≈⟨ ^N-homo (normalise p) k ρ ⟩ + ⟦ p ⟧↓ ρ ^ k ≈⟨ correct p ρ ⟨ ^-cong ⟩ PropEq.refl {x = k} ⟩ + ⟦ p ⟧ ρ ^ k ∎ +correct (:- p) ρ = begin + ⟦ -N normalise p ⟧N ρ ≈⟨ -N‿-homo (normalise p) ρ ⟩ + - ⟦ p ⟧↓ ρ ≈⟨ -‿cong (correct p ρ) ⟩ + - ⟦ p ⟧ ρ ∎ + +------------------------------------------------------------------------ +-- "Tactic. + +open Reflection setoid var ⟦_⟧ ⟦_⟧↓ correct public + using (prove; solve) renaming (_⊜_ to _:=_) + +-- For examples of how solve and _:=_ can be used to +-- semi-automatically prove ring equalities, see, for instance, +-- Data.Digit or Data.Nat.DivMod. \ No newline at end of file diff --git a/Algebra.Structures.Biased.html b/Algebra.Structures.Biased.html index 76d71ec4..fe903097 100644 --- a/Algebra.Structures.Biased.html +++ b/Algebra.Structures.Biased.html @@ -3,249 +3,266 @@ -- The Agda standard library -- -- Ways to give instances of certain structures where some fields can --- be given in terms of others ------------------------------------------------------------------------- - -{-# OPTIONS --cubical-compatible --safe #-} - -open import Algebra.Core -open import Algebra.Consequences.Setoid -open import Data.Product using (_,_; proj₁; proj₂) -open import Level using (_⊔_) -open import Relation.Binary using (Rel; Setoid; IsEquivalence) - -module Algebra.Structures.Biased - {a ℓ} {A : Set a} -- The underlying set - (_≈_ : Rel A ℓ) -- The underlying equality relation - where - -open import Algebra.Definitions _≈_ -open import Algebra.Structures _≈_ - ------------------------------------------------------------------------- --- IsCommutativeMonoid - -record IsCommutativeMonoidˡ (∙ : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where - field - isSemigroup : IsSemigroup ∙ - identityˡ : LeftIdentity ε ∙ - comm : Commutative ∙ - - isCommutativeMonoid : IsCommutativeMonoid ∙ ε - isCommutativeMonoid = record - { isMonoid = record - { isSemigroup = isSemigroup - ; identity = comm+idˡ⇒id setoid comm identityˡ - } - ; comm = comm - } where open IsSemigroup isSemigroup - -open IsCommutativeMonoidˡ public - using () renaming (isCommutativeMonoid to isCommutativeMonoidˡ) - - -record IsCommutativeMonoidʳ (∙ : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where - field - isSemigroup : IsSemigroup ∙ - identityʳ : RightIdentity ε ∙ - comm : Commutative ∙ - - isCommutativeMonoid : IsCommutativeMonoid ∙ ε - isCommutativeMonoid = record - { isMonoid = record - { isSemigroup = isSemigroup - ; identity = comm+idʳ⇒id setoid comm identityʳ - } - ; comm = comm - } where open IsSemigroup isSemigroup - -open IsCommutativeMonoidʳ public - using () renaming (isCommutativeMonoid to isCommutativeMonoidʳ) - ------------------------------------------------------------------------- --- IsSemiringWithoutOne - -record IsSemiringWithoutOne* (+ * : Op₂ A) (0# : A) : Set (a ⊔ ℓ) where - field - +-isCommutativeMonoid : IsCommutativeMonoid + 0# - *-isSemigroup : IsSemigroup * - distrib : * DistributesOver + - zero : Zero 0# * - - isSemiringWithoutOne : IsSemiringWithoutOne + * 0# - isSemiringWithoutOne = record - { +-isCommutativeMonoid = +-isCommutativeMonoid - ; *-cong = ∙-cong - ; *-assoc = assoc - ; distrib = distrib - ; zero = zero - } where open IsSemigroup *-isSemigroup - -open IsSemiringWithoutOne* public - using () renaming (isSemiringWithoutOne to isSemiringWithoutOne*) - ------------------------------------------------------------------------- --- IsNearSemiring - -record IsNearSemiring* (+ * : Op₂ A) (0# : A) : Set (a ⊔ ℓ) where - field - +-isMonoid : IsMonoid + 0# - *-isSemigroup : IsSemigroup * - distribʳ : * DistributesOverʳ + - zeroˡ : LeftZero 0# * - - isNearSemiring : IsNearSemiring + * 0# - isNearSemiring = record - { +-isMonoid = +-isMonoid - ; *-cong = ∙-cong - ; *-assoc = assoc - ; distribʳ = distribʳ - ; zeroˡ = zeroˡ - } where open IsSemigroup *-isSemigroup - -open IsNearSemiring* public - using () renaming (isNearSemiring to isNearSemiring*) - ------------------------------------------------------------------------- --- IsSemiringWithoutAnnihilatingZero - -record IsSemiringWithoutAnnihilatingZero* (+ * : Op₂ A) (0# 1# : A) : Set (a ⊔ ℓ) where - field - +-isCommutativeMonoid : IsCommutativeMonoid + 0# - *-isMonoid : IsMonoid * 1# - distrib : * DistributesOver + - - isSemiringWithoutAnnihilatingZero : IsSemiringWithoutAnnihilatingZero + * 0# 1# - isSemiringWithoutAnnihilatingZero = record - { +-isCommutativeMonoid = +-isCommutativeMonoid - ; *-cong = ∙-cong - ; *-assoc = assoc - ; *-identity = identity - ; distrib = distrib - } where open IsMonoid *-isMonoid - -open IsSemiringWithoutAnnihilatingZero* public - using () renaming (isSemiringWithoutAnnihilatingZero to isSemiringWithoutAnnihilatingZero*) - ------------------------------------------------------------------------- --- IsCommutativeSemiring - -record IsCommutativeSemiringˡ (+ * : Op₂ A) (0# 1# : A) : Set (a ⊔ ℓ) where - field - +-isCommutativeMonoid : IsCommutativeMonoid + 0# - *-isCommutativeMonoid : IsCommutativeMonoid * 1# - distribʳ : * DistributesOverʳ + - zeroˡ : LeftZero 0# * - - isCommutativeSemiring : IsCommutativeSemiring + * 0# 1# - isCommutativeSemiring = record - { isSemiring = record - { isSemiringWithoutAnnihilatingZero = record - { +-isCommutativeMonoid = +-isCommutativeMonoid - ; *-cong = *.∙-cong - ; *-assoc = *.assoc - ; *-identity = *.identity - ; distrib = comm+distrʳ⇒distr +.setoid +.∙-cong *.comm distribʳ - } - ; zero = comm+zeˡ⇒ze +.setoid *.comm zeroˡ - } - ; *-comm = *.comm - } - where - module + = IsCommutativeMonoid +-isCommutativeMonoid - module * = IsCommutativeMonoid *-isCommutativeMonoid - -open IsCommutativeSemiringˡ public - using () renaming (isCommutativeSemiring to isCommutativeSemiringˡ) - - -record IsCommutativeSemiringʳ (+ * : Op₂ A) (0# 1# : A) : Set (a ⊔ ℓ) where - field - +-isCommutativeMonoid : IsCommutativeMonoid + 0# - *-isCommutativeMonoid : IsCommutativeMonoid * 1# - distribˡ : * DistributesOverˡ + - zeroʳ : RightZero 0# * - - isCommutativeSemiring : IsCommutativeSemiring + * 0# 1# - isCommutativeSemiring = record - { isSemiring = record - { isSemiringWithoutAnnihilatingZero = record - { +-isCommutativeMonoid = +-isCommutativeMonoid - ; *-cong = *.∙-cong - ; *-assoc = *.assoc - ; *-identity = *.identity - ; distrib = comm+distrˡ⇒distr +.setoid +.∙-cong *.comm distribˡ - } - ; zero = comm+zeʳ⇒ze +.setoid *.comm zeroʳ - } - ; *-comm = *.comm - } - where - module + = IsCommutativeMonoid +-isCommutativeMonoid - module * = IsCommutativeMonoid *-isCommutativeMonoid - -open IsCommutativeSemiringʳ public - using () renaming (isCommutativeSemiring to isCommutativeSemiringʳ) - - ------------------------------------------------------------------------- --- IsRing - --- We can recover a ring without proving that 0# annihilates *. -record IsRingWithoutAnnihilatingZero (+ * : Op₂ A) (-_ : Op₁ A) (0# 1# : A) - : Set (a ⊔ ℓ) where - field - +-isAbelianGroup : IsAbelianGroup + 0# -_ - *-isMonoid : IsMonoid * 1# - distrib : * DistributesOver + - - module + = IsAbelianGroup +-isAbelianGroup - module * = IsMonoid *-isMonoid - - open + using (setoid) renaming (∙-cong to +-cong) - open * using () renaming (∙-cong to *-cong) - - zeroˡ : LeftZero 0# * - zeroˡ = assoc+distribʳ+idʳ+invʳ⇒zeˡ setoid - +-cong *-cong +.assoc (proj₂ distrib) +.identityʳ +.inverseʳ - - zeroʳ : RightZero 0# * - zeroʳ = assoc+distribˡ+idʳ+invʳ⇒zeʳ setoid - +-cong *-cong +.assoc (proj₁ distrib) +.identityʳ +.inverseʳ - - zero : Zero 0# * - zero = (zeroˡ , zeroʳ) - - isRing : IsRing + * -_ 0# 1# - isRing = record - { +-isAbelianGroup = +-isAbelianGroup - ; *-cong = *.∙-cong - ; *-assoc = *.assoc - ; *-identity = *.identity - ; distrib = distrib - ; zero = zero - } - -open IsRingWithoutAnnihilatingZero public - using () renaming (isRing to isRingWithoutAnnihilatingZero) - -record IsRing* (+ * : Op₂ A) (-_ : Op₁ A) (0# 1# : A) : Set (a ⊔ ℓ) where - field - +-isAbelianGroup : IsAbelianGroup + 0# -_ - *-isMonoid : IsMonoid * 1# - distrib : * DistributesOver + - zero : Zero 0# * - - isRing : IsRing + * -_ 0# 1# - isRing = record - { +-isAbelianGroup = +-isAbelianGroup - ; *-cong = ∙-cong - ; *-assoc = assoc - ; *-identity = identity - ; distrib = distrib - ; zero = zero - } where open IsMonoid *-isMonoid - -open IsRing* public - using () renaming (isRing to isRing*) +-- be given in terms of others. Re-exported via `Algebra`. +------------------------------------------------------------------------ + +{-# OPTIONS --cubical-compatible --safe #-} + +open import Algebra.Core +open import Algebra.Consequences.Setoid +open import Data.Product.Base using (_,_; proj₁; proj₂) +open import Level using (_⊔_) +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Binary.Structures using (IsEquivalence) + +module Algebra.Structures.Biased + {a ℓ} {A : Set a} -- The underlying set + (_≈_ : Rel A ℓ) -- The underlying equality relation + where + +open import Algebra.Definitions _≈_ +open import Algebra.Structures _≈_ + +------------------------------------------------------------------------ +-- IsCommutativeMonoid + +record IsCommutativeMonoidˡ (∙ : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where + field + isSemigroup : IsSemigroup ∙ + identityˡ : LeftIdentity ε ∙ + comm : Commutative ∙ + + isCommutativeMonoid : IsCommutativeMonoid ∙ ε + isCommutativeMonoid = record + { isMonoid = record + { isSemigroup = isSemigroup + ; identity = comm∧idˡ⇒id setoid comm identityˡ + } + ; comm = comm + } where open IsSemigroup isSemigroup + +open IsCommutativeMonoidˡ public + using () renaming (isCommutativeMonoid to isCommutativeMonoidˡ) + + +record IsCommutativeMonoidʳ (∙ : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where + field + isSemigroup : IsSemigroup ∙ + identityʳ : RightIdentity ε ∙ + comm : Commutative ∙ + + isCommutativeMonoid : IsCommutativeMonoid ∙ ε + isCommutativeMonoid = record + { isMonoid = record + { isSemigroup = isSemigroup + ; identity = comm∧idʳ⇒id setoid comm identityʳ + } + ; comm = comm + } where open IsSemigroup isSemigroup + +open IsCommutativeMonoidʳ public + using () renaming (isCommutativeMonoid to isCommutativeMonoidʳ) + +------------------------------------------------------------------------ +-- IsSemiringWithoutOne + +record IsSemiringWithoutOne* (+ * : Op₂ A) (0# : A) : Set (a ⊔ ℓ) where + field + +-isCommutativeMonoid : IsCommutativeMonoid + 0# + *-isSemigroup : IsSemigroup * + distrib : * DistributesOver + + zero : Zero 0# * + + isSemiringWithoutOne : IsSemiringWithoutOne + * 0# + isSemiringWithoutOne = record + { +-isCommutativeMonoid = +-isCommutativeMonoid + ; *-cong = ∙-cong + ; *-assoc = assoc + ; distrib = distrib + ; zero = zero + } where open IsSemigroup *-isSemigroup + +open IsSemiringWithoutOne* public + using () renaming (isSemiringWithoutOne to isSemiringWithoutOne*) + +------------------------------------------------------------------------ +-- IsNearSemiring + +record IsNearSemiring* (+ * : Op₂ A) (0# : A) : Set (a ⊔ ℓ) where + field + +-isMonoid : IsMonoid + 0# + *-isSemigroup : IsSemigroup * + distribʳ : * DistributesOverʳ + + zeroˡ : LeftZero 0# * + + isNearSemiring : IsNearSemiring + * 0# + isNearSemiring = record + { +-isMonoid = +-isMonoid + ; *-cong = ∙-cong + ; *-assoc = assoc + ; distribʳ = distribʳ + ; zeroˡ = zeroˡ + } where open IsSemigroup *-isSemigroup + +open IsNearSemiring* public + using () renaming (isNearSemiring to isNearSemiring*) + +------------------------------------------------------------------------ +-- IsSemiringWithoutAnnihilatingZero + +record IsSemiringWithoutAnnihilatingZero* (+ * : Op₂ A) (0# 1# : A) : Set (a ⊔ ℓ) where + field + +-isCommutativeMonoid : IsCommutativeMonoid + 0# + *-isMonoid : IsMonoid * 1# + distrib : * DistributesOver + + + isSemiringWithoutAnnihilatingZero : IsSemiringWithoutAnnihilatingZero + * 0# 1# + isSemiringWithoutAnnihilatingZero = record + { +-isCommutativeMonoid = +-isCommutativeMonoid + ; *-cong = ∙-cong + ; *-assoc = assoc + ; *-identity = identity + ; distrib = distrib + } where open IsMonoid *-isMonoid + +open IsSemiringWithoutAnnihilatingZero* public + using () renaming (isSemiringWithoutAnnihilatingZero to isSemiringWithoutAnnihilatingZero*) + +------------------------------------------------------------------------ +-- IsCommutativeSemiring + +record IsCommutativeSemiringˡ (+ * : Op₂ A) (0# 1# : A) : Set (a ⊔ ℓ) where + field + +-isCommutativeMonoid : IsCommutativeMonoid + 0# + *-isCommutativeMonoid : IsCommutativeMonoid * 1# + distribʳ : * DistributesOverʳ + + zeroˡ : LeftZero 0# * + + isCommutativeSemiring : IsCommutativeSemiring + * 0# 1# + isCommutativeSemiring = record + { isSemiring = record + { isSemiringWithoutAnnihilatingZero = record + { +-isCommutativeMonoid = +-isCommutativeMonoid + ; *-cong = *.∙-cong + ; *-assoc = *.assoc + ; *-identity = *.identity + ; distrib = comm∧distrʳ⇒distr +.setoid +.∙-cong *.comm distribʳ + } + ; zero = comm∧zeˡ⇒ze +.setoid *.comm zeroˡ + } + ; *-comm = *.comm + } + where + module + = IsCommutativeMonoid +-isCommutativeMonoid + module * = IsCommutativeMonoid *-isCommutativeMonoid + +open IsCommutativeSemiringˡ public + using () renaming (isCommutativeSemiring to isCommutativeSemiringˡ) + + +record IsCommutativeSemiringʳ (+ * : Op₂ A) (0# 1# : A) : Set (a ⊔ ℓ) where + field + +-isCommutativeMonoid : IsCommutativeMonoid + 0# + *-isCommutativeMonoid : IsCommutativeMonoid * 1# + distribˡ : * DistributesOverˡ + + zeroʳ : RightZero 0# * + + isCommutativeSemiring : IsCommutativeSemiring + * 0# 1# + isCommutativeSemiring = record + { isSemiring = record + { isSemiringWithoutAnnihilatingZero = record + { +-isCommutativeMonoid = +-isCommutativeMonoid + ; *-cong = *.∙-cong + ; *-assoc = *.assoc + ; *-identity = *.identity + ; distrib = comm∧distrˡ⇒distr +.setoid +.∙-cong *.comm distribˡ + } + ; zero = comm∧zeʳ⇒ze +.setoid *.comm zeroʳ + } + ; *-comm = *.comm + } + where + module + = IsCommutativeMonoid +-isCommutativeMonoid + module * = IsCommutativeMonoid *-isCommutativeMonoid + +open IsCommutativeSemiringʳ public + using () renaming (isCommutativeSemiring to isCommutativeSemiringʳ) + + +------------------------------------------------------------------------ +-- IsRing + +record IsRing* (+ * : Op₂ A) (-_ : Op₁ A) (0# 1# : A) : Set (a ⊔ ℓ) where + field + +-isAbelianGroup : IsAbelianGroup + 0# -_ + *-isMonoid : IsMonoid * 1# + distrib : * DistributesOver + + zero : Zero 0# * + + isRing : IsRing + * -_ 0# 1# + isRing = record + { +-isAbelianGroup = +-isAbelianGroup + ; *-cong = ∙-cong + ; *-assoc = assoc + ; *-identity = identity + ; distrib = distrib + } where open IsMonoid *-isMonoid + +open IsRing* public + using () renaming (isRing to isRing*) + + + +------------------------------------------------------------------------ +-- Deprecated +------------------------------------------------------------------------ + +-- Version 2.0 + +-- We can recover a ring without proving that 0# annihilates *. +record IsRingWithoutAnnihilatingZero (+ * : Op₂ A) (-_ : Op₁ A) (0# 1# : A) + : Set (a ⊔ ℓ) where + field + +-isAbelianGroup : IsAbelianGroup + 0# -_ + *-isMonoid : IsMonoid * 1# + distrib : * DistributesOver + + + module + = IsAbelianGroup +-isAbelianGroup + module * = IsMonoid *-isMonoid + + open + using (setoid) renaming (∙-cong to +-cong) + open * using () renaming (∙-cong to *-cong) + + zeroˡ : LeftZero 0# * + zeroˡ = assoc∧distribʳ∧idʳ∧invʳ⇒zeˡ setoid + +-cong *-cong +.assoc (proj₂ distrib) +.identityʳ +.inverseʳ + + zeroʳ : RightZero 0# * + zeroʳ = assoc∧distribˡ∧idʳ∧invʳ⇒zeʳ setoid + +-cong *-cong +.assoc (proj₁ distrib) +.identityʳ +.inverseʳ + + zero : Zero 0# * + zero = (zeroˡ , zeroʳ) + + isRing : IsRing + * -_ 0# 1# + isRing = record + { +-isAbelianGroup = +-isAbelianGroup + ; *-cong = *.∙-cong + ; *-assoc = *.assoc + ; *-identity = *.identity + ; distrib = distrib + } + +open IsRingWithoutAnnihilatingZero public + using () renaming (isRing to isRingWithoutAnnihilatingZero) + +{-# WARNING_ON_USAGE IsRingWithoutAnnihilatingZero +"Warning: IsRingWithoutAnnihilatingZero was deprecated in v2.0. +Please use the standard `IsRing` instead." +#-} +{-# WARNING_ON_USAGE isRingWithoutAnnihilatingZero +"Warning: isRingWithoutAnnihilatingZero was deprecated in v2.0. +Please use the standard `IsRing` instead." +#-} \ No newline at end of file diff --git a/Algebra.Structures.html b/Algebra.Structures.html index faafdc5d..3368dd6c 100644 --- a/Algebra.Structures.html +++ b/Algebra.Structures.html @@ -10,938 +10,953 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary using (Rel; Setoid; IsEquivalence) +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Binary.Structures using (IsEquivalence) -module Algebra.Structures - {a ℓ} {A : Set a} -- The underlying set - (_≈_ : Rel A ℓ) -- The underlying equality relation - where +module Algebra.Structures + {a ℓ} {A : Set a} -- The underlying set + (_≈_ : Rel A ℓ) -- The underlying equality relation + where --- The file is divided into sections depending on the arities of the --- components of the algebraic structure. +-- The file is divided into sections depending on the arities of the +-- components of the algebraic structure. -open import Algebra.Core -open import Algebra.Definitions _≈_ -import Algebra.Consequences.Setoid as Consequences -open import Data.Product using (_,_; proj₁; proj₂) -open import Level using (_⊔_) +open import Algebra.Core +open import Algebra.Definitions _≈_ +import Algebra.Consequences.Setoid as Consequences +open import Data.Product.Base using (_,_; proj₁; proj₂) +open import Level using (_⊔_) ------------------------------------------------------------------------- --- Structures with 1 binary operation ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Structures with 1 binary operation +------------------------------------------------------------------------ -record IsMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where - field - isEquivalence : IsEquivalence _≈_ - ∙-cong : Congruent₂ ∙ +record IsMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where + field + isEquivalence : IsEquivalence _≈_ + ∙-cong : Congruent₂ ∙ - open IsEquivalence isEquivalence public + open IsEquivalence isEquivalence public - setoid : Setoid a ℓ - setoid = record { isEquivalence = isEquivalence } + setoid : Setoid a ℓ + setoid = record { isEquivalence = isEquivalence } - ∙-congˡ : LeftCongruent ∙ - ∙-congˡ y≈z = ∙-cong refl y≈z + ∙-congˡ : LeftCongruent ∙ + ∙-congˡ y≈z = ∙-cong refl y≈z - ∙-congʳ : RightCongruent ∙ - ∙-congʳ y≈z = ∙-cong y≈z refl + ∙-congʳ : RightCongruent ∙ + ∙-congʳ y≈z = ∙-cong y≈z refl -record IsCommutativeMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where - field - isMagma : IsMagma ∙ - comm : Commutative ∙ +record IsCommutativeMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where + field + isMagma : IsMagma ∙ + comm : Commutative ∙ - open IsMagma isMagma public + open IsMagma isMagma public -record IsIdempotentMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where - field - isMagma : IsMagma ∙ - idem : Idempotent ∙ +record IsIdempotentMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where + field + isMagma : IsMagma ∙ + idem : Idempotent ∙ - open IsMagma isMagma public + open IsMagma isMagma public -record IsAlternativeMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where - field - isMagma : IsMagma ∙ - alter : Alternative ∙ +record IsAlternativeMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where + field + isMagma : IsMagma ∙ + alter : Alternative ∙ - open IsMagma isMagma public + open IsMagma isMagma public - alternativeˡ : LeftAlternative ∙ - alternativeˡ = proj₁ alter + alternativeˡ : LeftAlternative ∙ + alternativeˡ = proj₁ alter - alternativeʳ : RightAlternative ∙ - alternativeʳ = proj₂ alter + alternativeʳ : RightAlternative ∙ + alternativeʳ = proj₂ alter -record IsFlexibleMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where - field - isMagma : IsMagma ∙ - flex : Flexible ∙ +record IsFlexibleMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where + field + isMagma : IsMagma ∙ + flex : Flexible ∙ - open IsMagma isMagma public + open IsMagma isMagma public -record IsMedialMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where - field - isMagma : IsMagma ∙ - medial : Medial ∙ +record IsMedialMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where + field + isMagma : IsMagma ∙ + medial : Medial ∙ - open IsMagma isMagma public + open IsMagma isMagma public -record IsSemimedialMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where - field - isMagma : IsMagma ∙ - semiMedial : Semimedial ∙ +record IsSemimedialMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where + field + isMagma : IsMagma ∙ + semiMedial : Semimedial ∙ - open IsMagma isMagma public + open IsMagma isMagma public - semimedialˡ : LeftSemimedial ∙ - semimedialˡ = proj₁ semiMedial + semimedialˡ : LeftSemimedial ∙ + semimedialˡ = proj₁ semiMedial - semimedialʳ : RightSemimedial ∙ - semimedialʳ = proj₂ semiMedial + semimedialʳ : RightSemimedial ∙ + semimedialʳ = proj₂ semiMedial -record IsSelectiveMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where - field - isMagma : IsMagma ∙ - sel : Selective ∙ +record IsSelectiveMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where + field + isMagma : IsMagma ∙ + sel : Selective ∙ - open IsMagma isMagma public + open IsMagma isMagma public -record IsSemigroup (∙ : Op₂ A) : Set (a ⊔ ℓ) where - field - isMagma : IsMagma ∙ - assoc : Associative ∙ +record IsSemigroup (∙ : Op₂ A) : Set (a ⊔ ℓ) where + field + isMagma : IsMagma ∙ + assoc : Associative ∙ - open IsMagma isMagma public + open IsMagma isMagma public -record IsBand (∙ : Op₂ A) : Set (a ⊔ ℓ) where - field - isSemigroup : IsSemigroup ∙ - idem : Idempotent ∙ +record IsBand (∙ : Op₂ A) : Set (a ⊔ ℓ) where + field + isSemigroup : IsSemigroup ∙ + idem : Idempotent ∙ - open IsSemigroup isSemigroup public + open IsSemigroup isSemigroup public -record IsCommutativeSemigroup (∙ : Op₂ A) : Set (a ⊔ ℓ) where - field - isSemigroup : IsSemigroup ∙ - comm : Commutative ∙ +record IsCommutativeSemigroup (∙ : Op₂ A) : Set (a ⊔ ℓ) where + field + isSemigroup : IsSemigroup ∙ + comm : Commutative ∙ - open IsSemigroup isSemigroup public + open IsSemigroup isSemigroup public - isCommutativeMagma : IsCommutativeMagma ∙ - isCommutativeMagma = record - { isMagma = isMagma - ; comm = comm - } + isCommutativeMagma : IsCommutativeMagma ∙ + isCommutativeMagma = record + { isMagma = isMagma + ; comm = comm + } ------------------------------------------------------------------------- --- Structures with 1 binary operation & 1 element ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Structures with 1 binary operation & 1 element +------------------------------------------------------------------------ -record IsUnitalMagma (∙ : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where - field - isMagma : IsMagma ∙ - identity : Identity ε ∙ +record IsUnitalMagma (∙ : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where + field + isMagma : IsMagma ∙ + identity : Identity ε ∙ - open IsMagma isMagma public + open IsMagma isMagma public - identityˡ : LeftIdentity ε ∙ - identityˡ = proj₁ identity + identityˡ : LeftIdentity ε ∙ + identityˡ = proj₁ identity - identityʳ : RightIdentity ε ∙ - identityʳ = proj₂ identity + identityʳ : RightIdentity ε ∙ + identityʳ = proj₂ identity -record IsMonoid (∙ : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where - field - isSemigroup : IsSemigroup ∙ - identity : Identity ε ∙ +record IsMonoid (∙ : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where + field + isSemigroup : IsSemigroup ∙ + identity : Identity ε ∙ - open IsSemigroup isSemigroup public + open IsSemigroup isSemigroup public - identityˡ : LeftIdentity ε ∙ - identityˡ = proj₁ identity + identityˡ : LeftIdentity ε ∙ + identityˡ = proj₁ identity - identityʳ : RightIdentity ε ∙ - identityʳ = proj₂ identity + identityʳ : RightIdentity ε ∙ + identityʳ = proj₂ identity - isUnitalMagma : IsUnitalMagma ∙ ε - isUnitalMagma = record - { isMagma = isMagma - ; identity = identity - } + isUnitalMagma : IsUnitalMagma ∙ ε + isUnitalMagma = record + { isMagma = isMagma + ; identity = identity + } -record IsCommutativeMonoid (∙ : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where - field - isMonoid : IsMonoid ∙ ε - comm : Commutative ∙ +record IsCommutativeMonoid (∙ : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where + field + isMonoid : IsMonoid ∙ ε + comm : Commutative ∙ - open IsMonoid isMonoid public + open IsMonoid isMonoid public - isCommutativeSemigroup : IsCommutativeSemigroup ∙ - isCommutativeSemigroup = record - { isSemigroup = isSemigroup - ; comm = comm - } + isCommutativeSemigroup : IsCommutativeSemigroup ∙ + isCommutativeSemigroup = record + { isSemigroup = isSemigroup + ; comm = comm + } - open IsCommutativeSemigroup isCommutativeSemigroup public - using (isCommutativeMagma) + open IsCommutativeSemigroup isCommutativeSemigroup public + using (isCommutativeMagma) -record IsIdempotentCommutativeMonoid (∙ : Op₂ A) - (ε : A) : Set (a ⊔ ℓ) where - field - isCommutativeMonoid : IsCommutativeMonoid ∙ ε - idem : Idempotent ∙ +record IsIdempotentCommutativeMonoid (∙ : Op₂ A) + (ε : A) : Set (a ⊔ ℓ) where + field + isCommutativeMonoid : IsCommutativeMonoid ∙ ε + idem : Idempotent ∙ - open IsCommutativeMonoid isCommutativeMonoid public + open IsCommutativeMonoid isCommutativeMonoid public - isBand : IsBand ∙ - isBand = record { isSemigroup = isSemigroup ; idem = idem } + isBand : IsBand ∙ + isBand = record { isSemigroup = isSemigroup ; idem = idem } ------------------------------------------------------------------------- --- Structures with 1 binary operation, 1 unary operation & 1 element ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Structures with 1 binary operation, 1 unary operation & 1 element +------------------------------------------------------------------------ -record IsInvertibleMagma (_∙_ : Op₂ A) (ε : A) (_⁻¹ : Op₁ A) : Set (a ⊔ ℓ) where - field - isMagma : IsMagma _∙_ - inverse : Inverse ε _⁻¹ _∙_ - ⁻¹-cong : Congruent₁ _⁻¹ +record IsInvertibleMagma (_∙_ : Op₂ A) (ε : A) (_⁻¹ : Op₁ A) : Set (a ⊔ ℓ) where + field + isMagma : IsMagma _∙_ + inverse : Inverse ε _⁻¹ _∙_ + ⁻¹-cong : Congruent₁ _⁻¹ - open IsMagma isMagma public + open IsMagma isMagma public - inverseˡ : LeftInverse ε _⁻¹ _∙_ - inverseˡ = proj₁ inverse + inverseˡ : LeftInverse ε _⁻¹ _∙_ + inverseˡ = proj₁ inverse - inverseʳ : RightInverse ε _⁻¹ _∙_ - inverseʳ = proj₂ inverse + inverseʳ : RightInverse ε _⁻¹ _∙_ + inverseʳ = proj₂ inverse -record IsInvertibleUnitalMagma (_∙_ : Op₂ A) (ε : A) (⁻¹ : Op₁ A) : Set (a ⊔ ℓ) where - field - isInvertibleMagma : IsInvertibleMagma _∙_ ε ⁻¹ - identity : Identity ε _∙_ +record IsInvertibleUnitalMagma (_∙_ : Op₂ A) (ε : A) (⁻¹ : Op₁ A) : Set (a ⊔ ℓ) where + field + isInvertibleMagma : IsInvertibleMagma _∙_ ε ⁻¹ + identity : Identity ε _∙_ - open IsInvertibleMagma isInvertibleMagma public + open IsInvertibleMagma isInvertibleMagma public - identityˡ : LeftIdentity ε _∙_ - identityˡ = proj₁ identity + identityˡ : LeftIdentity ε _∙_ + identityˡ = proj₁ identity - identityʳ : RightIdentity ε _∙_ - identityʳ = proj₂ identity + identityʳ : RightIdentity ε _∙_ + identityʳ = proj₂ identity - isUnitalMagma : IsUnitalMagma _∙_ ε - isUnitalMagma = record - { isMagma = isMagma - ; identity = identity - } + isUnitalMagma : IsUnitalMagma _∙_ ε + isUnitalMagma = record + { isMagma = isMagma + ; identity = identity + } -record IsGroup (_∙_ : Op₂ A) (ε : A) (_⁻¹ : Op₁ A) : Set (a ⊔ ℓ) where - field - isMonoid : IsMonoid _∙_ ε - inverse : Inverse ε _⁻¹ _∙_ - ⁻¹-cong : Congruent₁ _⁻¹ +record IsGroup (_∙_ : Op₂ A) (ε : A) (_⁻¹ : Op₁ A) : Set (a ⊔ ℓ) where + field + isMonoid : IsMonoid _∙_ ε + inverse : Inverse ε _⁻¹ _∙_ + ⁻¹-cong : Congruent₁ _⁻¹ - open IsMonoid isMonoid public + open IsMonoid isMonoid public - infixl 6 _-_ - _-_ : Op₂ A - x - y = x ∙ (y ⁻¹) + infixl 6 _-_ + _-_ : Op₂ A + x - y = x ∙ (y ⁻¹) - inverseˡ : LeftInverse ε _⁻¹ _∙_ - inverseˡ = proj₁ inverse + inverseˡ : LeftInverse ε _⁻¹ _∙_ + inverseˡ = proj₁ inverse - inverseʳ : RightInverse ε _⁻¹ _∙_ - inverseʳ = proj₂ inverse - - uniqueˡ-⁻¹ : ∀ x y → (x ∙ y) ≈ ε → x ≈ (y ⁻¹) - uniqueˡ-⁻¹ = Consequences.assoc+id+invʳ⇒invˡ-unique - setoid ∙-cong assoc identity inverseʳ - - uniqueʳ-⁻¹ : ∀ x y → (x ∙ y) ≈ ε → y ≈ (x ⁻¹) - uniqueʳ-⁻¹ = Consequences.assoc+id+invˡ⇒invʳ-unique - setoid ∙-cong assoc identity inverseˡ - - isInvertibleMagma : IsInvertibleMagma _∙_ ε _⁻¹ - isInvertibleMagma = record - { isMagma = isMagma - ; inverse = inverse - ; ⁻¹-cong = ⁻¹-cong - } - - isInvertibleUnitalMagma : IsInvertibleUnitalMagma _∙_ ε _⁻¹ - isInvertibleUnitalMagma = record - { isInvertibleMagma = isInvertibleMagma - ; identity = identity - } - - -record IsAbelianGroup (∙ : Op₂ A) - (ε : A) (⁻¹ : Op₁ A) : Set (a ⊔ ℓ) where - field - isGroup : IsGroup ∙ ε ⁻¹ - comm : Commutative ∙ - - open IsGroup isGroup public - - isCommutativeMonoid : IsCommutativeMonoid ∙ ε - isCommutativeMonoid = record - { isMonoid = isMonoid - ; comm = comm - } - - open IsCommutativeMonoid isCommutativeMonoid public - using (isCommutativeMagma; isCommutativeSemigroup) - - ------------------------------------------------------------------------- --- Structures with 2 binary operations & 1 element ------------------------------------------------------------------------- - -record IsNearSemiring (+ * : Op₂ A) (0# : A) : Set (a ⊔ ℓ) where - field - +-isMonoid : IsMonoid + 0# - *-cong : Congruent₂ * - *-assoc : Associative * - distribʳ : * DistributesOverʳ + - zeroˡ : LeftZero 0# * - - open IsMonoid +-isMonoid public - renaming - ( assoc to +-assoc - ; ∙-cong to +-cong - ; ∙-congˡ to +-congˡ - ; ∙-congʳ to +-congʳ - ; identity to +-identity - ; identityˡ to +-identityˡ - ; identityʳ to +-identityʳ - ; isMagma to +-isMagma - ; isUnitalMagma to +-isUnitalMagma - ; isSemigroup to +-isSemigroup - ) - - *-isMagma : IsMagma * - *-isMagma = record - { isEquivalence = isEquivalence - ; ∙-cong = *-cong - } - - *-isSemigroup : IsSemigroup * - *-isSemigroup = record - { isMagma = *-isMagma - ; assoc = *-assoc - } - - open IsMagma *-isMagma public - using () - renaming - ( ∙-congˡ to *-congˡ - ; ∙-congʳ to *-congʳ - ) - - -record IsSemiringWithoutOne (+ * : Op₂ A) (0# : A) : Set (a ⊔ ℓ) where - field - +-isCommutativeMonoid : IsCommutativeMonoid + 0# - *-cong : Congruent₂ * - *-assoc : Associative * - distrib : * DistributesOver + - zero : Zero 0# * - - open IsCommutativeMonoid +-isCommutativeMonoid public - using (isEquivalence) - renaming - ( comm to +-comm - ; isMonoid to +-isMonoid - ; isCommutativeMagma to +-isCommutativeMagma - ; isCommutativeSemigroup to +-isCommutativeSemigroup - ) - - *-isMagma : IsMagma * - *-isMagma = record - { isEquivalence = isEquivalence - ; ∙-cong = *-cong - } - - *-isSemigroup : IsSemigroup * - *-isSemigroup = record - { isMagma = *-isMagma - ; assoc = *-assoc - } - - open IsMagma *-isMagma public - using () - renaming - ( ∙-congˡ to *-congˡ - ; ∙-congʳ to *-congʳ - ) - - zeroˡ : LeftZero 0# * - zeroˡ = proj₁ zero - - zeroʳ : RightZero 0# * - zeroʳ = proj₂ zero - - isNearSemiring : IsNearSemiring + * 0# - isNearSemiring = record - { +-isMonoid = +-isMonoid - ; *-cong = *-cong - ; *-assoc = *-assoc - ; distribʳ = proj₂ distrib - ; zeroˡ = zeroˡ - } - -record IsCommutativeSemiringWithoutOne - (+ * : Op₂ A) (0# : A) : Set (a ⊔ ℓ) where - field - isSemiringWithoutOne : IsSemiringWithoutOne + * 0# - *-comm : Commutative * - - open IsSemiringWithoutOne isSemiringWithoutOne public - - *-isCommutativeSemigroup : IsCommutativeSemigroup * - *-isCommutativeSemigroup = record - { isSemigroup = *-isSemigroup - ; comm = *-comm - } - - open IsCommutativeSemigroup *-isCommutativeSemigroup public - using () renaming (isCommutativeMagma to *-isCommutativeMagma) - ------------------------------------------------------------------------- --- Structures with 2 binary operations & 2 elements ------------------------------------------------------------------------- - -record IsSemiringWithoutAnnihilatingZero (+ * : Op₂ A) - (0# 1# : A) : Set (a ⊔ ℓ) where - field - -- Note that these structures do have an additive unit, but this - -- unit does not necessarily annihilate multiplication. - +-isCommutativeMonoid : IsCommutativeMonoid + 0# - *-cong : Congruent₂ * - *-assoc : Associative * - *-identity : Identity 1# * - distrib : * DistributesOver + - - distribˡ : * DistributesOverˡ + - distribˡ = proj₁ distrib - - distribʳ : * DistributesOverʳ + - distribʳ = proj₂ distrib - - open IsCommutativeMonoid +-isCommutativeMonoid public - renaming - ( assoc to +-assoc - ; ∙-cong to +-cong - ; ∙-congˡ to +-congˡ - ; ∙-congʳ to +-congʳ - ; identity to +-identity - ; identityˡ to +-identityˡ - ; identityʳ to +-identityʳ - ; comm to +-comm - ; isMagma to +-isMagma - ; isSemigroup to +-isSemigroup - ; isMonoid to +-isMonoid - ; isUnitalMagma to +-isUnitalMagma - ; isCommutativeMagma to +-isCommutativeMagma - ; isCommutativeSemigroup to +-isCommutativeSemigroup - ) - - *-isMagma : IsMagma * - *-isMagma = record - { isEquivalence = isEquivalence - ; ∙-cong = *-cong - } - - *-isSemigroup : IsSemigroup * - *-isSemigroup = record - { isMagma = *-isMagma - ; assoc = *-assoc - } - - *-isMonoid : IsMonoid * 1# - *-isMonoid = record - { isSemigroup = *-isSemigroup - ; identity = *-identity - } - - open IsMonoid *-isMonoid public - using () - renaming - ( ∙-congˡ to *-congˡ - ; ∙-congʳ to *-congʳ - ; identityˡ to *-identityˡ - ; identityʳ to *-identityʳ - ) - - -record IsSemiring (+ * : Op₂ A) (0# 1# : A) : Set (a ⊔ ℓ) where - field - isSemiringWithoutAnnihilatingZero : - IsSemiringWithoutAnnihilatingZero + * 0# 1# - zero : Zero 0# * - - open IsSemiringWithoutAnnihilatingZero - isSemiringWithoutAnnihilatingZero public - - isSemiringWithoutOne : IsSemiringWithoutOne + * 0# - isSemiringWithoutOne = record - { +-isCommutativeMonoid = +-isCommutativeMonoid - ; *-cong = *-cong - ; *-assoc = *-assoc - ; distrib = distrib - ; zero = zero - } - - open IsSemiringWithoutOne isSemiringWithoutOne public - using - ( isNearSemiring - ; zeroˡ - ; zeroʳ - ) - - -record IsCommutativeSemiring (+ * : Op₂ A) (0# 1# : A) : Set (a ⊔ ℓ) where - field - isSemiring : IsSemiring + * 0# 1# - *-comm : Commutative * - - open IsSemiring isSemiring public - - isCommutativeSemiringWithoutOne : - IsCommutativeSemiringWithoutOne + * 0# - isCommutativeSemiringWithoutOne = record - { isSemiringWithoutOne = isSemiringWithoutOne - ; *-comm = *-comm - } - - open IsCommutativeSemiringWithoutOne isCommutativeSemiringWithoutOne public - using - ( *-isCommutativeMagma - ; *-isCommutativeSemigroup - ) - - *-isCommutativeMonoid : IsCommutativeMonoid * 1# - *-isCommutativeMonoid = record - { isMonoid = *-isMonoid - ; comm = *-comm - } - - -record IsCancellativeCommutativeSemiring (+ * : Op₂ A) (0# 1# : A) : Set (a ⊔ ℓ) where - field - isCommutativeSemiring : IsCommutativeSemiring + * 0# 1# - *-cancelˡ-nonZero : AlmostLeftCancellative 0# * - - open IsCommutativeSemiring isCommutativeSemiring public - -record IsIdempotentSemiring (+ * : Op₂ A) (0# 1# : A) : Set (a ⊔ ℓ) where - field - isSemiring : IsSemiring + * 0# 1# - +-idem : Idempotent + - - open IsSemiring isSemiring public - -record IsKleeneAlgebra (+ * : Op₂ A) (⋆ : Op₁ A) (0# 1# : A) : Set (a ⊔ ℓ) where - field - isIdempotentSemiring : IsIdempotentSemiring + * 0# 1# - starExpansive : StarExpansive 1# + * ⋆ - starDestructive : StarDestructive + * ⋆ - - open IsIdempotentSemiring isIdempotentSemiring public - - starExpansiveˡ : StarLeftExpansive 1# + * ⋆ - starExpansiveˡ = proj₁ starExpansive - - starExpansiveʳ : StarRightExpansive 1# + * ⋆ - starExpansiveʳ = proj₂ starExpansive - - starDestructiveˡ : StarLeftDestructive + * ⋆ - starDestructiveˡ = proj₁ starDestructive - - starDestructiveʳ : StarRightDestructive + * ⋆ - starDestructiveʳ = proj₂ starDestructive - -record IsQuasiring (+ * : Op₂ A) (0# 1# : A) : Set (a ⊔ ℓ) where - field - +-isMonoid : IsMonoid + 0# - *-cong : Congruent₂ * - *-assoc : Associative * - *-identity : Identity 1# * - distrib : * DistributesOver + - zero : Zero 0# * - - open IsMonoid +-isMonoid public - renaming - ( assoc to +-assoc - ; ∙-cong to +-cong - ; ∙-congˡ to +-congˡ - ; ∙-congʳ to +-congʳ - ; identity to +-identity - ; identityˡ to +-identityˡ - ; identityʳ to +-identityʳ - ; isMagma to +-isMagma - ; isUnitalMagma to +-isUnitalMagma - ; isSemigroup to +-isSemigroup - ) - - *-isMagma : IsMagma * - *-isMagma = record - { isEquivalence = isEquivalence - ; ∙-cong = *-cong - } - - *-isSemigroup : IsSemigroup * - *-isSemigroup = record - { isMagma = *-isMagma - ; assoc = *-assoc - } - - *-isMonoid : IsMonoid * 1# - *-isMonoid = record - { isSemigroup = *-isSemigroup - ; identity = *-identity - } - - open IsMonoid *-isMonoid public - using () - renaming - ( ∙-congˡ to *-congˡ - ; ∙-congʳ to *-congʳ - ; identityˡ to *-identityˡ - ; identityʳ to *-identityʳ - ) - ------------------------------------------------------------------------- --- Structures with 2 binary operations, 1 unary operation & 1 element ------------------------------------------------------------------------- - -record IsRingWithoutOne (+ * : Op₂ A) (-_ : Op₁ A) (0# : A) : Set (a ⊔ ℓ) where - field - +-isAbelianGroup : IsAbelianGroup + 0# -_ - *-cong : Congruent₂ * - *-assoc : Associative * - distrib : * DistributesOver + - zero : Zero 0# * - - open IsAbelianGroup +-isAbelianGroup public - renaming - ( assoc to +-assoc - ; ∙-cong to +-cong - ; ∙-congˡ to +-congˡ - ; ∙-congʳ to +-congʳ - ; identity to +-identity - ; identityˡ to +-identityˡ - ; identityʳ to +-identityʳ - ; inverse to -‿inverse - ; inverseˡ to -‿inverseˡ - ; inverseʳ to -‿inverseʳ - ; ⁻¹-cong to -‿cong - ; comm to +-comm - ; isMagma to +-isMagma - ; isSemigroup to +-isSemigroup - ; isMonoid to +-isMonoid - ; isUnitalMagma to +-isUnitalMagma - ; isCommutativeMagma to +-isCommutativeMagma - ; isCommutativeMonoid to +-isCommutativeMonoid - ; isCommutativeSemigroup to +-isCommutativeSemigroup - ; isInvertibleMagma to +-isInvertibleMagma - ; isInvertibleUnitalMagma to +-isInvertibleUnitalMagma - ; isGroup to +-isGroup - ) - - *-isMagma : IsMagma * - *-isMagma = record - { isEquivalence = isEquivalence - ; ∙-cong = *-cong - } - - zeroˡ : LeftZero 0# * - zeroˡ = proj₁ zero - - zeroʳ : RightZero 0# * - zeroʳ = proj₂ zero - - distribˡ : * DistributesOverˡ + - distribˡ = proj₁ distrib - - distribʳ : * DistributesOverʳ + - distribʳ = proj₂ distrib - - *-isSemigroup : IsSemigroup * - *-isSemigroup = record - { isMagma = *-isMagma - ; assoc = *-assoc - } - - open IsMagma *-isMagma public - using () - renaming - ( ∙-congˡ to *-congˡ - ; ∙-congʳ to *-congʳ - ) - ------------------------------------------------------------------------- --- Structures with 2 binary operations, 1 unary operation & 2 elements ------------------------------------------------------------------------- - -record IsNonAssociativeRing (+ * : Op₂ A) (-_ : Op₁ A) (0# 1# : A) : Set (a ⊔ ℓ) where - field - +-isAbelianGroup : IsAbelianGroup + 0# -_ - *-cong : Congruent₂ * - identity : Identity 1# * - distrib : * DistributesOver + - zero : Zero 0# * - - open IsAbelianGroup +-isAbelianGroup public - renaming - ( assoc to +-assoc - ; ∙-cong to +-cong - ; ∙-congˡ to +-congˡ - ; ∙-congʳ to +-congʳ - ; identity to +-identity - ; identityˡ to +-identityˡ - ; identityʳ to +-identityʳ - ; inverse to -‿inverse - ; inverseˡ to -‿inverseˡ - ; inverseʳ to -‿inverseʳ - ; ⁻¹-cong to -‿cong - ; comm to +-comm - ; isMagma to +-isMagma - ; isSemigroup to +-isSemigroup - ; isMonoid to +-isMonoid - ; isUnitalMagma to +-isUnitalMagma - ; isCommutativeMagma to +-isCommutativeMagma - ; isCommutativeMonoid to +-isCommutativeMonoid - ; isCommutativeSemigroup to +-isCommutativeSemigroup - ; isInvertibleMagma to +-isInvertibleMagma - ; isInvertibleUnitalMagma to +-isInvertibleUnitalMagma - ; isGroup to +-isGroup - ) - - *-isMagma : IsMagma * - *-isMagma = record - { isEquivalence = isEquivalence - ; ∙-cong = *-cong - } - - *-identityˡ : LeftIdentity 1# * - *-identityˡ = proj₁ identity - - *-identityʳ : RightIdentity 1# * - *-identityʳ = proj₂ identity - -record IsNearring (+ * : Op₂ A) (0# 1# : A) (_⁻¹ : Op₁ A) : Set (a ⊔ ℓ) where - field - isQuasiring : IsQuasiring + * 0# 1# - +-inverse : Inverse 0# _⁻¹ + - ⁻¹-cong : Congruent₁ _⁻¹ - - open IsQuasiring isQuasiring public - - +-inverseˡ : LeftInverse 0# _⁻¹ + - +-inverseˡ = proj₁ +-inverse - - +-inverseʳ : RightInverse 0# _⁻¹ + - +-inverseʳ = proj₂ +-inverse - -record IsRing (+ * : Op₂ A) (-_ : Op₁ A) (0# 1# : A) : Set (a ⊔ ℓ) where - field - +-isAbelianGroup : IsAbelianGroup + 0# -_ - *-cong : Congruent₂ * - *-assoc : Associative * - *-identity : Identity 1# * - distrib : * DistributesOver + - zero : Zero 0# * - - open IsAbelianGroup +-isAbelianGroup public - renaming - ( assoc to +-assoc - ; ∙-cong to +-cong - ; ∙-congˡ to +-congˡ - ; ∙-congʳ to +-congʳ - ; identity to +-identity - ; identityˡ to +-identityˡ - ; identityʳ to +-identityʳ - ; inverse to -‿inverse - ; inverseˡ to -‿inverseˡ - ; inverseʳ to -‿inverseʳ - ; ⁻¹-cong to -‿cong - ; comm to +-comm - ; isMagma to +-isMagma - ; isSemigroup to +-isSemigroup - ; isMonoid to +-isMonoid - ; isUnitalMagma to +-isUnitalMagma - ; isCommutativeMagma to +-isCommutativeMagma - ; isCommutativeMonoid to +-isCommutativeMonoid - ; isCommutativeSemigroup to +-isCommutativeSemigroup - ; isInvertibleMagma to +-isInvertibleMagma - ; isInvertibleUnitalMagma to +-isInvertibleUnitalMagma - ; isGroup to +-isGroup - ) - - *-isMagma : IsMagma * - *-isMagma = record - { isEquivalence = isEquivalence - ; ∙-cong = *-cong - } - - *-isSemigroup : IsSemigroup * - *-isSemigroup = record - { isMagma = *-isMagma - ; assoc = *-assoc - } - - *-isMonoid : IsMonoid * 1# - *-isMonoid = record - { isSemigroup = *-isSemigroup - ; identity = *-identity - } - - open IsMonoid *-isMonoid public - using () - renaming - ( ∙-congˡ to *-congˡ - ; ∙-congʳ to *-congʳ - ; identityˡ to *-identityˡ - ; identityʳ to *-identityʳ - ) - - zeroˡ : LeftZero 0# * - zeroˡ = proj₁ zero - - zeroʳ : RightZero 0# * - zeroʳ = proj₂ zero - - isSemiringWithoutAnnihilatingZero - : IsSemiringWithoutAnnihilatingZero + * 0# 1# - isSemiringWithoutAnnihilatingZero = record - { +-isCommutativeMonoid = +-isCommutativeMonoid - ; *-cong = *-cong - ; *-assoc = *-assoc - ; *-identity = *-identity - ; distrib = distrib - } - - isSemiring : IsSemiring + * 0# 1# - isSemiring = record - { isSemiringWithoutAnnihilatingZero = - isSemiringWithoutAnnihilatingZero - ; zero = zero - } - - open IsSemiring isSemiring public - using (distribˡ; distribʳ; isNearSemiring; isSemiringWithoutOne) - - -record IsCommutativeRing - (+ * : Op₂ A) (- : Op₁ A) (0# 1# : A) : Set (a ⊔ ℓ) where - 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 - ; *-isCommutativeMagma - ; *-isCommutativeSemigroup - ; *-isCommutativeMonoid - ) - ------------------------------------------------------------------------- --- Structures with 3 binary operations ------------------------------------------------------------------------- - -record IsQuasigroup (∙ \\ // : Op₂ A) : Set (a ⊔ ℓ) where - field - isMagma : IsMagma ∙ - \\-cong : Congruent₂ \\ - //-cong : Congruent₂ // - leftDivides : LeftDivides ∙ \\ - rightDivides : RightDivides ∙ // - - open IsMagma isMagma public - - \\-congˡ : LeftCongruent \\ - \\-congˡ y≈z = \\-cong refl y≈z - - \\-congʳ : RightCongruent \\ - \\-congʳ y≈z = \\-cong y≈z refl - - //-congˡ : LeftCongruent // - //-congˡ y≈z = //-cong refl y≈z - - //-congʳ : RightCongruent // - //-congʳ y≈z = //-cong y≈z refl - - leftDividesˡ : LeftDividesˡ ∙ \\ - leftDividesˡ = proj₁ leftDivides - - leftDividesʳ : LeftDividesʳ ∙ \\ - leftDividesʳ = proj₂ leftDivides - - rightDividesˡ : RightDividesˡ ∙ // - rightDividesˡ = proj₁ rightDivides + inverseʳ : RightInverse ε _⁻¹ _∙_ + inverseʳ = proj₂ inverse + + uniqueˡ-⁻¹ : ∀ x y → (x ∙ y) ≈ ε → x ≈ (y ⁻¹) + uniqueˡ-⁻¹ = Consequences.assoc∧id∧invʳ⇒invˡ-unique + setoid ∙-cong assoc identity inverseʳ + + uniqueʳ-⁻¹ : ∀ x y → (x ∙ y) ≈ ε → y ≈ (x ⁻¹) + uniqueʳ-⁻¹ = Consequences.assoc∧id∧invˡ⇒invʳ-unique + setoid ∙-cong assoc identity inverseˡ + + isInvertibleMagma : IsInvertibleMagma _∙_ ε _⁻¹ + isInvertibleMagma = record + { isMagma = isMagma + ; inverse = inverse + ; ⁻¹-cong = ⁻¹-cong + } + + isInvertibleUnitalMagma : IsInvertibleUnitalMagma _∙_ ε _⁻¹ + isInvertibleUnitalMagma = record + { isInvertibleMagma = isInvertibleMagma + ; identity = identity + } + + +record IsAbelianGroup (∙ : Op₂ A) + (ε : A) (⁻¹ : Op₁ A) : Set (a ⊔ ℓ) where + field + isGroup : IsGroup ∙ ε ⁻¹ + comm : Commutative ∙ + + open IsGroup isGroup public + + isCommutativeMonoid : IsCommutativeMonoid ∙ ε + isCommutativeMonoid = record + { isMonoid = isMonoid + ; comm = comm + } + + open IsCommutativeMonoid isCommutativeMonoid public + using (isCommutativeMagma; isCommutativeSemigroup) + + +------------------------------------------------------------------------ +-- Structures with 2 binary operations & 1 element +------------------------------------------------------------------------ + +record IsNearSemiring (+ * : Op₂ A) (0# : A) : Set (a ⊔ ℓ) where + field + +-isMonoid : IsMonoid + 0# + *-cong : Congruent₂ * + *-assoc : Associative * + distribʳ : * DistributesOverʳ + + zeroˡ : LeftZero 0# * + + open IsMonoid +-isMonoid public + renaming + ( assoc to +-assoc + ; ∙-cong to +-cong + ; ∙-congˡ to +-congˡ + ; ∙-congʳ to +-congʳ + ; identity to +-identity + ; identityˡ to +-identityˡ + ; identityʳ to +-identityʳ + ; isMagma to +-isMagma + ; isUnitalMagma to +-isUnitalMagma + ; isSemigroup to +-isSemigroup + ) + + *-isMagma : IsMagma * + *-isMagma = record + { isEquivalence = isEquivalence + ; ∙-cong = *-cong + } + + *-isSemigroup : IsSemigroup * + *-isSemigroup = record + { isMagma = *-isMagma + ; assoc = *-assoc + } + + open IsMagma *-isMagma public + using () + renaming + ( ∙-congˡ to *-congˡ + ; ∙-congʳ to *-congʳ + ) + + +record IsSemiringWithoutOne (+ * : Op₂ A) (0# : A) : Set (a ⊔ ℓ) where + field + +-isCommutativeMonoid : IsCommutativeMonoid + 0# + *-cong : Congruent₂ * + *-assoc : Associative * + distrib : * DistributesOver + + zero : Zero 0# * + + open IsCommutativeMonoid +-isCommutativeMonoid public + using (setoid) + renaming + ( comm to +-comm + ; isMonoid to +-isMonoid + ; isCommutativeMagma to +-isCommutativeMagma + ; isCommutativeSemigroup to +-isCommutativeSemigroup + ) + + open Setoid setoid public + + *-isMagma : IsMagma * + *-isMagma = record + { isEquivalence = isEquivalence + ; ∙-cong = *-cong + } + + *-isSemigroup : IsSemigroup * + *-isSemigroup = record + { isMagma = *-isMagma + ; assoc = *-assoc + } + + open IsMagma *-isMagma public + using () + renaming + ( ∙-congˡ to *-congˡ + ; ∙-congʳ to *-congʳ + ) + + zeroˡ : LeftZero 0# * + zeroˡ = proj₁ zero + + zeroʳ : RightZero 0# * + zeroʳ = proj₂ zero + + isNearSemiring : IsNearSemiring + * 0# + isNearSemiring = record + { +-isMonoid = +-isMonoid + ; *-cong = *-cong + ; *-assoc = *-assoc + ; distribʳ = proj₂ distrib + ; zeroˡ = zeroˡ + } + +record IsCommutativeSemiringWithoutOne + (+ * : Op₂ A) (0# : A) : Set (a ⊔ ℓ) where + field + isSemiringWithoutOne : IsSemiringWithoutOne + * 0# + *-comm : Commutative * + + open IsSemiringWithoutOne isSemiringWithoutOne public + + *-isCommutativeSemigroup : IsCommutativeSemigroup * + *-isCommutativeSemigroup = record + { isSemigroup = *-isSemigroup + ; comm = *-comm + } + + open IsCommutativeSemigroup *-isCommutativeSemigroup public + using () renaming (isCommutativeMagma to *-isCommutativeMagma) + +------------------------------------------------------------------------ +-- Structures with 2 binary operations & 2 elements +------------------------------------------------------------------------ + +record IsSemiringWithoutAnnihilatingZero (+ * : Op₂ A) + (0# 1# : A) : Set (a ⊔ ℓ) where + field + -- Note that these structures do have an additive unit, but this + -- unit does not necessarily annihilate multiplication. + +-isCommutativeMonoid : IsCommutativeMonoid + 0# + *-cong : Congruent₂ * + *-assoc : Associative * + *-identity : Identity 1# * + distrib : * DistributesOver + + + distribˡ : * DistributesOverˡ + + distribˡ = proj₁ distrib + + distribʳ : * DistributesOverʳ + + distribʳ = proj₂ distrib + + open IsCommutativeMonoid +-isCommutativeMonoid public + renaming + ( assoc to +-assoc + ; ∙-cong to +-cong + ; ∙-congˡ to +-congˡ + ; ∙-congʳ to +-congʳ + ; identity to +-identity + ; identityˡ to +-identityˡ + ; identityʳ to +-identityʳ + ; comm to +-comm + ; isMagma to +-isMagma + ; isSemigroup to +-isSemigroup + ; isMonoid to +-isMonoid + ; isUnitalMagma to +-isUnitalMagma + ; isCommutativeMagma to +-isCommutativeMagma + ; isCommutativeSemigroup to +-isCommutativeSemigroup + ) + + *-isMagma : IsMagma * + *-isMagma = record + { isEquivalence = isEquivalence + ; ∙-cong = *-cong + } + + *-isSemigroup : IsSemigroup * + *-isSemigroup = record + { isMagma = *-isMagma + ; assoc = *-assoc + } + + *-isMonoid : IsMonoid * 1# + *-isMonoid = record + { isSemigroup = *-isSemigroup + ; identity = *-identity + } + + open IsMonoid *-isMonoid public + using () + renaming + ( ∙-congˡ to *-congˡ + ; ∙-congʳ to *-congʳ + ; identityˡ to *-identityˡ + ; identityʳ to *-identityʳ + ) + + +record IsSemiring (+ * : Op₂ A) (0# 1# : A) : Set (a ⊔ ℓ) where + field + isSemiringWithoutAnnihilatingZero : + IsSemiringWithoutAnnihilatingZero + * 0# 1# + zero : Zero 0# * + + open IsSemiringWithoutAnnihilatingZero + isSemiringWithoutAnnihilatingZero public + + isSemiringWithoutOne : IsSemiringWithoutOne + * 0# + isSemiringWithoutOne = record + { +-isCommutativeMonoid = +-isCommutativeMonoid + ; *-cong = *-cong + ; *-assoc = *-assoc + ; distrib = distrib + ; zero = zero + } + + open IsSemiringWithoutOne isSemiringWithoutOne public + using + ( isNearSemiring + ; zeroˡ + ; zeroʳ + ) + + +record IsCommutativeSemiring (+ * : Op₂ A) (0# 1# : A) : Set (a ⊔ ℓ) where + field + isSemiring : IsSemiring + * 0# 1# + *-comm : Commutative * + + open IsSemiring isSemiring public + + isCommutativeSemiringWithoutOne : + IsCommutativeSemiringWithoutOne + * 0# + isCommutativeSemiringWithoutOne = record + { isSemiringWithoutOne = isSemiringWithoutOne + ; *-comm = *-comm + } + + open IsCommutativeSemiringWithoutOne isCommutativeSemiringWithoutOne public + using + ( *-isCommutativeMagma + ; *-isCommutativeSemigroup + ) + + *-isCommutativeMonoid : IsCommutativeMonoid * 1# + *-isCommutativeMonoid = record + { isMonoid = *-isMonoid + ; comm = *-comm + } + + +record IsCancellativeCommutativeSemiring (+ * : Op₂ A) (0# 1# : A) : Set (a ⊔ ℓ) where + field + isCommutativeSemiring : IsCommutativeSemiring + * 0# 1# + *-cancelˡ-nonZero : AlmostLeftCancellative 0# * + + open IsCommutativeSemiring isCommutativeSemiring public + +record IsIdempotentSemiring (+ * : Op₂ A) (0# 1# : A) : Set (a ⊔ ℓ) where + field + isSemiring : IsSemiring + * 0# 1# + +-idem : Idempotent + + + open IsSemiring isSemiring public + +record IsKleeneAlgebra (+ * : Op₂ A) (⋆ : Op₁ A) (0# 1# : A) : Set (a ⊔ ℓ) where + field + isIdempotentSemiring : IsIdempotentSemiring + * 0# 1# + starExpansive : StarExpansive 1# + * ⋆ + starDestructive : StarDestructive + * ⋆ + + open IsIdempotentSemiring isIdempotentSemiring public + + starExpansiveˡ : StarLeftExpansive 1# + * ⋆ + starExpansiveˡ = proj₁ starExpansive + + starExpansiveʳ : StarRightExpansive 1# + * ⋆ + starExpansiveʳ = proj₂ starExpansive + + starDestructiveˡ : StarLeftDestructive + * ⋆ + starDestructiveˡ = proj₁ starDestructive + + starDestructiveʳ : StarRightDestructive + * ⋆ + starDestructiveʳ = proj₂ starDestructive + +record IsQuasiring (+ * : Op₂ A) (0# 1# : A) : Set (a ⊔ ℓ) where + field + +-isMonoid : IsMonoid + 0# + *-cong : Congruent₂ * + *-assoc : Associative * + *-identity : Identity 1# * + distrib : * DistributesOver + + zero : Zero 0# * + + open IsMonoid +-isMonoid public + renaming + ( assoc to +-assoc + ; ∙-cong to +-cong + ; ∙-congˡ to +-congˡ + ; ∙-congʳ to +-congʳ + ; identity to +-identity + ; identityˡ to +-identityˡ + ; identityʳ to +-identityʳ + ; isMagma to +-isMagma + ; isUnitalMagma to +-isUnitalMagma + ; isSemigroup to +-isSemigroup + ) + + distribˡ : * DistributesOverˡ + + distribˡ = proj₁ distrib + + distribʳ : * DistributesOverʳ + + distribʳ = proj₂ distrib + + zeroˡ : LeftZero 0# * + zeroˡ = proj₁ zero + + zeroʳ : RightZero 0# * + zeroʳ = proj₂ zero + + identityˡ : LeftIdentity 1# * + identityˡ = proj₁ *-identity + + identityʳ : RightIdentity 1# * + identityʳ = proj₂ *-identity + + *-isMagma : IsMagma * + *-isMagma = record + { isEquivalence = isEquivalence + ; ∙-cong = *-cong + } + + *-isSemigroup : IsSemigroup * + *-isSemigroup = record + { isMagma = *-isMagma + ; assoc = *-assoc + } + + *-isMonoid : IsMonoid * 1# + *-isMonoid = record + { isSemigroup = *-isSemigroup + ; identity = *-identity + } + + open IsMonoid *-isMonoid public + using () + renaming + ( ∙-congˡ to *-congˡ + ; ∙-congʳ to *-congʳ + ; identityˡ to *-identityˡ + ; identityʳ to *-identityʳ + ) + +------------------------------------------------------------------------ +-- Structures with 2 binary operations, 1 unary operation & 1 element +------------------------------------------------------------------------ + +record IsRingWithoutOne (+ * : Op₂ A) (-_ : Op₁ A) (0# : A) : Set (a ⊔ ℓ) where + field + +-isAbelianGroup : IsAbelianGroup + 0# -_ + *-cong : Congruent₂ * + *-assoc : Associative * + distrib : * DistributesOver + + + open IsAbelianGroup +-isAbelianGroup public + renaming + ( assoc to +-assoc + ; ∙-cong to +-cong + ; ∙-congˡ to +-congˡ + ; ∙-congʳ to +-congʳ + ; identity to +-identity + ; identityˡ to +-identityˡ + ; identityʳ to +-identityʳ + ; inverse to -‿inverse + ; inverseˡ to -‿inverseˡ + ; inverseʳ to -‿inverseʳ + ; ⁻¹-cong to -‿cong + ; comm to +-comm + ; isMagma to +-isMagma + ; isSemigroup to +-isSemigroup + ; isMonoid to +-isMonoid + ; isUnitalMagma to +-isUnitalMagma + ; isCommutativeMagma to +-isCommutativeMagma + ; isCommutativeMonoid to +-isCommutativeMonoid + ; isCommutativeSemigroup to +-isCommutativeSemigroup + ; isInvertibleMagma to +-isInvertibleMagma + ; isInvertibleUnitalMagma to +-isInvertibleUnitalMagma + ; isGroup to +-isGroup + ) + + distribˡ : * DistributesOverˡ + + distribˡ = proj₁ distrib + + distribʳ : * DistributesOverʳ + + distribʳ = proj₂ distrib + + zeroˡ : LeftZero 0# * + zeroˡ = Consequences.assoc∧distribʳ∧idʳ∧invʳ⇒zeˡ setoid + +-cong *-cong +-assoc distribʳ +-identityʳ -‿inverseʳ + + zeroʳ : RightZero 0# * + zeroʳ = Consequences.assoc∧distribˡ∧idʳ∧invʳ⇒zeʳ setoid + +-cong *-cong +-assoc distribˡ +-identityʳ -‿inverseʳ + + zero : Zero 0# * + zero = zeroˡ , zeroʳ + + *-isMagma : IsMagma * + *-isMagma = record + { isEquivalence = isEquivalence + ; ∙-cong = *-cong + } + + *-isSemigroup : IsSemigroup * + *-isSemigroup = record + { isMagma = *-isMagma + ; assoc = *-assoc + } + + open IsSemigroup *-isSemigroup public + using () + renaming + ( ∙-congˡ to *-congˡ + ; ∙-congʳ to *-congʳ + ) + +------------------------------------------------------------------------ +-- Structures with 2 binary operations, 1 unary operation & 2 elements +------------------------------------------------------------------------ + +record IsNonAssociativeRing (+ * : Op₂ A) (-_ : Op₁ A) (0# 1# : A) : Set (a ⊔ ℓ) where + field + +-isAbelianGroup : IsAbelianGroup + 0# -_ + *-cong : Congruent₂ * + *-identity : Identity 1# * + distrib : * DistributesOver + + zero : Zero 0# * + + open IsAbelianGroup +-isAbelianGroup public + renaming + ( assoc to +-assoc + ; ∙-cong to +-cong + ; ∙-congˡ to +-congˡ + ; ∙-congʳ to +-congʳ + ; identity to +-identity + ; identityˡ to +-identityˡ + ; identityʳ to +-identityʳ + ; inverse to -‿inverse + ; inverseˡ to -‿inverseˡ + ; inverseʳ to -‿inverseʳ + ; ⁻¹-cong to -‿cong + ; comm to +-comm + ; isMagma to +-isMagma + ; isSemigroup to +-isSemigroup + ; isMonoid to +-isMonoid + ; isUnitalMagma to +-isUnitalMagma + ; isCommutativeMagma to +-isCommutativeMagma + ; isCommutativeMonoid to +-isCommutativeMonoid + ; isCommutativeSemigroup to +-isCommutativeSemigroup + ; isInvertibleMagma to +-isInvertibleMagma + ; isInvertibleUnitalMagma to +-isInvertibleUnitalMagma + ; isGroup to +-isGroup + ) + + zeroˡ : LeftZero 0# * + zeroˡ = proj₁ zero + + zeroʳ : RightZero 0# * + zeroʳ = proj₂ zero + + distribˡ : * DistributesOverˡ + + distribˡ = proj₁ distrib + + distribʳ : * DistributesOverʳ + + distribʳ = proj₂ distrib + + *-isMagma : IsMagma * + *-isMagma = record + { isEquivalence = isEquivalence + ; ∙-cong = *-cong + } + + *-identityˡ : LeftIdentity 1# * + *-identityˡ = proj₁ *-identity + + *-identityʳ : RightIdentity 1# * + *-identityʳ = proj₂ *-identity + + *-isUnitalMagma : IsUnitalMagma * 1# + *-isUnitalMagma = record + { isMagma = *-isMagma + ; identity = *-identity + } + + open IsUnitalMagma *-isUnitalMagma public + using () + renaming + ( ∙-congˡ to *-congˡ + ; ∙-congʳ to *-congʳ + ) + +record IsNearring (+ * : Op₂ A) (0# 1# : A) (_⁻¹ : Op₁ A) : Set (a ⊔ ℓ) where + field + isQuasiring : IsQuasiring + * 0# 1# + +-inverse : Inverse 0# _⁻¹ + + ⁻¹-cong : Congruent₁ _⁻¹ + + open IsQuasiring isQuasiring public + + +-inverseˡ : LeftInverse 0# _⁻¹ + + +-inverseˡ = proj₁ +-inverse + + +-inverseʳ : RightInverse 0# _⁻¹ + + +-inverseʳ = proj₂ +-inverse + +record IsRing (+ * : Op₂ A) (-_ : Op₁ A) (0# 1# : A) : Set (a ⊔ ℓ) where + field + +-isAbelianGroup : IsAbelianGroup + 0# -_ + *-cong : Congruent₂ * + *-assoc : Associative * + *-identity : Identity 1# * + distrib : * DistributesOver + + + isRingWithoutOne : IsRingWithoutOne + * -_ 0# + isRingWithoutOne = record + { +-isAbelianGroup = +-isAbelianGroup + ; *-cong = *-cong + ; *-assoc = *-assoc + ; distrib = distrib + } + + open IsRingWithoutOne isRingWithoutOne public + hiding (+-isAbelianGroup; *-cong; *-assoc; distrib) + + *-isMonoid : IsMonoid * 1# + *-isMonoid = record + { isSemigroup = *-isSemigroup + ; identity = *-identity + } + + open IsMonoid *-isMonoid public + using () + renaming + ( identityˡ to *-identityˡ + ; identityʳ to *-identityʳ + ) + + isSemiringWithoutAnnihilatingZero + : IsSemiringWithoutAnnihilatingZero + * 0# 1# + isSemiringWithoutAnnihilatingZero = record + { +-isCommutativeMonoid = +-isCommutativeMonoid + ; *-cong = *-cong + ; *-assoc = *-assoc + ; *-identity = *-identity + ; distrib = distrib + } + + isSemiring : IsSemiring + * 0# 1# + isSemiring = record + { isSemiringWithoutAnnihilatingZero = + isSemiringWithoutAnnihilatingZero + ; zero = zero + } + + open IsSemiring isSemiring public + using (isNearSemiring; isSemiringWithoutOne) + + +record IsCommutativeRing + (+ * : Op₂ A) (- : Op₁ A) (0# 1# : A) : Set (a ⊔ ℓ) where + 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 + ; *-isCommutativeMagma + ; *-isCommutativeSemigroup + ; *-isCommutativeMonoid + ) + +------------------------------------------------------------------------ +-- Structures with 3 binary operations +------------------------------------------------------------------------ + +record IsQuasigroup (∙ \\ // : Op₂ A) : Set (a ⊔ ℓ) where + field + isMagma : IsMagma ∙ + \\-cong : Congruent₂ \\ + //-cong : Congruent₂ // + leftDivides : LeftDivides ∙ \\ + rightDivides : RightDivides ∙ // + + open IsMagma isMagma public + + \\-congˡ : LeftCongruent \\ + \\-congˡ y≈z = \\-cong refl y≈z + + \\-congʳ : RightCongruent \\ + \\-congʳ y≈z = \\-cong y≈z refl + + //-congˡ : LeftCongruent // + //-congˡ y≈z = //-cong refl y≈z + + //-congʳ : RightCongruent // + //-congʳ y≈z = //-cong y≈z refl + + leftDividesˡ : LeftDividesˡ ∙ \\ + leftDividesˡ = proj₁ leftDivides + + leftDividesʳ : LeftDividesʳ ∙ \\ + leftDividesʳ = proj₂ leftDivides + + rightDividesˡ : RightDividesˡ ∙ // + rightDividesˡ = proj₁ rightDivides + + rightDividesʳ : RightDividesʳ ∙ // + rightDividesʳ = proj₂ rightDivides - rightDividesʳ : RightDividesʳ ∙ // - rightDividesʳ = proj₂ rightDivides +record IsLoop (∙ \\ // : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where + field + isQuasigroup : IsQuasigroup ∙ \\ // + identity : Identity ε ∙ -record IsLoop (∙ \\ // : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where - field - isQuasigroup : IsQuasigroup ∙ \\ // - identity : Identity ε ∙ + open IsQuasigroup isQuasigroup public - open IsQuasigroup isQuasigroup public + identityˡ : LeftIdentity ε ∙ + identityˡ = proj₁ identity - identityˡ : LeftIdentity ε ∙ - identityˡ = proj₁ identity + identityʳ : RightIdentity ε ∙ + identityʳ = proj₂ identity - identityʳ : RightIdentity ε ∙ - identityʳ = proj₂ identity +record IsLeftBolLoop (∙ \\ // : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where + field + isLoop : IsLoop ∙ \\ // ε + leftBol : LeftBol ∙ -record IsLeftBolLoop (∙ \\ // : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where - field - isLoop : IsLoop ∙ \\ // ε - leftBol : LeftBol ∙ + open IsLoop isLoop public - open IsLoop isLoop public +record IsRightBolLoop (∙ \\ // : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where + field + isLoop : IsLoop ∙ \\ // ε + rightBol : RightBol ∙ -record IsRightBolLoop (∙ \\ // : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where - field - isLoop : IsLoop ∙ \\ // ε - rightBol : RightBol ∙ + open IsLoop isLoop public - open IsLoop isLoop public +record IsMoufangLoop (∙ \\ // : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where + field + isLeftBolLoop : IsLeftBolLoop ∙ \\ // ε + rightBol : RightBol ∙ + identical : Identical ∙ -record IsMoufangLoop (∙ \\ // : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where - field - isLeftBolLoop : IsLeftBolLoop ∙ \\ // ε - rightBol : RightBol ∙ - identical : Identical ∙ + open IsLeftBolLoop isLeftBolLoop public - open IsLeftBolLoop isLeftBolLoop public +record IsMiddleBolLoop (∙ \\ // : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where + field + isLoop : IsLoop ∙ \\ // ε + middleBol : MiddleBol ∙ \\ // -record IsMiddleBolLoop (∙ \\ // : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where - field - isLoop : IsLoop ∙ \\ // ε - middleBol : MiddleBol ∙ \\ // - - open IsLoop isLoop public + open IsLoop isLoop public \ No newline at end of file diff --git a/Axiom.Extensionality.Propositional.html b/Axiom.Extensionality.Propositional.html index b207c900..5b372906 100644 --- a/Axiom.Extensionality.Propositional.html +++ b/Axiom.Extensionality.Propositional.html @@ -41,8 +41,8 @@ lower-extensionality : ∀ {a₁ b₁} a₂ b₂ → Extensionality (a₁ ⊔ a₂) (b₁ ⊔ b₂) → Extensionality a₁ b₁ -lower-extensionality a₂ b₂ ext f≡g = cong (λ h → Level.lower ∘ h ∘ lift) $ - ext (cong (lift {ℓ = b₂}) ∘ f≡g ∘ Level.lower {ℓ = a₂}) +lower-extensionality a₂ b₂ ext f≡g = cong (λ h → Level.lower ∘ h ∘ lift) $ + ext (cong (lift {ℓ = b₂}) ∘ f≡g ∘ Level.lower {ℓ = a₂}) -- Functional extensionality implies a form of extensionality for -- Π-types. @@ -60,5 +60,5 @@ implicit-extensionality : ∀ {a b} → Extensionality a b → ExtensionalityImplicit a b -implicit-extensionality ext f≡g = cong _$- (ext (λ x → f≡g)) +implicit-extensionality ext f≡g = cong _$- (ext (λ x → f≡g)) \ No newline at end of file diff --git a/Axiom.UniquenessOfIdentityProofs.html b/Axiom.UniquenessOfIdentityProofs.html index 6be463c6..c94fb0e9 100644 --- a/Axiom.UniquenessOfIdentityProofs.html +++ b/Axiom.UniquenessOfIdentityProofs.html @@ -11,8 +11,8 @@ open import Data.Bool.Base using (true; false) open import Data.Empty -open import Relation.Nullary.Reflects using (invert) -open import Relation.Nullary hiding (Irrelevant) +open import Relation.Nullary.Reflects using (invert) +open import Relation.Nullary hiding (Irrelevant) open import Relation.Binary.Core open import Relation.Binary.Definitions open import Relation.Binary.PropositionalEquality.Core @@ -26,7 +26,7 @@ -- is irrelevant. Here we define UIP relative to a given type. UIP : ∀ {a} (A : Set a) → Set a -UIP A = Irrelevant {A = A} _≡_ +UIP A = Irrelevant {A = A} _≡_ ------------------------------------------------------------------------ -- Properties @@ -40,20 +40,20 @@ -- the image of any other proof. module Constant⇒UIP - {a} {A : Set a} (f : _≡_ {A = A} ⇒ _≡_) + {a} {A : Set a} (f : _≡_ {A = A} ⇒ _≡_) (f-constant : ∀ {a b} (p q : a ≡ b) → f p ≡ f q) where - ≡-canonical : ∀ {a b} (p : a ≡ b) → trans (sym (f refl)) (f p) ≡ p - ≡-canonical refl = trans-symˡ (f refl) + ≡-canonical : ∀ {a b} (p : a ≡ b) → trans (sym (f refl)) (f p) ≡ p + ≡-canonical refl = trans-symˡ (f refl) ≡-irrelevant : UIP A - ≡-irrelevant p q = begin - p ≡⟨ sym (≡-canonical p) ⟩ - trans (sym (f refl)) (f p) ≡⟨ cong (trans _) (f-constant p q) ⟩ - trans (sym (f refl)) (f q) ≡⟨ ≡-canonical q ⟩ - q ∎ - where open ≡-Reasoning + ≡-irrelevant p q = begin + p ≡⟨ sym (≡-canonical p) ⟩ + trans (sym (f refl)) (f p) ≡⟨ cong (trans _) (f-constant p q) ⟩ + trans (sym (f refl)) (f q) ≡⟨ ≡-canonical q ⟩ + q ∎ + where open ≡-Reasoning -- If equality is decidable for a given type, then we can prove UIP for -- that type. Indeed, the decision procedure allows us to define a @@ -61,18 +61,18 @@ -- proof produced by the decision procedure. module Decidable⇒UIP - {a} {A : Set a} (_≟_ : Decidable {A = A} _≡_) + {a} {A : Set a} (_≟_ : Decidable {A = A} _≡_) where - ≡-normalise : _≡_ {A = A} ⇒ _≡_ + ≡-normalise : _≡_ {A = A} ⇒ _≡_ ≡-normalise {a} {b} a≡b with a ≟ b - ... | true because [p] = invert [p] - ... | false because [¬p] = ⊥-elim (invert [¬p] a≡b) + ... | true because [p] = invert [p] + ... | false because [¬p] = ⊥-elim (invert [¬p] a≡b) ≡-normalise-constant : ∀ {a b} (p q : a ≡ b) → ≡-normalise p ≡ ≡-normalise q ≡-normalise-constant {a} {b} p q with a ≟ b - ... | true because _ = refl - ... | false because [¬p] = ⊥-elim (invert [¬p] p) + ... | true because _ = refl + ... | false because [¬p] = ⊥-elim (invert [¬p] p) ≡-irrelevant : UIP A ≡-irrelevant = Constant⇒UIP.≡-irrelevant ≡-normalise ≡-normalise-constant diff --git a/Calf.CBPV.html b/Calf.CBPV.html index 220d224b..c0a7308e 100644 --- a/Calf.CBPV.html +++ b/Calf.CBPV.html @@ -9,8 +9,8 @@ open import Relation.Binary.PropositionalEquality open import Data.Unit using () renaming (tt to triv) public open import Data.Unit renaming (⊤ to Unit) -open import Data.Product using (_,_; proj₁; proj₂) public -open import Data.Product using (Σ; _×_) +open import Data.Product using (_,_; proj₁; proj₂) public +open import Data.Product using (Σ; _×_) postulate tp⁺ : □ @@ -62,7 +62,7 @@ {-# REWRITE Π/decode #-} prod⁻ : tp⁻ → tp⁻ → tp⁻ - prod⁻/decode : val (U (prod⁻ X Y)) ≡ (cmp X × cmp Y) + prod⁻/decode : val (U (prod⁻ X Y)) ≡ (cmp X × cmp Y) {-# REWRITE prod⁻/decode #-} unit⁻ : tp⁻ diff --git a/Calf.Data.BigO.html b/Calf.Data.BigO.html index 61e7481a..7336c214 100644 --- a/Calf.Data.BigO.html +++ b/Calf.Data.BigO.html @@ -5,9 +5,9 @@ open import Algebra.Cost -module Calf.Data.BigO (costMonoid : CostMonoid) where +module Calf.Data.BigO (costMonoid : CostMonoid) where -open CostMonoid costMonoid +open CostMonoid costMonoid open import Calf.Prelude open import Calf.CBPV @@ -18,26 +18,26 @@ open import Relation.Binary.PropositionalEquality as Eq using (_≡_) -[_]*_ : ℕ → ℂ → ℂ -[ ℕ.zero ]* c = zero -[ ℕ.suc k ]* c = c + [ k ]* c +[_]*_ : ℕ → ℂ → ℂ +[ ℕ.zero ]* c = zero +[ ℕ.suc k ]* c = c + [ k ]* c record given_measured-via_,_∈𝓞_ (A : tp⁺) {B : val A → tp⁺} (∣_∣ : val A → val nat) - (f : cmp (Π A λ a → F (B a))) (g : ℕ → ℂ) : □ + (f : cmp (Π A λ a → F (B a))) (g : ℕ → ℂ) : □ where constructor _≤n⇒f[n]≤_g[n]via_ field n' : val nat k : val nat - h : ∀ a → n' Nat.≤ ∣ a ∣ → IsBounded (B a) (f a) ([ k ]* g ∣ a ∣) + h : ∀ a → n' Nat.≤ ∣ a ∣ → IsBounded (B a) (f a) ([ k ]* g ∣ a ∣) _≤n⇒f[n]≤g[n]via_ : ∀ {A : tp⁺} {B : val A → tp⁺} {f ∣_∣ g} → - (n' : val nat) → (∀ a → n' Nat.≤ ∣ a ∣ → IsBounded (B a) (f a) (g ∣ a ∣)) → given A measured-via ∣_∣ , f ∈𝓞 g + (n' : val nat) → (∀ a → n' Nat.≤ ∣ a ∣ → IsBounded (B a) (f a) (g ∣ a ∣)) → given A measured-via ∣_∣ , f ∈𝓞 g _≤n⇒f[n]≤g[n]via_ {B = B} {f = f} n' h = n' ≤n⇒f[n]≤ 1 g[n]via λ a h≤ → - Eq.subst (IsBounded (B a) (f a)) (Eq.sym (+-identityʳ _)) (h a h≤) + Eq.subst (IsBounded (B a) (f a)) (Eq.sym (+-identityʳ _)) (h a h≤) f[n]≤g[n]via_ : ∀ {A : tp⁺} {B : val A → tp⁺} {f ∣_∣ g} → (∀ a → IsBounded (B a) (f a) (g ∣ a ∣)) → given A measured-via ∣_∣ , f ∈𝓞 g diff --git a/Calf.Data.IsBounded.html b/Calf.Data.IsBounded.html index 7b64de9c..0f79c97c 100644 --- a/Calf.Data.IsBounded.html +++ b/Calf.Data.IsBounded.html @@ -5,9 +5,9 @@ -- Upper bound on the cost of a computation. -module Calf.Data.IsBounded (costMonoid : CostMonoid) where +module Calf.Data.IsBounded (costMonoid : CostMonoid) where -open CostMonoid costMonoid +open CostMonoid costMonoid open import Calf.Prelude open import Calf.CBPV @@ -17,57 +17,57 @@ open import Calf.Data.IsBoundedG costMonoid -IsBounded : (A : tp⁺) → cmp (F A) → ℂ → Set +IsBounded : (A : tp⁺) → cmp (F A) → ℂ → Set IsBounded A e c = IsBoundedG A e (step⋆ c) -bound/relax : {c c' : ℂ} → c ≤ c' → {e : cmp (F A)} → IsBounded A e c → IsBounded A e c' +bound/relax : {c c' : ℂ} → c ≤ c' → {e : cmp (F A)} → IsBounded A e c → IsBounded A e c' bound/relax h {e = e} = boundg/relax (step-monoˡ-≤⁻ (ret triv) h) {e = e} -bound/ret : {A : tp⁺} (a : val A) → IsBounded A (ret a) zero +bound/ret : {A : tp⁺} (a : val A) → IsBounded A (ret a) zero bound/ret a = ≤⁻-refl -bound/step : {A : tp⁺} (c : ℂ) {c' : ℂ} (e : cmp (F A)) → +bound/step : {A : tp⁺} (c : ℂ) {c' : ℂ} (e : cmp (F A)) → IsBounded A e c' → - IsBounded A (step (F A) c e) (c + c') + IsBounded A (step (F A) c e) (c + c') bound/step c {c'} e h = boundg/step c {b = step⋆ c'} e h bound/bind/const : {e : cmp (F A)} {f : val A → cmp (F B)} - (c d : ℂ) → + (c d : ℂ) → IsBounded A e c → ((a : val A) → IsBounded B (f a) d) → - IsBounded B (bind {A} (F B) e f) (c + d) + IsBounded B (bind {A} (F B) e f) (c + d) bound/bind/const {e = e} {f} c d he hf = - let open ≤⁻-Reasoning cost in - begin + let open ≤⁻-Reasoning cost in + begin bind cost e (λ v → bind cost (f v) (λ _ → ret triv)) - ≤⟨ bind-monoʳ-≤⁻ e hf ⟩ + ≲⟨ bind-monoʳ-≤⁻ e hf ⟩ bind cost e (λ _ → step⋆ d) - ≡⟨⟩ + ≡⟨⟩ bind cost (bind cost e λ _ → ret triv) (λ _ → step⋆ d) - ≤⟨ bind-monoˡ-≤⁻ (λ _ → step⋆ d) he ⟩ + ≲⟨ bind-monoˡ-≤⁻ (λ _ → step⋆ d) he ⟩ bind cost (step⋆ c) (λ _ → step⋆ d) - ≡⟨⟩ - step⋆ (c + d) - ∎ + ≡⟨⟩ + step⋆ (c + d) + ∎ module Legacy where open import Calf.Data.Product open import Calf.Data.Equality - legacy : {e : cmp (F A)} {c : ℂ} → - val (Σ⁺ ℂ⁺ λ c' → meta⁺ (c' ≤ c) ×⁺ Σ⁺ A λ a → e ≡⁺[ U (F A) ] step (F A) c' (ret a)) → + legacy : {e : cmp (F A)} {c : ℂ} → + val (Σ⁺ ℂ⁺ λ c' → meta⁺ (c' ≤ c) ×⁺ Σ⁺ A λ a → e ≡⁺[ U (F A) ] step (F A) c' (ret a)) → IsBounded A e c legacy {A} {e} {c} (c' , c'≤c , a , e≡step-ret) = - let open ≤⁻-Reasoning cost in - begin + let open ≤⁻-Reasoning cost in + begin bind cost e (λ _ → ret triv) - ≡⟨ cong (λ e → bind cost e (λ _ → ret triv)) e≡step-ret ⟩ + ≡⟨ cong (λ e → bind cost e (λ _ → ret triv)) e≡step-ret ⟩ bind cost (step (F A) c' (ret a)) (λ _ → ret triv) - ≡⟨⟩ + ≡⟨⟩ step⋆ c' - ≤⟨ step-monoˡ-≤⁻ (ret triv) c'≤c ⟩ + ≲⟨ step-monoˡ-≤⁻ (ret triv) c'≤c ⟩ step⋆ c - ∎ + ∎ \ No newline at end of file diff --git a/Calf.Data.IsBoundedG.html b/Calf.Data.IsBoundedG.html index 3d5d4a23..df867ed8 100644 --- a/Calf.Data.IsBoundedG.html +++ b/Calf.Data.IsBoundedG.html @@ -5,9 +5,9 @@ -- Upper bound on the cost of a computation. -module Calf.Data.IsBoundedG (costMonoid : CostMonoid) where +module Calf.Data.IsBoundedG (costMonoid : CostMonoid) where -open CostMonoid costMonoid +open CostMonoid costMonoid open import Calf.Prelude open import Calf.CBPV @@ -26,7 +26,7 @@ step⋆ : cmp (Π ℂ⁺ λ _ → cost) step⋆ c = step cost c (ret triv) -step⋆-mono-≤⁻ : {c c' : ℂ} → c ≤ c' → step⋆ c ≤⁻[ cost ] step⋆ c' +step⋆-mono-≤⁻ : {c c' : ℂ} → c ≤ c' → step⋆ c ≤⁻[ cost ] step⋆ c' step⋆-mono-≤⁻ = step-monoˡ-≤⁻ (ret triv) @@ -36,39 +36,39 @@ → IsBoundedG A e b → IsBoundedG A e b' boundg/relax {b = b} {b'} h {e = e} ib-b = - let open ≤⁻-Reasoning cost in - begin + let open ≤⁻-Reasoning cost in + begin bind cost e (λ _ → ret triv) - ≤⟨ ib-b ⟩ + ≲⟨ ib-b ⟩ b - ≤⟨ h ⟩ + ≲⟨ h ⟩ b' - ∎ + ∎ -boundg/step : (c : ℂ) {b : cmp cost} (e : cmp (F A)) → +boundg/step : (c : ℂ) {b : cmp cost} (e : cmp (F A)) → IsBoundedG A e b → IsBoundedG A (step (F A) c e) (step cost c b) boundg/step c {b} e h = - let open ≤⁻-Reasoning cost in - begin + let open ≤⁻-Reasoning cost in + begin bind cost (step (F _) c e) (λ _ → ret triv) - ≡⟨⟩ + ≡⟨⟩ step cost c (bind cost e (λ _ → ret triv)) - ≤⟨ step-monoʳ-≤⁻ c h ⟩ + ≲⟨ step-monoʳ-≤⁻ c h ⟩ step cost c b - ∎ + ∎ boundg/bind : {e : cmp (F A)} {f : val A → cmp (F B)} (b : val A → cmp cost) → ((a : val A) → IsBoundedG B (f a) (b a)) → IsBoundedG B (bind {A} (F B) e f) (bind {A} cost e b) boundg/bind {e = e} {f} b hf = - let open ≤⁻-Reasoning cost in - begin + let open ≤⁻-Reasoning cost in + begin bind cost (bind (F _) e f) (λ _ → ret triv) - ≡⟨⟩ + ≡⟨⟩ bind cost e (λ a → bind cost (f a) λ _ → ret triv) - ≤⟨ bind-monoʳ-≤⁻ e hf ⟩ + ≲⟨ bind-monoʳ-≤⁻ e hf ⟩ bind cost e b - ∎ + ∎ \ No newline at end of file diff --git a/Calf.Data.Maybe.html b/Calf.Data.Maybe.html index 4ca3a09a..4b9fd4c8 100644 --- a/Calf.Data.Maybe.html +++ b/Calf.Data.Maybe.html @@ -6,7 +6,7 @@ open import Calf.Prelude open import Calf.CBPV -open import Data.Maybe public renaming (maybe to maybe-case) +open import Data.Maybe public renaming (maybe to maybe-case) maybe : tp⁺ → tp⁺ maybe A = meta⁺ (Maybe (val A)) diff --git a/Calf.Data.Product.html b/Calf.Data.Product.html index 151826b7..94ddecdd 100644 --- a/Calf.Data.Product.html +++ b/Calf.Data.Product.html @@ -9,12 +9,12 @@ -- definitions exported by CBPV.agda are hidden open import Data.Unit public renaming (⊤ to Unit) hiding (tt) -open import Data.Product hiding (_,_; proj₁; proj₂) public +open import Data.Product hiding (_,_; proj₁; proj₂) public unit : tp⁺ unit = meta⁺ Unit infixr 2 _×⁺_ _×⁺_ : tp⁺ → tp⁺ → tp⁺ -A ×⁺ B = meta⁺ (val A × val B) +A ×⁺ B = meta⁺ (val A × val B) \ No newline at end of file diff --git a/Calf.Directed.html b/Calf.Directed.html index cd6edfa8..9828e79b 100644 --- a/Calf.Directed.html +++ b/Calf.Directed.html @@ -16,22 +16,22 @@ infix 4 _≤⁺_ postulate _≤⁺_ : val A → val A → □ - ≤⁺-isPreorder : IsPreorder _≡_ (_≤⁺_ {A}) + ≤⁺-isPreorder : IsPreorder _≡_ (_≤⁺_ {A}) ≤⁺-mono : (f : val A → val B) → - f Preserves (_≤⁺_ {A}) ⟶ (_≤⁺_ {B}) + f Preserves (_≤⁺_ {A}) ⟶ (_≤⁺_ {B}) -≤⁺-reflexive : _≡_ ⇒ _≤⁺_ {A} -≤⁺-reflexive = IsPreorder.reflexive ≤⁺-isPreorder +≤⁺-reflexive : _≡_ ⇒ _≤⁺_ {A} +≤⁺-reflexive = IsPreorder.reflexive ≤⁺-isPreorder -≤⁺-refl : Reflexive (_≤⁺_ {A}) -≤⁺-refl = IsPreorder.refl ≤⁺-isPreorder +≤⁺-refl : Reflexive (_≤⁺_ {A}) +≤⁺-refl = IsPreorder.refl ≤⁺-isPreorder -≤⁺-trans : Transitive (_≤⁺_ {A}) -≤⁺-trans = IsPreorder.trans ≤⁺-isPreorder +≤⁺-trans : Transitive (_≤⁺_ {A}) +≤⁺-trans = IsPreorder.trans ≤⁺-isPreorder ≤⁺-mono₂ : (f : val A → val B → val C) → - f Preserves₂ (_≤⁺_ {A}) ⟶ (_≤⁺_ {B}) ⟶ (_≤⁺_ {C}) + f Preserves₂ (_≤⁺_ {A}) ⟶ (_≤⁺_ {B}) ⟶ (_≤⁺_ {C}) ≤⁺-mono₂ f a≤a' b≤b' = ≤⁺-trans (≤⁺-mono (f _) b≤b') @@ -50,20 +50,20 @@ _≤⁻_ : cmp X → cmp X → □ _≤⁻_ {X} e e' = e ≤⁺[ U X ] e' -≤⁻-isPreorder : IsPreorder _≡_ (_≤⁻_ {X}) +≤⁻-isPreorder : IsPreorder _≡_ (_≤⁻_ {X}) ≤⁻-isPreorder {X} = record - { isEquivalence = IsPreorder.isEquivalence (≤⁺-isPreorder {U X}) - ; reflexive = ≤⁺-reflexive - ; trans = ≤⁺-trans + { isEquivalence = IsPreorder.isEquivalence (≤⁺-isPreorder {U X}) + ; reflexive = ≤⁺-reflexive + ; trans = ≤⁺-trans } ≤⁻-mono : (f : cmp X → cmp Y) → - f Preserves (_≤⁻_ {X}) ⟶ (_≤⁻_ {Y}) + f Preserves (_≤⁻_ {X}) ⟶ (_≤⁻_ {Y}) ≤⁻-mono = ≤⁺-mono ≤⁻-mono₂ : (f : cmp X → cmp Y → cmp Z) → - f Preserves₂ (_≤⁻_ {X}) ⟶ (_≤⁻_ {Y}) ⟶ (_≤⁻_ {Z}) + f Preserves₂ (_≤⁻_ {X}) ⟶ (_≤⁻_ {Y}) ⟶ (_≤⁻_ {Z}) ≤⁻-mono₂ = ≤⁺-mono₂ postulate @@ -71,14 +71,14 @@ → ((a : val A) → _≤⁻_ {X a} (f a) (f' a)) → _≤⁻_ {Π A X} f f' -≤⁻-reflexive : _≡_ ⇒ _≤⁻_ {X} -≤⁻-reflexive = IsPreorder.reflexive ≤⁻-isPreorder +≤⁻-reflexive : _≡_ ⇒ _≤⁻_ {X} +≤⁻-reflexive = IsPreorder.reflexive ≤⁻-isPreorder -≤⁻-refl : Reflexive (_≤⁻_ {X}) -≤⁻-refl = IsPreorder.refl ≤⁻-isPreorder +≤⁻-refl : Reflexive (_≤⁻_ {X}) +≤⁻-refl = IsPreorder.refl ≤⁻-isPreorder -≤⁻-trans : Transitive (_≤⁻_ {X}) -≤⁻-trans = IsPreorder.trans ≤⁻-isPreorder +≤⁻-trans : Transitive (_≤⁻_ {X}) +≤⁻-trans = IsPreorder.trans ≤⁻-isPreorder ≤⁻-syntax : cmp X → cmp X → □ ≤⁻-syntax {X} = _≤⁻_ {X} @@ -119,17 +119,16 @@ bind-irr-mono-≤⁻ e₁≤e₁' ≤⁻-refl -open import Relation.Binary.Structures +open import Level using (0ℓ) +open import Relation.Binary using (Preorder) +open import Relation.Binary.Structures -module ≤⁻-Reasoning (X : tp⁻) where - open import Relation.Binary.Reasoning.Base.Triple - (≤⁻-isPreorder {X}) - ≤⁻-trans - (resp₂ _≤⁻_) - (λ h → h) - ≤⁻-trans - ≤⁻-trans - public - hiding (begin-strict_; step-<; step-≈; step-≈˘) - renaming (step-≤ to step-≤⁻) +≤⁻-preorder : tp⁻ → Preorder 0ℓ 0ℓ 0ℓ +Preorder.Carrier (≤⁻-preorder X) = cmp X +Preorder._≈_ (≤⁻-preorder X) = _≡_ +Preorder._≲_ (≤⁻-preorder X) = _≤⁻_ {X} +Preorder.isPreorder (≤⁻-preorder X) = ≤⁻-isPreorder {X} + +module ≤⁻-Reasoning (X : tp⁻) where + open import Relation.Binary.Reasoning.Preorder (≤⁻-preorder X) public \ No newline at end of file diff --git a/Calf.Parallel.html b/Calf.Parallel.html index 7795c016..1857ce51 100644 --- a/Calf.Parallel.html +++ b/Calf.Parallel.html @@ -5,18 +5,18 @@ open import Algebra.Cost -module Calf.Parallel (parCostMonoid : ParCostMonoid) where +module Calf.Parallel (parCostMonoid : ParCostMonoid) where -open ParCostMonoid parCostMonoid +open ParCostMonoid parCostMonoid open import Calf.Prelude open import Calf.CBPV open import Calf.Directed -open import Calf.Step costMonoid +open import Calf.Step costMonoid open import Calf.Data.Product -open import Calf.Data.IsBoundedG costMonoid -open import Calf.Data.IsBounded costMonoid +open import Calf.Data.IsBoundedG costMonoid +open import Calf.Data.IsBounded costMonoid open import Data.Product open import Relation.Binary.PropositionalEquality @@ -25,23 +25,23 @@ _∥_ : {A₁ A₂ : tp⁺} → cmp (F A₁) → cmp (F A₂) → cmp (F (A₁ ×⁺ A₂)) ∥/join : ∀ {A₁ A₂} {v₁ v₂ c₁ c₂} → - step (F A₁) c₁ (ret v₁) ∥ step (F A₂) c₂ (ret v₂) ≡ step (F (A₁ ×⁺ A₂)) (c₁ ⊗ c₂) (ret (v₁ , v₂)) + step (F A₁) c₁ (ret v₁) ∥ step (F A₂) c₂ (ret v₂) ≡ step (F (A₁ ×⁺ A₂)) (c₁ ⊗ c₂) (ret (v₁ , v₂)) ∥/join/𝟘 : ∀ {A₁ A₂} {v₁ : val A₁} {v₂ : val A₂} → ret {A₁} v₁ ∥ ret {A₂} v₂ ≡ ret (v₁ , v₂) ∥/join/𝟘 {A₁} {A₂} {v₁} {v₂} = - let open ≡-Reasoning in - begin + let open ≡-Reasoning in + begin ret v₁ ∥ ret v₂ - ≡⟨⟩ - step (F A₁) 𝟘 (ret v₁) ∥ step (F A₂) 𝟘 (ret v₂) - ≡⟨ ∥/join {A₁} {A₂} {v₁} {v₂} {𝟘} {𝟘} ⟩ - step (F (Σ⁺ A₁ (λ _ → A₂))) (𝟘 ⊗ 𝟘) (ret (v₁ , v₂)) - ≡⟨ cong (λ c → step (F (Σ⁺ A₁ (λ _ → A₂))) c (ret (v₁ , v₂))) (⊗-identityˡ 𝟘) ⟩ - step (F (Σ⁺ A₁ (λ _ → A₂))) 𝟘 (ret (v₁ , v₂)) - ≡⟨⟩ + ≡⟨⟩ + step (F A₁) 𝟘 (ret v₁) ∥ step (F A₂) 𝟘 (ret v₂) + ≡⟨ ∥/join {A₁} {A₂} {v₁} {v₂} {𝟘} {𝟘} ⟩ + step (F (Σ⁺ A₁ (λ _ → A₂))) (𝟘 ⊗ 𝟘) (ret (v₁ , v₂)) + ≡⟨ cong (λ c → step (F (Σ⁺ A₁ (λ _ → A₂))) c (ret (v₁ , v₂))) (⊗-identityˡ 𝟘) ⟩ + step (F (Σ⁺ A₁ (λ _ → A₂))) 𝟘 (ret (v₁ , v₂)) + ≡⟨⟩ ret (v₁ , v₂) - ∎ + ∎ {-# REWRITE ∥/join ∥/join/𝟘 #-} ∥-mono-≤⁻ : {A₁ A₂ : tp⁺} {e₁ e₁' : cmp (F A₁)} {e₂ e₂' : cmp (F A₂)} @@ -56,21 +56,21 @@ IsBoundedG A₂ e₂ b₂ → IsBoundedG (Σ⁺ A₁ λ _ → A₂) (e₁ ∥ e₂) (bind cost (b₁ ∥ b₂) λ _ → ret triv) boundg/par {A₁} {A₂} {e₁} {e₂} {b₁} {b₂} ib₁ ib₂ = - let open ≤⁻-Reasoning cost in - begin + let open ≤⁻-Reasoning cost in + begin bind cost (e₁ ∥ e₂) (λ _ → ret triv) - ≤⟨ {! !} ⟩ + ≲⟨ {! !} ⟩ bind cost ((bind cost e₁ λ _ → ret triv) ∥ (bind cost e₂ λ _ → ret triv)) (λ _ → ret triv) - ≤⟨ ≤⁻-mono (λ e → bind cost (e ∥ (bind cost e₂ λ _ → ret triv)) (λ _ → ret triv)) ib₁ ⟩ + ≲⟨ ≤⁻-mono (λ e → bind cost (e ∥ (bind cost e₂ λ _ → ret triv)) (λ _ → ret triv)) ib₁ ⟩ bind cost (b₁ ∥ (bind cost e₂ λ _ → ret triv)) (λ _ → ret triv) - ≤⟨ ≤⁻-mono (λ e → bind cost (b₁ ∥ e) (λ _ → ret triv)) ib₂ ⟩ + ≲⟨ ≤⁻-mono (λ e → bind cost (b₁ ∥ e) (λ _ → ret triv)) ib₂ ⟩ bind cost (b₁ ∥ b₂) (λ _ → ret triv) - ∎ + ∎ -bound/par : {A₁ A₂ : tp⁺} {e₁ : cmp (F A₁)} {e₂ : cmp (F A₂)} {c₁ c₂ : ℂ} → +bound/par : {A₁ A₂ : tp⁺} {e₁ : cmp (F A₁)} {e₂ : cmp (F A₂)} {c₁ c₂ : ℂ} → IsBounded A₁ e₁ c₁ → IsBounded A₂ e₂ c₂ → - IsBounded (Σ⁺ A₁ λ _ → A₂) (e₁ ∥ e₂) (c₁ ⊗ c₂) + IsBounded (Σ⁺ A₁ λ _ → A₂) (e₁ ∥ e₂) (c₁ ⊗ c₂) bound/par {A₁} {A₂} {e₁} {e₂} {c₁} {c₂} ib₁ ib₂ = boundg/par {A₁} {A₂} {e₁} {e₂} ib₁ ib₂ \ No newline at end of file diff --git a/Calf.Phase.Closed.html b/Calf.Phase.Closed.html index c767d2a8..aebc5071 100644 --- a/Calf.Phase.Closed.html +++ b/Calf.Phase.Closed.html @@ -7,7 +7,7 @@ open import Calf.Prelude open import Calf.CBPV -open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; subst) +open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; subst) open import Calf.Phase.Core @@ -28,18 +28,18 @@ ●/ind : (a : val (● A)) (𝕁 : val (● A) → □) (x0 : (a : val A) → 𝕁 (η a)) → (x1 : (u : ext) → 𝕁 (∗ u)) → - ((a : val A) → (u : ext) → subst (λ a → 𝕁 a) (η≡∗ a u) (x0 a) ≡ x1 u) → + ((a : val A) → (u : ext) → subst (λ a → 𝕁 a) (η≡∗ a u) (x0 a) ≡ x1 u) → 𝕁 a ●/ind/β₁ : (a : val A) (𝕁 : val (● A) → □) (x0 : (a : val A) → 𝕁 (η a)) → (x1 : (u : ext) → 𝕁 (∗ u)) → - (h : (a : val A) → (u : ext) → subst (λ a → 𝕁 a) (η≡∗ a u) (x0 a) ≡ x1 u) → + (h : (a : val A) → (u : ext) → subst (λ a → 𝕁 a) (η≡∗ a u) (x0 a) ≡ x1 u) → ●/ind (η a) 𝕁 x0 x1 h ≡ x0 a {-# REWRITE ●/ind/β₁ #-} ●/ind/β₂ : (u : ext) (𝕁 : val (● A) → □) (x0 : (a : val A) → 𝕁 (η a)) → (x1 : (u : ext) → 𝕁 (∗ u)) → - (h : (a : val A) → (u : ext) → subst (λ a → 𝕁 a) (η≡∗ a u) (x0 a) ≡ x1 u) → + (h : (a : val A) → (u : ext) → subst (λ a → 𝕁 a) (η≡∗ a u) (x0 a) ≡ x1 u) → ●/ind (∗ u) 𝕁 x0 x1 h ≡ x1 u {-# REWRITE ●/ind/β₂ #-} \ No newline at end of file diff --git a/Calf.Phase.Noninterference.html b/Calf.Phase.Noninterference.html index a29a4eec..c1da48e3 100644 --- a/Calf.Phase.Noninterference.html +++ b/Calf.Phase.Noninterference.html @@ -15,7 +15,7 @@ open import Calf.Data.Equality open import Data.Product -open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; subst; cong; module ≡-Reasoning) +open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; subst; cong; module ≡-Reasoning) unique : ∀ {A} → (a : val (● A)) → (u : ext) → a ≡ ∗ u @@ -24,13 +24,13 @@ (λ a → val (a ≡⁺[ ● A ] ∗ u)) (λ a → η≡∗ a u) (λ u → refl) - (λ a u → η≡∗/uni (subst (λ a₂ → a₂ ≡ ∗ u) (η≡∗ a u) (η≡∗ a u)) refl) + (λ a u → η≡∗/uni (subst (λ a₂ → a₂ ≡ ∗ u) (η≡∗ a u) (η≡∗ a u)) refl) constant : ∀ {A B} (f : val (● A) → val (◯⁺ B)) → Σ (val (◯⁺ B)) λ b → f ≡ λ _ → b constant f = (λ u → f (∗ u) u) , funext (λ a → funext/Ω (λ u → - cong (λ a → f a u) (unique a u))) + cong (λ a → f a u) (unique a u))) optimization : ∀ {C B : tp⁺} {A : val C → tp⁺} (f : val (Σ⁺ C λ c → ● (A c)) → val (◯⁺ B)) → @@ -45,18 +45,18 @@ let g : val (● (A c)) → val (◯⁺ B) g a = f (c , a) in let (b , h) = constant {A c} {B} g in - Eq.cong-app h a + Eq.cong-app h a -module _ (costMonoid : CostMonoid) where +module _ (costMonoid : CostMonoid) where open import Calf.Step costMonoid oblivious : ∀ {A B} (f : cmp (F A) → val (◯⁺ B)) → ∀ c e → f (step (F A) c e) ≡ f e oblivious {A} {B} f c e = funext/Ω λ u → - begin + begin f (step (F A) c e) u - ≡⟨ cong (λ e → f e u) (step/ext (F A) e c u) ⟩ + ≡⟨ cong (λ e → f e u) (step/ext (F A) e c u) ⟩ f e u - ∎ - where open ≡-Reasoning + ∎ + where open ≡-Reasoning \ No newline at end of file diff --git a/Calf.Phase.Open.html b/Calf.Phase.Open.html index 42cd0e30..5b0edeab 100644 --- a/Calf.Phase.Open.html +++ b/Calf.Phase.Open.html @@ -34,35 +34,35 @@ module _ where open import Algebra.Cost - ◯-CostMonoid : CostMonoid → CostMonoid + ◯-CostMonoid : CostMonoid → CostMonoid ◯-CostMonoid cm = record - { ℂ = ◯ ℂ - ; _+_ = λ c₁ c₂ u → c₁ u + c₂ u - ; zero = λ u → zero - ; _≤_ = λ c₁ c₂ → (u : ext) → c₁ u ≤ c₂ u - ; isCostMonoid = + { ℂ = ◯ ℂ + ; _+_ = λ c₁ c₂ u → c₁ u + c₂ u + ; zero = λ u → zero + ; _≤_ = λ c₁ c₂ → (u : ext) → c₁ u ≤ c₂ u + ; isCostMonoid = record { isMonoid = record - { isSemigroup = + { isSemigroup = record - { isMagma = + { isMagma = record - { isEquivalence = Eq.isEquivalence - ; ∙-cong = Eq.cong₂ _ + { isEquivalence = Eq.isEquivalence + ; ∙-cong = Eq.cong₂ _ } - ; assoc = λ c₁ c₂ c₃ → funext/Ω λ u → +-assoc (c₁ u) (c₂ u) (c₃ u) + ; assoc = λ c₁ c₂ c₃ → funext/Ω λ u → +-assoc (c₁ u) (c₂ u) (c₃ u) } - ; identity = + ; identity = (λ c → funext/Ω λ u → +-identityˡ (c u)) , (λ c → funext/Ω λ u → +-identityʳ (c u)) } ; isPreorder = record - { isEquivalence = Eq.isEquivalence - ; reflexive = λ h u → ≤-reflexive (Eq.cong (λ x → x u) h) - ; trans = λ h₁ h₂ u → ≤-trans (h₁ u) (h₂ u) + { isEquivalence = Eq.isEquivalence + ; reflexive = λ h u → ≤-reflexive (Eq.cong (λ x → x u) h) + ; trans = λ h₁ h₂ u → ≤-trans (h₁ u) (h₂ u) } ; isMonotone = record @@ -71,6 +71,6 @@ } } where - open CostMonoid cm + open CostMonoid cm open import Data.Product \ No newline at end of file diff --git a/Calf.Step.html b/Calf.Step.html index 38d08062..bdb9d867 100644 --- a/Calf.Step.html +++ b/Calf.Step.html @@ -5,36 +5,36 @@ open import Algebra.Cost -module Calf.Step (costMonoid : CostMonoid) where +module Calf.Step (costMonoid : CostMonoid) where -open CostMonoid costMonoid +open CostMonoid costMonoid open import Calf.Prelude open import Calf.CBPV open import Calf.Directed open import Calf.Phase.Core open import Calf.Phase.Open -open import Relation.Binary.Core using (_⇒_) +open import Relation.Binary.Core using (_⇒_) open import Relation.Binary.PropositionalEquality variable - c c' c₁ c₂ : ℂ + c c' c₁ c₂ : ℂ ℂ⁺ : tp⁺ -ℂ⁺ = meta⁺ ℂ +ℂ⁺ = meta⁺ ℂ postulate - step : (X : tp⁻) → ℂ → cmp X → cmp X + step : (X : tp⁻) → ℂ → cmp X → cmp X step/0 : {e : cmp X} → - step X zero e ≡ e + step X zero e ≡ e step/+ : {e : cmp X} → - step X c₁ (step X c₂ e) ≡ step X (c₁ + c₂) e + step X c₁ (step X c₂ e) ≡ step X (c₁ + c₂) e {-# REWRITE step/0 step/+ #-} - step/ext : (X : tp⁻) (e : cmp X) (c : ℂ) (u : ext) → step X c e ≡ e + step/ext : (X : tp⁻) (e : cmp X) (c : ℂ) (u : ext) → step X c e ≡ e -- sadly the above cannot be made an Agda rewrite rule @@ -48,7 +48,7 @@ {-# REWRITE Π/step #-} prod⁻/step : {e : cmp (prod⁻ X Y)} → - step (prod⁻ X Y) c e ≡ (step X c (proj₁ e) , step Y c (proj₂ e)) + step (prod⁻ X Y) c e ≡ (step X c (proj₁ e) , step Y c (proj₂ e)) {-# REWRITE prod⁻/step #-} unit⁻/step : {e : cmp unit⁻} → @@ -56,7 +56,7 @@ {-# REWRITE unit⁻/step #-} Σ⁻/step : {X : val A → tp⁻} {e : cmp (Σ⁻ A X)} → - step (Σ⁻ A X) c e ≡ (proj₁ e , step (X (proj₁ e)) c (proj₂ e)) + step (Σ⁻ A X) c e ≡ (proj₁ e , step (X (proj₁ e)) c (proj₂ e)) {-# REWRITE Σ⁻/step #-} open⁻/step : {X : ext → tp⁻} {e : cmp (open⁻ X)} → @@ -65,25 +65,25 @@ postulate - ≤⇒≤⁺ : _≤_ ⇒ _≤⁺_ {ℂ⁺} + ≤⇒≤⁺ : _≤_ ⇒ _≤⁺_ {ℂ⁺} step-monoˡ-≤⁻ : (e : cmp X) → - c ≤ c' → step X c e ≤⁻[ X ] step X c' e + c ≤ c' → step X c e ≤⁻[ X ] step X c' e step-monoˡ-≤⁻ {X} e c≤c' = ≤⁺-mono (λ c → step X c e) (≤⇒≤⁺ c≤c') -step-monoʳ-≤⁻ : (c : ℂ) {e e' : cmp X} → +step-monoʳ-≤⁻ : (c : ℂ) {e e' : cmp X} → _≤⁻_ {X} e e' → _≤⁻_ {X} (step X c e) (step X c e') step-monoʳ-≤⁻ {X} c = ≤⁻-mono (step X c) step-mono-≤⁻ : {e e' : cmp X} → - c ≤ c' → e ≤⁻[ X ] e' → step X c e ≤⁻[ X ] step X c' e' + c ≤ c' → e ≤⁻[ X ] e' → step X c e ≤⁻[ X ] step X c' e' step-mono-≤⁻ {X} {c} {c'} {e} {e'} c≤c' e≤e' = - let open ≤⁻-Reasoning X in - begin + let open ≤⁻-Reasoning X in + begin step X c e - ≤⟨ step-monoˡ-≤⁻ e c≤c' ⟩ + ≲⟨ step-monoˡ-≤⁻ e c≤c' ⟩ step X c' e - ≤⟨ step-monoʳ-≤⁻ c' e≤e' ⟩ + ≲⟨ step-monoʳ-≤⁻ c' e≤e' ⟩ step X c' e' - ∎ + ∎ \ No newline at end of file diff --git a/Calf.html b/Calf.html index 6c8de75d..9d56ed62 100644 --- a/Calf.html +++ b/Calf.html @@ -3,9 +3,9 @@ open import Algebra.Cost -module Calf (costMonoid : CostMonoid) where +module Calf (costMonoid : CostMonoid) where -open CostMonoid costMonoid +open CostMonoid costMonoid open import Calf.Prelude public open import Calf.CBPV public diff --git a/Data.Bool.Base.html b/Data.Bool.Base.html index d23f48cb..add725a8 100644 --- a/Data.Bool.Base.html +++ b/Data.Bool.Base.html @@ -58,18 +58,20 @@ false xor b = b ------------------------------------------------------------------------ --- Other operations +-- Conversion to Set -infix 0 if_then_else_ +-- A function mapping true to an inhabited type and false to an empty +-- type. +T : Bool → Set +T true = ⊤ +T false = ⊥ -if_then_else_ : Bool → A → A → A -if true then t else f = t -if false then t else f = f +------------------------------------------------------------------------ +-- Other operations --- A function mapping true to an inhabited type and false to an empty --- type. +infix 0 if_then_else_ -T : Bool → Set -T true = ⊤ -T false = ⊥ +if_then_else_ : Bool → A → A → A +if true then t else f = t +if false then t else f = f \ No newline at end of file diff --git a/Data.Bool.Properties.html b/Data.Bool.Properties.html index a6785d43..e124e349 100644 --- a/Data.Bool.Properties.html +++ b/Data.Bool.Properties.html @@ -14,691 +14,777 @@ import Algebra.Lattice.Properties.BooleanAlgebra as BooleanAlgebraProperties open import Data.Bool.Base open import Data.Empty -open import Data.Product -open import Data.Sum.Base -open import Function.Base -open import Function.Equality using (_⟨$⟩_) -open import Function.Equivalence - using (_⇔_; equivalence; module Equivalence) -open import Induction.WellFounded using (WellFounded; Acc; acc) -open import Level using (Level; 0ℓ) -open import Relation.Binary hiding (_⇔_) -open import Relation.Binary.PropositionalEquality hiding ([_]) -open import Relation.Nullary using (ofʸ; ofⁿ; does; proof; yes; no) -open import Relation.Nullary.Decidable using (True) -import Relation.Unary as U - -open import Algebra.Definitions {A = Bool} _≡_ -open import Algebra.Structures {A = Bool} _≡_ -open import Algebra.Lattice.Structures {A = Bool} _≡_ - -open ≡-Reasoning - -private - variable - a b : Level - A : Set a - B : Set b - ------------------------------------------------------------------------- --- Properties of _≡_ - -infix 4 _≟_ - -_≟_ : Decidable {A = Bool} _≡_ -true ≟ true = yes refl -false ≟ false = yes refl -true ≟ false = no λ() -false ≟ true = no λ() - -≡-setoid : Setoid 0ℓ 0ℓ -≡-setoid = setoid Bool - -≡-decSetoid : DecSetoid 0ℓ 0ℓ -≡-decSetoid = decSetoid _≟_ - ------------------------------------------------------------------------- --- Properties of _≤_ - --- Relational properties - -≤-reflexive : _≡_ ⇒ _≤_ -≤-reflexive refl = b≤b - -≤-refl : Reflexive _≤_ -≤-refl = ≤-reflexive refl - -≤-trans : Transitive _≤_ -≤-trans b≤b p = p -≤-trans f≤t b≤b = f≤t - -≤-antisym : Antisymmetric _≡_ _≤_ -≤-antisym b≤b _ = refl - -≤-minimum : Minimum _≤_ false -≤-minimum false = b≤b -≤-minimum true = f≤t - -≤-maximum : Maximum _≤_ true -≤-maximum false = f≤t -≤-maximum true = b≤b - -≤-total : Total _≤_ -≤-total false b = inj₁ (≤-minimum b) -≤-total true b = inj₂ (≤-maximum b) - -infix 4 _≤?_ +open import Data.Product.Base using (_×_; _,_; proj₁; proj₂) +open import Data.Sum.Base using (_⊎_; inj₁; inj₂; [_,_]) +open import Function.Base using (_⟨_⟩_; const; id) +open import Function.Bundles hiding (LeftInverse; RightInverse; Inverse) +open import Induction.WellFounded using (WellFounded; Acc; acc) +open import Level using (Level; 0ℓ) +open import Relation.Binary.Core using (_⇒_) +open import Relation.Binary.Structures + using (IsPreorder; IsPartialOrder; IsTotalOrder; IsDecTotalOrder; IsStrictPartialOrder; IsStrictTotalOrder) +open import Relation.Binary.Bundles + using (Setoid; DecSetoid; Poset; Preorder; TotalOrder; DecTotalOrder; StrictPartialOrder; StrictTotalOrder) +open import Relation.Binary.Definitions + using (Decidable; Reflexive; Transitive; Antisymmetric; Minimum; Maximum; Total; Irrelevant; Irreflexive; Asymmetric; Trans; Trichotomous; tri≈; tri<; tri>; _Respects₂_) +open import Relation.Binary.PropositionalEquality.Core +open import Relation.Binary.PropositionalEquality.Properties +open import Relation.Nullary.Decidable.Core using (True; yes; no; fromWitness) +import Relation.Unary as U + +open import Algebra.Definitions {A = Bool} _≡_ +open import Algebra.Structures {A = Bool} _≡_ +open import Algebra.Lattice.Structures {A = Bool} _≡_ + +open ≡-Reasoning + +private + variable + a b : Level + A : Set a + B : Set b + +------------------------------------------------------------------------ +-- Properties of _≡_ + +infix 4 _≟_ + +_≟_ : Decidable {A = Bool} _≡_ +true ≟ true = yes refl +false ≟ false = yes refl +true ≟ false = no λ() +false ≟ true = no λ() + +≡-setoid : Setoid 0ℓ 0ℓ +≡-setoid = setoid Bool + +≡-decSetoid : DecSetoid 0ℓ 0ℓ +≡-decSetoid = decSetoid _≟_ + +------------------------------------------------------------------------ +-- Properties of _≤_ + +-- Relational properties + +≤-reflexive : _≡_ ⇒ _≤_ +≤-reflexive refl = b≤b + +≤-refl : Reflexive _≤_ +≤-refl = ≤-reflexive refl + +≤-trans : Transitive _≤_ +≤-trans b≤b p = p +≤-trans f≤t b≤b = f≤t + +≤-antisym : Antisymmetric _≡_ _≤_ +≤-antisym b≤b _ = refl + +≤-minimum : Minimum _≤_ false +≤-minimum false = b≤b +≤-minimum true = f≤t + +≤-maximum : Maximum _≤_ true +≤-maximum false = f≤t +≤-maximum true = b≤b + +≤-total : Total _≤_ +≤-total false b = inj₁ (≤-minimum b) +≤-total true b = inj₂ (≤-maximum b) + +infix 4 _≤?_ + +_≤?_ : Decidable _≤_ +false ≤? b = yes (≤-minimum b) +true ≤? false = no λ () +true ≤? true = yes b≤b + +≤-irrelevant : Irrelevant _≤_ +≤-irrelevant {_} f≤t f≤t = refl +≤-irrelevant {false} b≤b b≤b = refl +≤-irrelevant {true} b≤b b≤b = refl + +-- 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 + ; _≟_ = _≟_ + ; _≤?_ = _≤?_ + } -_≤?_ : Decidable _≤_ -false ≤? b = yes (≤-minimum b) -true ≤? false = no λ () -true ≤? true = yes b≤b - -≤-irrelevant : Irrelevant _≤_ -≤-irrelevant {_} f≤t f≤t = refl -≤-irrelevant {false} b≤b b≤b = refl -≤-irrelevant {true} b≤b b≤b = refl - --- 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 --- Bundles +≤-poset : Poset 0ℓ 0ℓ 0ℓ +≤-poset = record + { isPartialOrder = ≤-isPartialOrder + } -≤-poset : Poset 0ℓ 0ℓ 0ℓ -≤-poset = record - { isPartialOrder = ≤-isPartialOrder - } +≤-preorder : Preorder 0ℓ 0ℓ 0ℓ +≤-preorder = record + { isPreorder = ≤-isPreorder + } -≤-preorder : Preorder 0ℓ 0ℓ 0ℓ -≤-preorder = record - { isPreorder = ≤-isPreorder - } +≤-totalOrder : TotalOrder 0ℓ 0ℓ 0ℓ +≤-totalOrder = record + { isTotalOrder = ≤-isTotalOrder + } -≤-totalOrder : TotalOrder 0ℓ 0ℓ 0ℓ -≤-totalOrder = record - { isTotalOrder = ≤-isTotalOrder - } +≤-decTotalOrder : DecTotalOrder 0ℓ 0ℓ 0ℓ +≤-decTotalOrder = record + { isDecTotalOrder = ≤-isDecTotalOrder + } -≤-decTotalOrder : DecTotalOrder 0ℓ 0ℓ 0ℓ -≤-decTotalOrder = record - { isDecTotalOrder = ≤-isDecTotalOrder - } +------------------------------------------------------------------------ +-- Properties of _<_ ------------------------------------------------------------------------- --- Properties of _<_ +-- Relational properties --- Relational properties +<-irrefl : Irreflexive _≡_ _<_ +<-irrefl refl () -<-irrefl : Irreflexive _≡_ _<_ -<-irrefl refl () +<-asym : Asymmetric _<_ +<-asym f<t () -<-asym : Asymmetric _<_ -<-asym f<t () +<-trans : Transitive _<_ +<-trans f<t () -<-trans : Transitive _<_ -<-trans f<t () +<-transʳ : Trans _≤_ _<_ _<_ +<-transʳ b≤b f<t = f<t -<-transʳ : Trans _≤_ _<_ _<_ -<-transʳ b≤b f<t = f<t +<-transˡ : Trans _<_ _≤_ _<_ +<-transˡ f<t b≤b = f<t -<-transˡ : Trans _<_ _≤_ _<_ -<-transˡ f<t b≤b = f<t - -<-cmp : Trichotomous _≡_ _<_ -<-cmp false false = tri≈ (λ()) refl (λ()) -<-cmp false true = tri< f<t (λ()) (λ()) -<-cmp true false = tri> (λ()) (λ()) f<t -<-cmp true true = tri≈ (λ()) refl (λ()) +<-cmp : Trichotomous _≡_ _<_ +<-cmp false false = tri≈ (λ()) refl (λ()) +<-cmp false true = tri< f<t (λ()) (λ()) +<-cmp true false = tri> (λ()) (λ()) f<t +<-cmp true true = tri≈ (λ()) refl (λ()) -infix 4 _<?_ +infix 4 _<?_ -_<?_ : Decidable _<_ -false <? false = no (λ()) -false <? true = yes f<t -true <? _ = no (λ()) +_<?_ : Decidable _<_ +false <? false = no (λ()) +false <? true = yes f<t +true <? _ = no (λ()) -<-resp₂-≡ : _<_ Respects₂ _≡_ -<-resp₂-≡ = subst (_ <_) , subst (_< _) +<-resp₂-≡ : _<_ Respects₂ _≡_ +<-resp₂-≡ = subst (_ <_) , subst (_< _) -<-irrelevant : Irrelevant _<_ -<-irrelevant f<t f<t = refl - -<-wellFounded : WellFounded _<_ -<-wellFounded _ = acc <-acc - where - <-acc : ∀ {x} y → y < x → Acc _<_ y - <-acc false f<t = acc (λ _ → λ()) +<-irrelevant : Irrelevant _<_ +<-irrelevant f<t f<t = refl --- Structures - -<-isStrictPartialOrder : IsStrictPartialOrder _≡_ _<_ -<-isStrictPartialOrder = record - { isEquivalence = isEquivalence - ; irrefl = <-irrefl - ; trans = <-trans - ; <-resp-≈ = <-resp₂-≡ - } - -<-isStrictTotalOrder : IsStrictTotalOrder _≡_ _<_ -<-isStrictTotalOrder = record - { isEquivalence = isEquivalence - ; trans = <-trans - ; compare = <-cmp - } - --- Bundles - -<-strictPartialOrder : StrictPartialOrder 0ℓ 0ℓ 0ℓ -<-strictPartialOrder = record - { isStrictPartialOrder = <-isStrictPartialOrder - } - -<-strictTotalOrder : StrictTotalOrder 0ℓ 0ℓ 0ℓ -<-strictTotalOrder = record - { isStrictTotalOrder = <-isStrictTotalOrder - } - ------------------------------------------------------------------------- --- Properties of _∨_ - -∨-assoc : Associative _∨_ -∨-assoc true y z = refl -∨-assoc false y z = refl - -∨-comm : Commutative _∨_ -∨-comm true true = refl -∨-comm true false = refl -∨-comm false true = refl -∨-comm false false = refl - -∨-identityˡ : LeftIdentity false _∨_ -∨-identityˡ _ = refl - -∨-identityʳ : RightIdentity false _∨_ -∨-identityʳ false = refl -∨-identityʳ true = refl - -∨-identity : Identity false _∨_ -∨-identity = ∨-identityˡ , ∨-identityʳ - -∨-zeroˡ : LeftZero true _∨_ -∨-zeroˡ _ = refl - -∨-zeroʳ : RightZero true _∨_ -∨-zeroʳ false = refl -∨-zeroʳ true = refl - -∨-zero : Zero true _∨_ -∨-zero = ∨-zeroˡ , ∨-zeroʳ - -∨-inverseˡ : LeftInverse true not _∨_ -∨-inverseˡ false = refl -∨-inverseˡ true = refl - -∨-inverseʳ : RightInverse true not _∨_ -∨-inverseʳ x = ∨-comm x (not x) ⟨ trans ⟩ ∨-inverseˡ x - -∨-inverse : Inverse true not _∨_ -∨-inverse = ∨-inverseˡ , ∨-inverseʳ - -∨-idem : Idempotent _∨_ -∨-idem false = refl -∨-idem true = refl - -∨-sel : Selective _∨_ -∨-sel false y = inj₂ refl -∨-sel true y = inj₁ refl - -∨-conicalˡ : LeftConical false _∨_ -∨-conicalˡ false false _ = refl - -∨-conicalʳ : RightConical false _∨_ -∨-conicalʳ false false _ = refl - -∨-conical : Conical false _∨_ -∨-conical = ∨-conicalˡ , ∨-conicalʳ - -∨-isMagma : IsMagma _∨_ -∨-isMagma = record - { isEquivalence = isEquivalence - ; ∙-cong = cong₂ _∨_ - } - -∨-magma : Magma 0ℓ 0ℓ -∨-magma = record - { isMagma = ∨-isMagma - } - -∨-isSemigroup : IsSemigroup _∨_ -∨-isSemigroup = record - { isMagma = ∨-isMagma - ; assoc = ∨-assoc - } - -∨-semigroup : Semigroup 0ℓ 0ℓ -∨-semigroup = record - { isSemigroup = ∨-isSemigroup - } - -∨-isBand : IsBand _∨_ -∨-isBand = record - { isSemigroup = ∨-isSemigroup - ; idem = ∨-idem - } - -∨-band : Band 0ℓ 0ℓ -∨-band = record - { isBand = ∨-isBand - } - -∨-isSemilattice : IsSemilattice _∨_ -∨-isSemilattice = record - { isBand = ∨-isBand - ; comm = ∨-comm - } - -∨-semilattice : Semilattice 0ℓ 0ℓ -∨-semilattice = record - { isSemilattice = ∨-isSemilattice - } - -∨-isMonoid : IsMonoid _∨_ false -∨-isMonoid = record - { isSemigroup = ∨-isSemigroup - ; identity = ∨-identity - } - -∨-isCommutativeMonoid : IsCommutativeMonoid _∨_ false -∨-isCommutativeMonoid = record - { isMonoid = ∨-isMonoid - ; comm = ∨-comm - } - -∨-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ -∨-commutativeMonoid = record - { isCommutativeMonoid = ∨-isCommutativeMonoid - } - -∨-isIdempotentCommutativeMonoid : - IsIdempotentCommutativeMonoid _∨_ false -∨-isIdempotentCommutativeMonoid = record - { isCommutativeMonoid = ∨-isCommutativeMonoid - ; idem = ∨-idem - } - -∨-idempotentCommutativeMonoid : IdempotentCommutativeMonoid 0ℓ 0ℓ -∨-idempotentCommutativeMonoid = record - { isIdempotentCommutativeMonoid = ∨-isIdempotentCommutativeMonoid - } - ------------------------------------------------------------------------- --- Properties of _∧_ - -∧-assoc : Associative _∧_ -∧-assoc true y z = refl -∧-assoc false y z = refl - -∧-comm : Commutative _∧_ -∧-comm true true = refl -∧-comm true false = refl -∧-comm false true = refl -∧-comm false false = refl - -∧-identityˡ : LeftIdentity true _∧_ -∧-identityˡ _ = refl - -∧-identityʳ : RightIdentity true _∧_ -∧-identityʳ false = refl -∧-identityʳ true = refl - -∧-identity : Identity true _∧_ -∧-identity = ∧-identityˡ , ∧-identityʳ - -∧-zeroˡ : LeftZero false _∧_ -∧-zeroˡ _ = refl - -∧-zeroʳ : RightZero false _∧_ -∧-zeroʳ false = refl -∧-zeroʳ true = refl - -∧-zero : Zero false _∧_ -∧-zero = ∧-zeroˡ , ∧-zeroʳ - -∧-inverseˡ : LeftInverse false not _∧_ -∧-inverseˡ false = refl -∧-inverseˡ true = refl - -∧-inverseʳ : RightInverse false not _∧_ -∧-inverseʳ x = ∧-comm x (not x) ⟨ trans ⟩ ∧-inverseˡ x - -∧-inverse : Inverse false not _∧_ -∧-inverse = ∧-inverseˡ , ∧-inverseʳ - -∧-idem : Idempotent _∧_ -∧-idem false = refl -∧-idem true = refl - -∧-sel : Selective _∧_ -∧-sel false y = inj₁ refl -∧-sel true y = inj₂ refl - -∧-conicalˡ : LeftConical true _∧_ -∧-conicalˡ true true _ = refl - -∧-conicalʳ : RightConical true _∧_ -∧-conicalʳ true true _ = refl - -∧-conical : Conical true _∧_ -∧-conical = ∧-conicalˡ , ∧-conicalʳ - -∧-distribˡ-∨ : _∧_ DistributesOverˡ _∨_ -∧-distribˡ-∨ true y z = refl -∧-distribˡ-∨ false y z = refl - -∧-distribʳ-∨ : _∧_ DistributesOverʳ _∨_ -∧-distribʳ-∨ x y z = begin - (y ∨ z) ∧ x ≡⟨ ∧-comm (y ∨ z) x ⟩ - x ∧ (y ∨ z) ≡⟨ ∧-distribˡ-∨ x y z ⟩ - x ∧ y ∨ x ∧ z ≡⟨ cong₂ _∨_ (∧-comm x y) (∧-comm x z) ⟩ - y ∧ x ∨ z ∧ x ∎ - -∧-distrib-∨ : _∧_ DistributesOver _∨_ -∧-distrib-∨ = ∧-distribˡ-∨ , ∧-distribʳ-∨ - -∨-distribˡ-∧ : _∨_ DistributesOverˡ _∧_ -∨-distribˡ-∧ true y z = refl -∨-distribˡ-∧ false y z = refl - -∨-distribʳ-∧ : _∨_ DistributesOverʳ _∧_ -∨-distribʳ-∧ x y z = begin - (y ∧ z) ∨ x ≡⟨ ∨-comm (y ∧ z) x ⟩ - x ∨ (y ∧ z) ≡⟨ ∨-distribˡ-∧ x y z ⟩ - (x ∨ y) ∧ (x ∨ z) ≡⟨ cong₂ _∧_ (∨-comm x y) (∨-comm x z) ⟩ - (y ∨ x) ∧ (z ∨ x) ∎ - -∨-distrib-∧ : _∨_ DistributesOver _∧_ -∨-distrib-∧ = ∨-distribˡ-∧ , ∨-distribʳ-∧ - -∧-abs-∨ : _∧_ Absorbs _∨_ -∧-abs-∨ true y = refl -∧-abs-∨ false y = refl - -∨-abs-∧ : _∨_ Absorbs _∧_ -∨-abs-∧ true y = refl -∨-abs-∧ false y = refl - -∨-∧-absorptive : Absorptive _∨_ _∧_ -∨-∧-absorptive = ∨-abs-∧ , ∧-abs-∨ - -∧-isMagma : IsMagma _∧_ -∧-isMagma = record - { isEquivalence = isEquivalence - ; ∙-cong = cong₂ _∧_ - } - -∧-magma : Magma 0ℓ 0ℓ -∧-magma = record - { isMagma = ∧-isMagma - } - -∧-isSemigroup : IsSemigroup _∧_ -∧-isSemigroup = record - { isMagma = ∧-isMagma - ; assoc = ∧-assoc - } - -∧-semigroup : Semigroup 0ℓ 0ℓ -∧-semigroup = record - { isSemigroup = ∧-isSemigroup - } - -∧-isBand : IsBand _∧_ -∧-isBand = record - { isSemigroup = ∧-isSemigroup - ; idem = ∧-idem - } - -∧-band : Band 0ℓ 0ℓ -∧-band = record - { isBand = ∧-isBand - } - -∧-isSemilattice : IsSemilattice _∧_ -∧-isSemilattice = record - { isBand = ∧-isBand - ; comm = ∧-comm - } - -∧-semilattice : Semilattice 0ℓ 0ℓ -∧-semilattice = record - { isSemilattice = ∧-isSemilattice - } - -∧-isMonoid : IsMonoid _∧_ true -∧-isMonoid = record - { isSemigroup = ∧-isSemigroup - ; identity = ∧-identity - } - -∧-isCommutativeMonoid : IsCommutativeMonoid _∧_ true -∧-isCommutativeMonoid = record - { isMonoid = ∧-isMonoid - ; comm = ∧-comm - } - -∧-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ -∧-commutativeMonoid = record - { isCommutativeMonoid = ∧-isCommutativeMonoid - } - -∧-isIdempotentCommutativeMonoid : - IsIdempotentCommutativeMonoid _∧_ true -∧-isIdempotentCommutativeMonoid = record - { isCommutativeMonoid = ∧-isCommutativeMonoid - ; idem = ∧-idem - } - -∧-idempotentCommutativeMonoid : IdempotentCommutativeMonoid 0ℓ 0ℓ -∧-idempotentCommutativeMonoid = record - { isIdempotentCommutativeMonoid = ∧-isIdempotentCommutativeMonoid - } - -∨-∧-isSemiring : IsSemiring _∨_ _∧_ false true -∨-∧-isSemiring = record - { isSemiringWithoutAnnihilatingZero = record - { +-isCommutativeMonoid = ∨-isCommutativeMonoid - ; *-cong = cong₂ _∧_ - ; *-assoc = ∧-assoc - ; *-identity = ∧-identity - ; distrib = ∧-distrib-∨ - } - ; zero = ∧-zero - } - -∨-∧-isCommutativeSemiring - : IsCommutativeSemiring _∨_ _∧_ false true -∨-∧-isCommutativeSemiring = record - { isSemiring = ∨-∧-isSemiring - ; *-comm = ∧-comm - } - -∨-∧-commutativeSemiring : CommutativeSemiring 0ℓ 0ℓ -∨-∧-commutativeSemiring = record - { _+_ = _∨_ - ; _*_ = _∧_ - ; 0# = false - ; 1# = true - ; isCommutativeSemiring = ∨-∧-isCommutativeSemiring - } - -∧-∨-isSemiring : IsSemiring _∧_ _∨_ true false -∧-∨-isSemiring = record - { isSemiringWithoutAnnihilatingZero = record - { +-isCommutativeMonoid = ∧-isCommutativeMonoid - ; *-cong = cong₂ _∨_ - ; *-assoc = ∨-assoc - ; *-identity = ∨-identity - ; distrib = ∨-distrib-∧ - } - ; zero = ∨-zero - } - -∧-∨-isCommutativeSemiring - : IsCommutativeSemiring _∧_ _∨_ true false -∧-∨-isCommutativeSemiring = record - { isSemiring = ∧-∨-isSemiring - ; *-comm = ∨-comm - } - -∧-∨-commutativeSemiring : CommutativeSemiring 0ℓ 0ℓ -∧-∨-commutativeSemiring = record - { _+_ = _∧_ - ; _*_ = _∨_ - ; 0# = true - ; 1# = false - ; isCommutativeSemiring = ∧-∨-isCommutativeSemiring - } - -∨-∧-isLattice : IsLattice _∨_ _∧_ -∨-∧-isLattice = record - { isEquivalence = isEquivalence - ; ∨-comm = ∨-comm - ; ∨-assoc = ∨-assoc - ; ∨-cong = cong₂ _∨_ - ; ∧-comm = ∧-comm - ; ∧-assoc = ∧-assoc - ; ∧-cong = cong₂ _∧_ - ; absorptive = ∨-∧-absorptive - } - -∨-∧-lattice : Lattice 0ℓ 0ℓ -∨-∧-lattice = record - { isLattice = ∨-∧-isLattice - } - -∨-∧-isDistributiveLattice : IsDistributiveLattice _∨_ _∧_ -∨-∧-isDistributiveLattice = record - { isLattice = ∨-∧-isLattice - ; ∨-distrib-∧ = ∨-distrib-∧ - ; ∧-distrib-∨ = ∧-distrib-∨ - } - -∨-∧-distributiveLattice : DistributiveLattice 0ℓ 0ℓ -∨-∧-distributiveLattice = record - { isDistributiveLattice = ∨-∧-isDistributiveLattice - } - -∨-∧-isBooleanAlgebra : IsBooleanAlgebra _∨_ _∧_ not true false -∨-∧-isBooleanAlgebra = record - { isDistributiveLattice = ∨-∧-isDistributiveLattice - ; ∨-complement = ∨-inverse - ; ∧-complement = ∧-inverse - ; ¬-cong = cong not - } - -∨-∧-booleanAlgebra : BooleanAlgebra 0ℓ 0ℓ -∨-∧-booleanAlgebra = record - { isBooleanAlgebra = ∨-∧-isBooleanAlgebra - } - ------------------------------------------------------------------------- --- Properties of _xor_ - -xor-is-ok : ∀ x y → x xor y ≡ (x ∨ y) ∧ not (x ∧ y) -xor-is-ok true y = refl -xor-is-ok false y = sym (∧-identityʳ _) - -xor-∧-commutativeRing : CommutativeRing 0ℓ 0ℓ -xor-∧-commutativeRing = ⊕-∧-commutativeRing - where - open BooleanAlgebraProperties ∨-∧-booleanAlgebra - open XorRing _xor_ xor-is-ok - ------------------------------------------------------------------------- --- Miscellaneous other properties - -not-involutive : Involutive not -not-involutive true = refl -not-involutive false = refl - -not-injective : ∀ {x y} → not x ≡ not y → x ≡ y -not-injective {false} {false} nx≢ny = refl -not-injective {true} {true} nx≢ny = refl - -not-¬ : ∀ {x y} → x ≡ y → x ≢ not y -not-¬ {true} refl () -not-¬ {false} refl () - -¬-not : ∀ {x y} → x ≢ y → x ≡ not y -¬-not {true} {true} x≢y = ⊥-elim (x≢y refl) -¬-not {true} {false} _ = refl -¬-not {false} {true} _ = refl -¬-not {false} {false} x≢y = ⊥-elim (x≢y refl) - -⇔→≡ : {x y z : Bool} → x ≡ z ⇔ y ≡ z → x ≡ y -⇔→≡ {true } {true } hyp = refl -⇔→≡ {true } {false} {true } hyp = sym (Equivalence.to hyp ⟨$⟩ refl) -⇔→≡ {true } {false} {false} hyp = Equivalence.from hyp ⟨$⟩ refl -⇔→≡ {false} {true } {true } hyp = Equivalence.from hyp ⟨$⟩ refl -⇔→≡ {false} {true } {false} hyp = sym (Equivalence.to hyp ⟨$⟩ refl) -⇔→≡ {false} {false} hyp = refl - -T-≡ : ∀ {x} → T x ⇔ x ≡ true -T-≡ {false} = equivalence (λ ()) (λ ()) -T-≡ {true} = equivalence (const refl) (const _) - -T-not-≡ : ∀ {x} → T (not x) ⇔ x ≡ false -T-not-≡ {false} = equivalence (const refl) (const _) -T-not-≡ {true} = equivalence (λ ()) (λ ()) - -T-∧ : ∀ {x y} → T (x ∧ y) ⇔ (T x × T y) -T-∧ {true} {true} = equivalence (const (_ , _)) (const _) -T-∧ {true} {false} = equivalence (λ ()) proj₂ -T-∧ {false} {_} = equivalence (λ ()) proj₁ - -T-∨ : ∀ {x y} → T (x ∨ y) ⇔ (T x ⊎ T y) -T-∨ {true} {_} = equivalence inj₁ (const _) -T-∨ {false} {true} = equivalence inj₂ (const _) -T-∨ {false} {false} = equivalence inj₁ [ id , id ] - -T-irrelevant : U.Irrelevant T -T-irrelevant {true} _ _ = refl - -T? : U.Decidable T -does (T? b) = b -proof (T? true ) = ofʸ _ -proof (T? false) = ofⁿ λ() - -T?-diag : ∀ b → T b → True (T? b) -T?-diag true _ = _ - -push-function-into-if : ∀ (f : A → B) x {y z} → - f (if x then y else z) ≡ (if x then f y else f z) -push-function-into-if _ true = refl -push-function-into-if _ false = refl +<-wellFounded : WellFounded _<_ +<-wellFounded _ = acc <-acc + where + <-acc : ∀ {x y} → y < x → Acc _<_ y + <-acc f<t = acc λ () + +-- Structures + +<-isStrictPartialOrder : IsStrictPartialOrder _≡_ _<_ +<-isStrictPartialOrder = record + { isEquivalence = isEquivalence + ; irrefl = <-irrefl + ; trans = <-trans + ; <-resp-≈ = <-resp₂-≡ + } + +<-isStrictTotalOrder : IsStrictTotalOrder _≡_ _<_ +<-isStrictTotalOrder = record + { isStrictPartialOrder = <-isStrictPartialOrder + ; compare = <-cmp + } + +-- Bundles + +<-strictPartialOrder : StrictPartialOrder 0ℓ 0ℓ 0ℓ +<-strictPartialOrder = record + { isStrictPartialOrder = <-isStrictPartialOrder + } + +<-strictTotalOrder : StrictTotalOrder 0ℓ 0ℓ 0ℓ +<-strictTotalOrder = record + { isStrictTotalOrder = <-isStrictTotalOrder + } + +------------------------------------------------------------------------ +-- Properties of _∨_ + +∨-assoc : Associative _∨_ +∨-assoc true y z = refl +∨-assoc false y z = refl + +∨-comm : Commutative _∨_ +∨-comm true true = refl +∨-comm true false = refl +∨-comm false true = refl +∨-comm false false = refl + +∨-identityˡ : LeftIdentity false _∨_ +∨-identityˡ _ = refl + +∨-identityʳ : RightIdentity false _∨_ +∨-identityʳ false = refl +∨-identityʳ true = refl + +∨-identity : Identity false _∨_ +∨-identity = ∨-identityˡ , ∨-identityʳ + +∨-zeroˡ : LeftZero true _∨_ +∨-zeroˡ _ = refl + +∨-zeroʳ : RightZero true _∨_ +∨-zeroʳ false = refl +∨-zeroʳ true = refl + +∨-zero : Zero true _∨_ +∨-zero = ∨-zeroˡ , ∨-zeroʳ + +∨-inverseˡ : LeftInverse true not _∨_ +∨-inverseˡ false = refl +∨-inverseˡ true = refl + +∨-inverseʳ : RightInverse true not _∨_ +∨-inverseʳ x = ∨-comm x (not x) ⟨ trans ⟩ ∨-inverseˡ x + +∨-inverse : Inverse true not _∨_ +∨-inverse = ∨-inverseˡ , ∨-inverseʳ + +∨-idem : Idempotent _∨_ +∨-idem false = refl +∨-idem true = refl + +∨-sel : Selective _∨_ +∨-sel false y = inj₂ refl +∨-sel true y = inj₁ refl + +∨-conicalˡ : LeftConical false _∨_ +∨-conicalˡ false false _ = refl + +∨-conicalʳ : RightConical false _∨_ +∨-conicalʳ false false _ = refl + +∨-conical : Conical false _∨_ +∨-conical = ∨-conicalˡ , ∨-conicalʳ + +∨-isMagma : IsMagma _∨_ +∨-isMagma = record + { isEquivalence = isEquivalence + ; ∙-cong = cong₂ _∨_ + } + +∨-magma : Magma 0ℓ 0ℓ +∨-magma = record + { isMagma = ∨-isMagma + } + +∨-isSemigroup : IsSemigroup _∨_ +∨-isSemigroup = record + { isMagma = ∨-isMagma + ; assoc = ∨-assoc + } + +∨-semigroup : Semigroup 0ℓ 0ℓ +∨-semigroup = record + { isSemigroup = ∨-isSemigroup + } + +∨-isBand : IsBand _∨_ +∨-isBand = record + { isSemigroup = ∨-isSemigroup + ; idem = ∨-idem + } + +∨-band : Band 0ℓ 0ℓ +∨-band = record + { isBand = ∨-isBand + } + +∨-isSemilattice : IsSemilattice _∨_ +∨-isSemilattice = record + { isBand = ∨-isBand + ; comm = ∨-comm + } + +∨-semilattice : Semilattice 0ℓ 0ℓ +∨-semilattice = record + { isSemilattice = ∨-isSemilattice + } + +∨-isMonoid : IsMonoid _∨_ false +∨-isMonoid = record + { isSemigroup = ∨-isSemigroup + ; identity = ∨-identity + } + +∨-isCommutativeMonoid : IsCommutativeMonoid _∨_ false +∨-isCommutativeMonoid = record + { isMonoid = ∨-isMonoid + ; comm = ∨-comm + } + +∨-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ +∨-commutativeMonoid = record + { isCommutativeMonoid = ∨-isCommutativeMonoid + } + +∨-isIdempotentCommutativeMonoid : + IsIdempotentCommutativeMonoid _∨_ false +∨-isIdempotentCommutativeMonoid = record + { isCommutativeMonoid = ∨-isCommutativeMonoid + ; idem = ∨-idem + } + +∨-idempotentCommutativeMonoid : IdempotentCommutativeMonoid 0ℓ 0ℓ +∨-idempotentCommutativeMonoid = record + { isIdempotentCommutativeMonoid = ∨-isIdempotentCommutativeMonoid + } + +------------------------------------------------------------------------ +-- Properties of _∧_ + +∧-assoc : Associative _∧_ +∧-assoc true y z = refl +∧-assoc false y z = refl + +∧-comm : Commutative _∧_ +∧-comm true true = refl +∧-comm true false = refl +∧-comm false true = refl +∧-comm false false = refl + +∧-identityˡ : LeftIdentity true _∧_ +∧-identityˡ _ = refl + +∧-identityʳ : RightIdentity true _∧_ +∧-identityʳ false = refl +∧-identityʳ true = refl + +∧-identity : Identity true _∧_ +∧-identity = ∧-identityˡ , ∧-identityʳ + +∧-zeroˡ : LeftZero false _∧_ +∧-zeroˡ _ = refl + +∧-zeroʳ : RightZero false _∧_ +∧-zeroʳ false = refl +∧-zeroʳ true = refl + +∧-zero : Zero false _∧_ +∧-zero = ∧-zeroˡ , ∧-zeroʳ + +∧-inverseˡ : LeftInverse false not _∧_ +∧-inverseˡ false = refl +∧-inverseˡ true = refl + +∧-inverseʳ : RightInverse false not _∧_ +∧-inverseʳ x = ∧-comm x (not x) ⟨ trans ⟩ ∧-inverseˡ x + +∧-inverse : Inverse false not _∧_ +∧-inverse = ∧-inverseˡ , ∧-inverseʳ + +∧-idem : Idempotent _∧_ +∧-idem false = refl +∧-idem true = refl + +∧-sel : Selective _∧_ +∧-sel false y = inj₁ refl +∧-sel true y = inj₂ refl + +∧-conicalˡ : LeftConical true _∧_ +∧-conicalˡ true true _ = refl + +∧-conicalʳ : RightConical true _∧_ +∧-conicalʳ true true _ = refl + +∧-conical : Conical true _∧_ +∧-conical = ∧-conicalˡ , ∧-conicalʳ + +∧-distribˡ-∨ : _∧_ DistributesOverˡ _∨_ +∧-distribˡ-∨ true y z = refl +∧-distribˡ-∨ false y z = refl + +∧-distribʳ-∨ : _∧_ DistributesOverʳ _∨_ +∧-distribʳ-∨ x y z = begin + (y ∨ z) ∧ x ≡⟨ ∧-comm (y ∨ z) x ⟩ + x ∧ (y ∨ z) ≡⟨ ∧-distribˡ-∨ x y z ⟩ + x ∧ y ∨ x ∧ z ≡⟨ cong₂ _∨_ (∧-comm x y) (∧-comm x z) ⟩ + y ∧ x ∨ z ∧ x ∎ + +∧-distrib-∨ : _∧_ DistributesOver _∨_ +∧-distrib-∨ = ∧-distribˡ-∨ , ∧-distribʳ-∨ + +∨-distribˡ-∧ : _∨_ DistributesOverˡ _∧_ +∨-distribˡ-∧ true y z = refl +∨-distribˡ-∧ false y z = refl + +∨-distribʳ-∧ : _∨_ DistributesOverʳ _∧_ +∨-distribʳ-∧ x y z = begin + (y ∧ z) ∨ x ≡⟨ ∨-comm (y ∧ z) x ⟩ + x ∨ (y ∧ z) ≡⟨ ∨-distribˡ-∧ x y z ⟩ + (x ∨ y) ∧ (x ∨ z) ≡⟨ cong₂ _∧_ (∨-comm x y) (∨-comm x z) ⟩ + (y ∨ x) ∧ (z ∨ x) ∎ + +∨-distrib-∧ : _∨_ DistributesOver _∧_ +∨-distrib-∧ = ∨-distribˡ-∧ , ∨-distribʳ-∧ + +∧-abs-∨ : _∧_ Absorbs _∨_ +∧-abs-∨ true y = refl +∧-abs-∨ false y = refl + +∨-abs-∧ : _∨_ Absorbs _∧_ +∨-abs-∧ true y = refl +∨-abs-∧ false y = refl + +∨-∧-absorptive : Absorptive _∨_ _∧_ +∨-∧-absorptive = ∨-abs-∧ , ∧-abs-∨ + +∧-isMagma : IsMagma _∧_ +∧-isMagma = record + { isEquivalence = isEquivalence + ; ∙-cong = cong₂ _∧_ + } + +∧-magma : Magma 0ℓ 0ℓ +∧-magma = record + { isMagma = ∧-isMagma + } + +∧-isSemigroup : IsSemigroup _∧_ +∧-isSemigroup = record + { isMagma = ∧-isMagma + ; assoc = ∧-assoc + } + +∧-semigroup : Semigroup 0ℓ 0ℓ +∧-semigroup = record + { isSemigroup = ∧-isSemigroup + } + +∧-isBand : IsBand _∧_ +∧-isBand = record + { isSemigroup = ∧-isSemigroup + ; idem = ∧-idem + } + +∧-band : Band 0ℓ 0ℓ +∧-band = record + { isBand = ∧-isBand + } + +∧-isSemilattice : IsSemilattice _∧_ +∧-isSemilattice = record + { isBand = ∧-isBand + ; comm = ∧-comm + } + +∧-semilattice : Semilattice 0ℓ 0ℓ +∧-semilattice = record + { isSemilattice = ∧-isSemilattice + } + +∧-isMonoid : IsMonoid _∧_ true +∧-isMonoid = record + { isSemigroup = ∧-isSemigroup + ; identity = ∧-identity + } + +∧-isCommutativeMonoid : IsCommutativeMonoid _∧_ true +∧-isCommutativeMonoid = record + { isMonoid = ∧-isMonoid + ; comm = ∧-comm + } + +∧-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ +∧-commutativeMonoid = record + { isCommutativeMonoid = ∧-isCommutativeMonoid + } + +∧-isIdempotentCommutativeMonoid : + IsIdempotentCommutativeMonoid _∧_ true +∧-isIdempotentCommutativeMonoid = record + { isCommutativeMonoid = ∧-isCommutativeMonoid + ; idem = ∧-idem + } + +∧-idempotentCommutativeMonoid : IdempotentCommutativeMonoid 0ℓ 0ℓ +∧-idempotentCommutativeMonoid = record + { isIdempotentCommutativeMonoid = ∧-isIdempotentCommutativeMonoid + } + +∨-∧-isSemiring : IsSemiring _∨_ _∧_ false true +∨-∧-isSemiring = record + { isSemiringWithoutAnnihilatingZero = record + { +-isCommutativeMonoid = ∨-isCommutativeMonoid + ; *-cong = cong₂ _∧_ + ; *-assoc = ∧-assoc + ; *-identity = ∧-identity + ; distrib = ∧-distrib-∨ + } + ; zero = ∧-zero + } + +∨-∧-isCommutativeSemiring + : IsCommutativeSemiring _∨_ _∧_ false true +∨-∧-isCommutativeSemiring = record + { isSemiring = ∨-∧-isSemiring + ; *-comm = ∧-comm + } + +∨-∧-commutativeSemiring : CommutativeSemiring 0ℓ 0ℓ +∨-∧-commutativeSemiring = record + { _+_ = _∨_ + ; _*_ = _∧_ + ; 0# = false + ; 1# = true + ; isCommutativeSemiring = ∨-∧-isCommutativeSemiring + } + +∧-∨-isSemiring : IsSemiring _∧_ _∨_ true false +∧-∨-isSemiring = record + { isSemiringWithoutAnnihilatingZero = record + { +-isCommutativeMonoid = ∧-isCommutativeMonoid + ; *-cong = cong₂ _∨_ + ; *-assoc = ∨-assoc + ; *-identity = ∨-identity + ; distrib = ∨-distrib-∧ + } + ; zero = ∨-zero + } + +∧-∨-isCommutativeSemiring + : IsCommutativeSemiring _∧_ _∨_ true false +∧-∨-isCommutativeSemiring = record + { isSemiring = ∧-∨-isSemiring + ; *-comm = ∨-comm + } + +∧-∨-commutativeSemiring : CommutativeSemiring 0ℓ 0ℓ +∧-∨-commutativeSemiring = record + { _+_ = _∧_ + ; _*_ = _∨_ + ; 0# = true + ; 1# = false + ; isCommutativeSemiring = ∧-∨-isCommutativeSemiring + } + +∨-∧-isLattice : IsLattice _∨_ _∧_ +∨-∧-isLattice = record + { isEquivalence = isEquivalence + ; ∨-comm = ∨-comm + ; ∨-assoc = ∨-assoc + ; ∨-cong = cong₂ _∨_ + ; ∧-comm = ∧-comm + ; ∧-assoc = ∧-assoc + ; ∧-cong = cong₂ _∧_ + ; absorptive = ∨-∧-absorptive + } + +∨-∧-lattice : Lattice 0ℓ 0ℓ +∨-∧-lattice = record + { isLattice = ∨-∧-isLattice + } + +∨-∧-isDistributiveLattice : IsDistributiveLattice _∨_ _∧_ +∨-∧-isDistributiveLattice = record + { isLattice = ∨-∧-isLattice + ; ∨-distrib-∧ = ∨-distrib-∧ + ; ∧-distrib-∨ = ∧-distrib-∨ + } + +∨-∧-distributiveLattice : DistributiveLattice 0ℓ 0ℓ +∨-∧-distributiveLattice = record + { isDistributiveLattice = ∨-∧-isDistributiveLattice + } + +∨-∧-isBooleanAlgebra : IsBooleanAlgebra _∨_ _∧_ not true false +∨-∧-isBooleanAlgebra = record + { isDistributiveLattice = ∨-∧-isDistributiveLattice + ; ∨-complement = ∨-inverse + ; ∧-complement = ∧-inverse + ; ¬-cong = cong not + } + +∨-∧-booleanAlgebra : BooleanAlgebra 0ℓ 0ℓ +∨-∧-booleanAlgebra = record + { isBooleanAlgebra = ∨-∧-isBooleanAlgebra + } + +------------------------------------------------------------------------ +-- Properties of not + +not-involutive : Involutive not +not-involutive true = refl +not-involutive false = refl + +not-injective : ∀ {x y} → not x ≡ not y → x ≡ y +not-injective {false} {false} nx≢ny = refl +not-injective {true} {true} nx≢ny = refl + +not-¬ : ∀ {x y} → x ≡ y → x ≢ not y +not-¬ {true} refl () +not-¬ {false} refl () + +¬-not : ∀ {x y} → x ≢ y → x ≡ not y +¬-not {true} {true} x≢y = ⊥-elim (x≢y refl) +¬-not {true} {false} _ = refl +¬-not {false} {true} _ = refl +¬-not {false} {false} x≢y = ⊥-elim (x≢y refl) + +------------------------------------------------------------------------ +-- Properties of _xor_ + +xor-is-ok : ∀ x y → x xor y ≡ (x ∨ y) ∧ not (x ∧ y) +xor-is-ok true y = refl +xor-is-ok false y = sym (∧-identityʳ _) + +true-xor : ∀ x → true xor x ≡ not x +true-xor false = refl +true-xor true = refl + +xor-same : ∀ x → x xor x ≡ false +xor-same false = refl +xor-same true = refl + +not-distribˡ-xor : ∀ x y → not (x xor y) ≡ (not x) xor y +not-distribˡ-xor false y = refl +not-distribˡ-xor true y = not-involutive _ + +not-distribʳ-xor : ∀ x y → not (x xor y) ≡ x xor (not y) +not-distribʳ-xor false y = refl +not-distribʳ-xor true y = refl + +xor-assoc : Associative _xor_ +xor-assoc true y z = sym (not-distribˡ-xor y z) +xor-assoc false y z = refl + +xor-comm : Commutative _xor_ +xor-comm false false = refl +xor-comm false true = refl +xor-comm true false = refl +xor-comm true true = refl + +xor-identityˡ : LeftIdentity false _xor_ +xor-identityˡ _ = refl + +xor-identityʳ : RightIdentity false _xor_ +xor-identityʳ false = refl +xor-identityʳ true = refl + +xor-identity : Identity false _xor_ +xor-identity = xor-identityˡ , xor-identityʳ + +xor-inverseˡ : LeftInverse true not _xor_ +xor-inverseˡ false = refl +xor-inverseˡ true = refl + +xor-inverseʳ : RightInverse true not _xor_ +xor-inverseʳ x = xor-comm x (not x) ⟨ trans ⟩ xor-inverseˡ x + +xor-inverse : Inverse true not _xor_ +xor-inverse = xor-inverseˡ , xor-inverseʳ + +∧-distribˡ-xor : _∧_ DistributesOverˡ _xor_ +∧-distribˡ-xor false y z = refl +∧-distribˡ-xor true y z = refl + +∧-distribʳ-xor : _∧_ DistributesOverʳ _xor_ +∧-distribʳ-xor x false z = refl +∧-distribʳ-xor x true false = sym (xor-identityʳ x) +∧-distribʳ-xor x true true = sym (xor-same x) + +∧-distrib-xor : _∧_ DistributesOver _xor_ +∧-distrib-xor = ∧-distribˡ-xor , ∧-distribʳ-xor + +xor-annihilates-not : ∀ x y → (not x) xor (not y) ≡ x xor y +xor-annihilates-not false y = not-involutive _ +xor-annihilates-not true y = refl + +xor-∧-commutativeRing : CommutativeRing 0ℓ 0ℓ +xor-∧-commutativeRing = ⊕-∧-commutativeRing + where + open BooleanAlgebraProperties ∨-∧-booleanAlgebra + open XorRing _xor_ xor-is-ok + +------------------------------------------------------------------------ +-- Properties of if_then_else_ + +if-float : ∀ (f : A → B) b {x y} → + f (if b then x else y) ≡ (if b then f x else f y) +if-float _ true = refl +if-float _ false = refl + +------------------------------------------------------------------------ +-- Properties of T + +open Relation.Nullary.Decidable.Core public using (T?) + +T-≡ : ∀ {x} → T x ⇔ x ≡ true +T-≡ {false} = mk⇔ (λ ()) (λ ()) +T-≡ {true} = mk⇔ (const refl) (const _) + +T-not-≡ : ∀ {x} → T (not x) ⇔ x ≡ false +T-not-≡ {false} = mk⇔ (const refl) (const _) +T-not-≡ {true} = mk⇔ (λ ()) (λ ()) + +T-∧ : ∀ {x y} → T (x ∧ y) ⇔ (T x × T y) +T-∧ {true} {true} = mk⇔ (const (_ , _)) (const _) +T-∧ {true} {false} = mk⇔ (λ ()) proj₂ +T-∧ {false} {_} = mk⇔ (λ ()) proj₁ + +T-∨ : ∀ {x y} → T (x ∨ y) ⇔ (T x ⊎ T y) +T-∨ {true} {_} = mk⇔ inj₁ (const _) +T-∨ {false} {true} = mk⇔ inj₂ (const _) +T-∨ {false} {false} = mk⇔ inj₁ [ id , id ] + +T-irrelevant : U.Irrelevant T +T-irrelevant {true} _ _ = refl + +T?-diag : ∀ b → T b → True (T? b) +T?-diag b = fromWitness + +------------------------------------------------------------------------ +-- Miscellaneous other properties + +⇔→≡ : {x y z : Bool} → x ≡ z ⇔ y ≡ z → x ≡ y +⇔→≡ {true } {true } hyp = refl +⇔→≡ {true } {false} {true } hyp = sym (Equivalence.to hyp refl) +⇔→≡ {true } {false} {false} hyp = Equivalence.from hyp refl +⇔→≡ {false} {true } {true } hyp = Equivalence.from hyp refl +⇔→≡ {false} {true } {false} hyp = sym (Equivalence.to hyp refl) +⇔→≡ {false} {false} hyp = refl + + +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 2.0 + +push-function-into-if = if-float +{-# WARNING_ON_USAGE push-function-into-if +"Warning: push-function-into-if was deprecated in v2.0. +Please use if-float instead." +#-} \ No newline at end of file diff --git a/Data.Bool.html b/Data.Bool.html index 5b391882..1db386df 100644 --- a/Data.Bool.html +++ b/Data.Bool.html @@ -9,19 +9,14 @@ module Data.Bool where -open import Relation.Nullary -open import Relation.Binary -open import Relation.Binary.PropositionalEquality as PropEq - using (_≡_; refl) +------------------------------------------------------------------------ +-- The boolean type and some operations ------------------------------------------------------------------------- --- The boolean type and some operations +open import Data.Bool.Base public -open import Data.Bool.Base public +------------------------------------------------------------------------ +-- Publicly re-export queries ------------------------------------------------------------------------- --- Publicly re-export queries - -open import Data.Bool.Properties public - using (T?; _≟_; _≤?_; _<?_) +open import Data.Bool.Properties public + using (T?; _≟_; _≤?_; _<?_) \ No newline at end of file diff --git a/Data.Char.Base.html b/Data.Char.Base.html index d498961f..4671861e 100644 --- a/Data.Char.Base.html +++ b/Data.Char.Base.html @@ -12,8 +12,8 @@ open import Level using (zero) import Data.Nat.Base as ℕ open import Data.Bool.Base using (Bool) -open import Function.Base using (_on_) -open import Relation.Binary.Core using (Rel) +open import Function.Base using (_on_) +open import Relation.Binary.Core using (Rel) open import Relation.Binary.PropositionalEquality.Core open import Relation.Binary.Construct.Closure.Reflexive @@ -43,21 +43,21 @@ renaming ( primShowChar to show ) infix 4 _≈_ _≉_ -_≈_ : Rel Char zero -_≈_ = _≡_ on toℕ +_≈_ : Rel Char zero +_≈_ = _≡_ on toℕ -_≉_ : Rel Char zero -_≉_ = _≢_ on toℕ +_≉_ : Rel Char zero +_≉_ = _≢_ on toℕ infix 4 _≈ᵇ_ _≈ᵇ_ : (c d : Char) → Bool -c ≈ᵇ d = toℕ c ℕ.≡ᵇ toℕ d +c ≈ᵇ d = toℕ c ℕ.≡ᵇ toℕ d infix 4 _<_ -_<_ : Rel Char zero -_<_ = ℕ._<_ on toℕ +_<_ : Rel Char zero +_<_ = ℕ._<_ on toℕ infix 4 _≤_ -_≤_ : Rel Char zero +_≤_ : Rel Char zero _≤_ = ReflClosure _<_ \ No newline at end of file diff --git a/Data.Char.Properties.html b/Data.Char.Properties.html deleted file mode 100644 index 72f47fe2..00000000 --- a/Data.Char.Properties.html +++ /dev/null @@ -1,301 +0,0 @@ - -Data.Char.Properties
------------------------------------------------------------------------
--- The Agda standard library
---
--- Properties of operations on characters
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-module Data.Char.Properties where
-
-open import Data.Bool.Base using (Bool)
-open import Data.Char.Base
-import Data.Nat.Base as ℕ
-import Data.Nat.Properties as ℕₚ
-open import Data.Product using (_,_)
-
-open import Function.Base
-open import Relation.Nullary using (¬_; yes; no)
-open import Relation.Nullary.Decidable using (map′; isYes)
-open import Relation.Binary
-import Relation.Binary.Construct.On as On
-import Relation.Binary.Construct.Subst.Equality as Subst
-import Relation.Binary.Construct.Closure.Reflexive as Refl
-import Relation.Binary.Construct.Closure.Reflexive.Properties as Reflₚ
-open import Relation.Binary.PropositionalEquality as PropEq
-  using (_≡_; _≢_; refl; cong; sym; trans; subst)
-
-------------------------------------------------------------------------
--- Primitive properties
-
-open import Agda.Builtin.Char.Properties
-  renaming ( primCharToNatInjective to toℕ-injective)
-  public
-
-------------------------------------------------------------------------
--- Properties of _≈_
-
-≈⇒≡ : _≈_ ⇒ _≡_
-≈⇒≡ = toℕ-injective _ _
-
-≉⇒≢ : _≉_ ⇒ _≢_
-≉⇒≢ p refl = p refl
-
-≈-reflexive : _≡_ ⇒ _≈_
-≈-reflexive = cong toℕ
-
-------------------------------------------------------------------------
--- Properties of _≡_
-
-infix 4 _≟_
-_≟_ : Decidable {A = Char} _≡_
-x ≟ y = map′ ≈⇒≡ ≈-reflexive (toℕ x ℕₚ.≟ toℕ y)
-
-setoid : Setoid _ _
-setoid = PropEq.setoid Char
-
-decSetoid : DecSetoid _ _
-decSetoid = PropEq.decSetoid _≟_
-
-isDecEquivalence : IsDecEquivalence _≡_
-isDecEquivalence = PropEq.isDecEquivalence _≟_
-
-------------------------------------------------------------------------
--- Boolean equality test.
---
--- Why is the definition _==_ = primCharEquality not used? One reason
--- is that the present definition can sometimes improve type
--- inference, at least with the version of Agda that is current at the
--- time of writing: see unit-test below.
-
-infix 4 _==_
-_==_ : Char → Char → Bool
-c₁ == c₂ = isYes (c₁ ≟ c₂)
-
-private
-
-  -- The following unit test does not type-check (at the time of
-  -- writing) if _==_ is replaced by primCharEquality.
-
-  data P : (Char → Bool) → Set where
-    MkP : (c : Char) → P (c ==_)
-
-  unit-test : P ('x' ==_)
-  unit-test = MkP _
-
-------------------------------------------------------------------------
--- Properties of _<_
-
-infix 4 _<?_
-_<?_ : Decidable _<_
-_<?_ = On.decidable toℕ ℕ._<_ ℕₚ._<?_
-
-<-cmp : Trichotomous _≡_ _<_
-<-cmp c d with ℕₚ.<-cmp (toℕ c) (toℕ d)
-... | tri< lt ¬eq ¬gt = tri< lt (≉⇒≢ ¬eq) ¬gt
-... | tri≈ ¬lt eq ¬gt = tri≈ ¬lt (≈⇒≡ eq) ¬gt
-... | tri> ¬lt ¬eq gt = tri> ¬lt (≉⇒≢ ¬eq) gt
-
-<-irrefl : Irreflexive _≡_ _<_
-<-irrefl = ℕₚ.<-irrefl ∘′ cong toℕ
-
-<-trans : Transitive _<_
-<-trans {c} {d} {e} = On.transitive toℕ ℕ._<_ ℕₚ.<-trans {c} {d} {e}
-
-<-asym : Asymmetric _<_
-<-asym {c} {d} = On.asymmetric toℕ ℕ._<_ ℕₚ.<-asym {c} {d}
-
-<-isStrictPartialOrder : IsStrictPartialOrder _≡_ _<_
-<-isStrictPartialOrder = record
-  { isEquivalence = PropEq.isEquivalence
-  ; irrefl        = <-irrefl
-  ; trans         = λ {a} {b} {c} → <-trans {a} {b} {c}
-  ; <-resp-≈      = (λ {c} → PropEq.subst (c <_))
-                  , (λ {c} → PropEq.subst (_< c))
-  }
-
-<-isStrictTotalOrder : IsStrictTotalOrder _≡_ _<_
-<-isStrictTotalOrder = record
-  { isEquivalence = PropEq.isEquivalence
-  ; trans         = λ {a} {b} {c} → <-trans {a} {b} {c}
-  ; compare       = <-cmp
-  }
-
-<-strictPartialOrder : StrictPartialOrder _ _ _
-<-strictPartialOrder = record
-  { isStrictPartialOrder = <-isStrictPartialOrder
-  }
-
-<-strictTotalOrder : StrictTotalOrder _ _ _
-<-strictTotalOrder = record
-  { isStrictTotalOrder = <-isStrictTotalOrder
-  }
-
-------------------------------------------------------------------------
--- Properties of _≤_
-
-infix 4 _≤?_
-_≤?_ : Decidable _≤_
-_≤?_ = Reflₚ.decidable <-cmp
-
-≤-reflexive : _≡_ ⇒ _≤_
-≤-reflexive = Refl.reflexive
-
-≤-trans : Transitive _≤_
-≤-trans = Reflₚ.trans (λ {a} {b} {c} → <-trans {a} {b} {c})
-
-≤-antisym : Antisymmetric _≡_ _≤_
-≤-antisym = Reflₚ.antisym _≡_ refl ℕₚ.<-asym
-
-≤-isPreorder : IsPreorder _≡_ _≤_
-≤-isPreorder = record
-  { isEquivalence = PropEq.isEquivalence
-  ; reflexive     = ≤-reflexive
-  ; trans         = ≤-trans
-  }
-
-≤-isPartialOrder : IsPartialOrder _≡_ _≤_
-≤-isPartialOrder = record
-  { isPreorder = ≤-isPreorder
-  ; antisym    = ≤-antisym
-  }
-
-≤-isDecPartialOrder : IsDecPartialOrder _≡_ _≤_
-≤-isDecPartialOrder = record
-  { isPartialOrder = ≤-isPartialOrder
-  ; _≟_            = _≟_
-  ; _≤?_           = _≤?_
-  }
-
-≤-preorder : Preorder _ _ _
-≤-preorder = record { isPreorder = ≤-isPreorder }
-
-≤-poset : Poset _ _ _
-≤-poset = record { isPartialOrder = ≤-isPartialOrder }
-
-≤-decPoset : DecPoset _ _ _
-≤-decPoset = record { isDecPartialOrder = ≤-isDecPartialOrder }
-
-------------------------------------------------------------------------
--- DEPRECATED NAMES
-------------------------------------------------------------------------
--- Please use the new names as continuing support for the old names is
--- not guaranteed.
-
--- Version 1.5
-
-≈-refl : Reflexive _≈_
-≈-refl = refl
-{-# WARNING_ON_USAGE ≈-refl
-"Warning: ≈-refl was deprecated in v1.5.
-Please use Propositional Equality's refl instead."
-#-}
-
-≈-sym : Symmetric _≈_
-≈-sym = sym
-{-# WARNING_ON_USAGE ≈-sym
-"Warning: ≈-sym was deprecated in v1.5.
-Please use Propositional Equality's sym instead."
-#-}
-
-≈-trans : Transitive _≈_
-≈-trans = trans
-{-# WARNING_ON_USAGE ≈-trans
-"Warning: ≈-trans was deprecated in v1.5.
-Please use Propositional Equality's trans instead."
-#-}
-
-≈-subst : ∀ {ℓ} → Substitutive _≈_ ℓ
-≈-subst P x≈y p = subst P (≈⇒≡ x≈y) p
-{-# WARNING_ON_USAGE ≈-subst
-"Warning: ≈-subst was deprecated in v1.5.
-Please use Propositional Equality's subst instead."
-#-}
-
-infix 4 _≈?_
-_≈?_ : Decidable _≈_
-x ≈? y = toℕ x ℕₚ.≟ toℕ y
-
-≈-isEquivalence : IsEquivalence _≈_
-≈-isEquivalence = record
-  { refl  = refl
-  ; sym   = sym
-  ; trans = trans
-  }
-≈-setoid : Setoid _ _
-≈-setoid = record
-  { isEquivalence = ≈-isEquivalence
-  }
-≈-isDecEquivalence : IsDecEquivalence _≈_
-≈-isDecEquivalence = record
-  { isEquivalence = ≈-isEquivalence
-  ; _≟_           = _≈?_
-  }
-≈-decSetoid : DecSetoid _ _
-≈-decSetoid = record
-  { isDecEquivalence = ≈-isDecEquivalence
-  }
-{-# WARNING_ON_USAGE _≈?_
-"Warning: _≈?_ was deprecated in v1.5.
-Please use _≟_ instead."
-#-}
-{-# WARNING_ON_USAGE ≈-isEquivalence
-"Warning: ≈-isEquivalence was deprecated in v1.5.
-Please use Propositional Equality's isEquivalence instead."
-#-}
-{-# WARNING_ON_USAGE ≈-setoid
-"Warning: ≈-setoid was deprecated in v1.5.
-Please use Propositional Equality's setoid instead."
-#-}
-{-# WARNING_ON_USAGE ≈-isDecEquivalence
-"Warning: ≈-isDecEquivalence was deprecated in v1.5.
-Please use Propositional Equality's isDecEquivalence instead."
-#-}
-{-# WARNING_ON_USAGE ≈-decSetoid
-"Warning: ≈-decSetoid was deprecated in v1.5.
-Please use Propositional Equality's decSetoid instead."
-#-}
-
-≡-setoid : Setoid _ _
-≡-setoid = setoid
-{-# WARNING_ON_USAGE ≡-setoid
-"Warning: ≡-setoid was deprecated in v1.5.
-Please use setoid instead."
-#-}
-
-≡-decSetoid : DecSetoid _ _
-≡-decSetoid = decSetoid
-{-# WARNING_ON_USAGE ≡-decSetoid
-"Warning: ≡-decSetoid was deprecated in v1.5.
-Please use decSetoid instead."
-#-}
-
-<-isStrictPartialOrder-≈ : IsStrictPartialOrder _≈_ _<_
-<-isStrictPartialOrder-≈ = On.isStrictPartialOrder toℕ ℕₚ.<-isStrictPartialOrder
-{-# WARNING_ON_USAGE <-isStrictPartialOrder-≈
-"Warning: <-isStrictPartialOrder-≈ was deprecated in v1.5.
-Please use <-isStrictPartialOrder instead."
-#-}
-
-<-isStrictTotalOrder-≈ : IsStrictTotalOrder _≈_ _<_
-<-isStrictTotalOrder-≈ = On.isStrictTotalOrder toℕ ℕₚ.<-isStrictTotalOrder
-{-# WARNING_ON_USAGE <-isStrictTotalOrder-≈
-"Warning: <-isStrictTotalOrder-≈ was deprecated in v1.5.
-Please use <-isStrictTotalOrder instead."
-#-}
-
-<-strictPartialOrder-≈ : StrictPartialOrder _ _ _
-<-strictPartialOrder-≈ = On.strictPartialOrder ℕₚ.<-strictPartialOrder toℕ
-{-# WARNING_ON_USAGE <-strictPartialOrder-≈
-"Warning: <-strictPartialOrder-≈ was deprecated in v1.5.
-Please use <-strictPartialOrder instead."
-#-}
-
-<-strictTotalOrder-≈ : StrictTotalOrder _ _ _
-<-strictTotalOrder-≈ = On.strictTotalOrder ℕₚ.<-strictTotalOrder toℕ
-{-# WARNING_ON_USAGE <-strictTotalOrder-≈
-"Warning: <-strictTotalOrder-≈ was deprecated in v1.5.
-Please use <-strictTotalOrder instead."
-#-}
-
\ No newline at end of file diff --git a/Data.Char.html b/Data.Char.html deleted file mode 100644 index 533acdab..00000000 --- a/Data.Char.html +++ /dev/null @@ -1,18 +0,0 @@ - -Data.Char
------------------------------------------------------------------------
--- The Agda standard library
---
--- Characters
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-module Data.Char where
-
-------------------------------------------------------------------------
--- Re-export base definitions and decidability of equality
-
-open import Data.Char.Base public
-open import Data.Char.Properties
-  using (_≈?_; _≟_; _<?_; _≤?_; _==_) public
-
\ No newline at end of file diff --git a/Data.Digit.html b/Data.Digit.html index b4ca5ebf..f3d70846 100644 --- a/Data.Digit.html +++ b/Data.Digit.html @@ -10,122 +10,120 @@ module Data.Digit where open import Data.Nat.Base -open import Data.Nat.Properties -open import Data.Nat.Solver -open import Data.Fin.Base as Fin using (Fin; zero; suc; toℕ) -open import Data.Bool.Base using (Bool; true; false) -open import Data.Char using (Char) -open import Data.List.Base -open import Data.Product -open import Data.Vec.Base as Vec using (Vec; _∷_; []) -open import Data.Nat.DivMod -open import Data.Nat.Induction -open import Relation.Nullary.Decidable using (does) -open import Relation.Nullary.Decidable -open import Relation.Binary using (Decidable) -open import Relation.Binary.PropositionalEquality as P using (_≡_; refl) -open import Function - ------------------------------------------------------------------------- --- Digits - --- Digit b is the type of digits in base b. - -Digit : ℕ → Set -Digit b = Fin b - --- Some specific digit kinds. - -Decimal = Digit 10 -Bit = Digit 2 - --- Some named digits. - -0b : Bit -0b = zero - -1b : Bit -1b = suc zero - ------------------------------------------------------------------------- --- Converting between `ℕ` and `expansions of ℕ` - -toNatDigits : (base : ℕ) {base≤16 : True (1 ≤? base)} → ℕ → List ℕ -toNatDigits base@(suc zero) n = replicate n 1 -toNatDigits base@(suc (suc _)) n = aux (<-wellFounded-fast n) [] - where - aux : {n : ℕ} → Acc _<_ n → List ℕ → List ℕ - aux {zero} _ xs = (0 ∷ xs) - aux {n@(suc _)} (acc wf) xs with does (0 <? n / base) - ... | false = (n % base) ∷ xs - ... | true = aux (wf (n / base) q<n) ((n % base) ∷ xs) - where - q<n : n / base < n - q<n = m/n<m n base (s<s z<s) - ------------------------------------------------------------------------- --- Converting between `ℕ` and expansions of `Digit base` - -Expansion : ℕ → Set -Expansion base = List (Digit base) - --- fromDigits takes a digit expansion of a natural number, starting --- with the _least_ significant digit, and returns the corresponding --- natural number. - -fromDigits : ∀ {base} → Expansion base → ℕ -fromDigits [] = 0 -fromDigits {base} (d ∷ ds) = toℕ d + fromDigits ds * base - --- toDigits b n yields the digits of n, in base b, starting with the --- _least_ significant digit. --- --- Note that the list of digits is always non-empty. - -toDigits : (base : ℕ) {base≥2 : True (2 ≤? base)} (n : ℕ) → - ∃ λ (ds : Expansion base) → fromDigits ds ≡ n -toDigits base@(suc (suc k)) n = <′-rec Pred helper n - where - - Pred = λ n → ∃ λ ds → fromDigits ds ≡ n - - cons : ∀ {m} (r : Digit base) → Pred m → Pred (toℕ r + m * base) - cons r (ds , eq) = (r ∷ ds , P.cong (λ i → toℕ r + i * base) eq) - - open ≤-Reasoning - open +-*-Solver - - lem : ∀ x k r → 2 + x ≤′ r + (1 + x) * (2 + k) - lem x k r = ≤⇒≤′ $ begin - 2 + x - ≤⟨ m≤m+n _ _ ⟩ - 2 + x + (x + (1 + x) * k + r) - ≡⟨ solve 3 (λ x r k → con 2 :+ x :+ (x :+ (con 1 :+ x) :* k :+ r) - := - r :+ (con 1 :+ x) :* (con 2 :+ k)) - refl x r k ⟩ - r + (1 + x) * (2 + k) - ∎ - - helper : ∀ n → <′-Rec Pred n → Pred n - helper n rec with n divMod base - helper .(toℕ r + 0 * base) rec | result zero r refl = ([ r ] , refl) - helper .(toℕ r + suc x * base) rec | result (suc x) r refl = - cons r (rec (suc x) (lem x k (toℕ r))) - ------------------------------------------------------------------------- --- Showing digits - --- The characters used to show the first 16 digits. - -digitChars : Vec Char 16 -digitChars = - '0' ∷ '1' ∷ '2' ∷ '3' ∷ '4' ∷ '5' ∷ '6' ∷ '7' ∷ '8' ∷ '9' ∷ - 'a' ∷ 'b' ∷ 'c' ∷ 'd' ∷ 'e' ∷ 'f' ∷ [] +open import Data.Nat.Properties using (_≤?_; _<?_; ≤⇒≤′; module ≤-Reasoning; m≤m+n) +open import Data.Nat.Solver using (module +-*-Solver) +open import Data.Fin.Base as Fin using (Fin; zero; suc; toℕ) +open import Data.Bool.Base using (Bool; true; false) +open import Data.Char.Base using (Char) +open import Data.List.Base +open import Data.Product.Base using (∃; _,_) +open import Data.Vec.Base as Vec using (Vec; _∷_; []) +open import Data.Nat.DivMod +open import Data.Nat.Induction +open import Relation.Nullary.Decidable using (True; does; toWitness) +open import Relation.Binary.Definitions using (Decidable) +open import Relation.Binary.PropositionalEquality.Core as P using (_≡_; refl) +open import Function.Base using (_$_) + +------------------------------------------------------------------------ +-- Digits + +-- Digit b is the type of digits in base b. + +Digit : ℕ → Set +Digit b = Fin b + +-- Some specific digit kinds. + +Decimal = Digit 10 +Bit = Digit 2 + +-- Some named digits. + +0b : Bit +0b = zero + +1b : Bit +1b = suc zero + +------------------------------------------------------------------------ +-- Converting between `ℕ` and `expansions of ℕ` + +toNatDigits : (base : ℕ) {base≤16 : True (1 ≤? base)} → ℕ → List ℕ +toNatDigits base@(suc zero) n = replicate n 1 +toNatDigits base@(suc (suc _)) n = aux (<-wellFounded-fast n) [] + where + aux : {n : ℕ} → Acc _<_ n → List ℕ → List ℕ + aux {zero} _ xs = (0 ∷ xs) + aux {n@(suc _)} (acc wf) xs with does (0 <? n / base) + ... | false = (n % base) ∷ xs + ... | true = aux (wf q<n) ((n % base) ∷ xs) + where + q<n : n / base < n + q<n = m/n<m n base (s<s z<s) + +------------------------------------------------------------------------ +-- Converting between `ℕ` and expansions of `Digit base` + +Expansion : ℕ → Set +Expansion base = List (Digit base) + +-- fromDigits takes a digit expansion of a natural number, starting +-- with the _least_ significant digit, and returns the corresponding +-- natural number. + +fromDigits : ∀ {base} → Expansion base → ℕ +fromDigits [] = 0 +fromDigits {base} (d ∷ ds) = toℕ d + fromDigits ds * base + +-- toDigits b n yields the digits of n, in base b, starting with the +-- _least_ significant digit. +-- +-- Note that the list of digits is always non-empty. + +toDigits : (base : ℕ) {base≥2 : True (2 ≤? base)} (n : ℕ) → + ∃ λ (ds : Expansion base) → fromDigits ds ≡ n +toDigits base@(suc (suc k)) n = <′-rec Pred helper n + where + + Pred = λ n → ∃ λ ds → fromDigits ds ≡ n + + cons : ∀ {m} (r : Digit base) → Pred m → Pred (toℕ r + m * base) + cons r (ds , eq) = (r ∷ ds , P.cong (λ i → toℕ r + i * base) eq) + + open ≤-Reasoning + open +-*-Solver + + lem : ∀ x k r → 2 + x ≤′ r + (1 + x) * (2 + k) + lem x k r = ≤⇒≤′ $ begin + 2 + x + ≤⟨ m≤m+n _ _ ⟩ + 2 + x + (x + (1 + x) * k + r) + ≡⟨ solve 3 (λ x r k → con 2 :+ x :+ (x :+ (con 1 :+ x) :* k :+ r) + := + r :+ (con 1 :+ x) :* (con 2 :+ k)) + refl x r k ⟩ + r + (1 + x) * (2 + k) + ∎ + + helper : ∀ n → <′-Rec Pred n → Pred n + helper n rec with n divMod base + ... | result zero r eq = ([ r ] , P.sym eq) + ... | result (suc x) r refl = cons r (rec (lem x k (toℕ r))) + +------------------------------------------------------------------------ +-- Showing digits + +-- The characters used to show the first 16 digits. + +digitChars : Vec Char 16 +digitChars = + '0' ∷ '1' ∷ '2' ∷ '3' ∷ '4' ∷ '5' ∷ '6' ∷ '7' ∷ '8' ∷ '9' ∷ + 'a' ∷ 'b' ∷ 'c' ∷ 'd' ∷ 'e' ∷ 'f' ∷ [] --- showDigit shows digits in base ≤ 16. +-- showDigit shows digits in base ≤ 16. -showDigit : ∀ {base} {base≤16 : True (base ≤? 16)} → Digit base → Char -showDigit {base≤16 = base≤16} d = - Vec.lookup digitChars (Fin.inject≤ d (toWitness base≤16)) +showDigit : ∀ {base} {base≤16 : True (base ≤? 16)} → Digit base → Char +showDigit {base≤16 = base≤16} d = + Vec.lookup digitChars (Fin.inject≤ d (toWitness base≤16)) \ No newline at end of file diff --git a/Data.Empty.html b/Data.Empty.html index eea8f872..a2da8884 100644 --- a/Data.Empty.html +++ b/Data.Empty.html @@ -21,10 +21,10 @@ private data Empty : Set where --- ⊥ is defined via Data.Irrelevant (a record with a single irrelevant field) --- so that Agda can judgementally declare that all proofs of ⊥ are equal --- to each other. In particular this means that all functions returning a --- proof of ⊥ are equal. +-- ⊥ is defined via Data.Irrelevant (a record with a single irrelevant +-- field) so that Agda can judgementally declare that all proofs of ⊥ +-- are equal to each other. In particular this means that all functions +-- returning a proof of ⊥ are equal. ⊥ : Set ⊥ = Irrelevant Empty diff --git a/Data.Fin.Base.html b/Data.Fin.Base.html index b27bc6e4..14b400bd 100644 --- a/Data.Fin.Base.html +++ b/Data.Fin.Base.html @@ -12,336 +12,333 @@ module Data.Fin.Base where -open import Data.Bool.Base using (Bool; true; false; T; not) -open import Data.Empty using (⊥-elim) -open import Data.Nat.Base as ℕ using (ℕ; zero; suc; z≤n; s≤s; z<s; s<s; _^_) -open import Data.Product as Product using (_×_; _,_; proj₁; proj₂) -open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂; [_,_]′) -open import Function.Base using (id; _∘_; _on_; flip) -open import Level using (0ℓ) -open import Relation.Nullary.Negation.Core using (contradiction) -open import Relation.Nullary.Decidable.Core using (yes; no; True; toWitness) -open import Relation.Binary.Core -open import Relation.Binary.PropositionalEquality.Core using (_≡_; _≢_; refl; cong) -open import Relation.Binary.Indexed.Heterogeneous.Core using (IRel) +open import Data.Bool.Base using (Bool; T) +open import Data.Nat.Base as ℕ using (ℕ; zero; suc) +open import Data.Product.Base as Product using (_×_; _,_; proj₁; proj₂) +open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂; [_,_]′) +open import Function.Base using (id; _∘_; _on_; flip) +open import Level using (0ℓ) +open import Relation.Binary.Core +open import Relation.Binary.PropositionalEquality.Core using (_≡_; _≢_; refl; cong) +open import Relation.Binary.Indexed.Heterogeneous.Core using (IRel) +open import Relation.Nullary.Negation.Core using (contradiction) -private - variable - m n : ℕ +private + variable + m n : ℕ ------------------------------------------------------------------------- --- Types +------------------------------------------------------------------------ +-- Types --- Fin n is a type with n elements. +-- Fin n is a type with n elements. -data Fin : ℕ → Set where - zero : Fin (suc n) - suc : (i : Fin n) → Fin (suc n) +data Fin : ℕ → Set where + zero : Fin (suc n) + suc : (i : Fin n) → Fin (suc n) --- A conversion: toℕ "i" = i. +-- A conversion: toℕ "i" = i. -toℕ : Fin n → ℕ -toℕ zero = 0 -toℕ (suc i) = suc (toℕ i) +toℕ : Fin n → ℕ +toℕ zero = 0 +toℕ (suc i) = suc (toℕ i) --- A Fin-indexed variant of Fin. +-- A Fin-indexed variant of Fin. -Fin′ : Fin n → Set -Fin′ i = Fin (toℕ i) +Fin′ : Fin n → Set +Fin′ i = Fin (toℕ i) ------------------------------------------------------------------------- --- A cast that actually computes on constructors (as opposed to subst) +------------------------------------------------------------------------ +-- A cast that actually computes on constructors (as opposed to subst) -cast : .(m ≡ n) → Fin m → Fin n -cast {zero} {zero} eq k = k -cast {suc m} {suc n} eq zero = zero -cast {suc m} {suc n} eq (suc k) = suc (cast (cong ℕ.pred eq) k) +cast : .(m ≡ n) → Fin m → Fin n +cast {zero} {zero} eq k = k +cast {suc m} {suc n} eq zero = zero +cast {suc m} {suc n} eq (suc k) = suc (cast (cong ℕ.pred eq) k) ------------------------------------------------------------------------- --- Conversions +------------------------------------------------------------------------ +-- Conversions --- toℕ is defined above. +-- toℕ is defined above. --- fromℕ n = "n". +-- fromℕ n = "n". -fromℕ : (n : ℕ) → Fin (suc n) -fromℕ zero = zero -fromℕ (suc n) = suc (fromℕ n) +fromℕ : (n : ℕ) → Fin (suc n) +fromℕ zero = zero +fromℕ (suc n) = suc (fromℕ n) --- fromℕ< {m} _ = "m". +-- fromℕ< {m} _ = "m". -fromℕ< : m ℕ.< n → Fin n -fromℕ< {zero} {suc n} z<s = zero -fromℕ< {suc m} {suc n} (s<s m<n) = suc (fromℕ< m<n) +fromℕ< : .(m ℕ.< n) → Fin n +fromℕ< {zero} {suc _} _ = zero +fromℕ< {suc m} {suc _} m<n = suc (fromℕ< (ℕ.s<s⁻¹ m<n)) --- fromℕ<″ m _ = "m". +-- fromℕ<″ m _ = "m". -fromℕ<″ : ∀ m {n} → m ℕ.<″ n → Fin n -fromℕ<″ zero (ℕ.less-than-or-equal refl) = zero -fromℕ<″ (suc m) (ℕ.less-than-or-equal refl) = - suc (fromℕ<″ m (ℕ.less-than-or-equal refl)) +fromℕ<″ : ∀ m {n} → .(m ℕ.<″ n) → Fin n +fromℕ<″ zero {suc _} _ = zero +fromℕ<″ (suc m) {suc _} m<″n = suc (fromℕ<″ m (ℕ.s<″s⁻¹ m<″n)) --- canonical liftings of i:Fin m to larger index +-- canonical liftings of i:Fin m to larger index --- injection on the left: "i" ↑ˡ n = "i" in Fin (m + n) -infixl 5 _↑ˡ_ -_↑ˡ_ : ∀ {m} → Fin m → ∀ n → Fin (m ℕ.+ n) -zero ↑ˡ n = zero -(suc i) ↑ˡ n = suc (i ↑ˡ n) +-- injection on the left: "i" ↑ˡ n = "i" in Fin (m + n) +infixl 5 _↑ˡ_ +_↑ˡ_ : ∀ {m} → Fin m → ∀ n → Fin (m ℕ.+ n) +zero ↑ˡ n = zero +(suc i) ↑ˡ n = suc (i ↑ˡ n) --- injection on the right: n ↑ʳ "i" = "n + i" in Fin (n + m) -infixr 5 _↑ʳ_ -_↑ʳ_ : ∀ {m} n → Fin m → Fin (n ℕ.+ m) -zero ↑ʳ i = i -(suc n) ↑ʳ i = suc (n ↑ʳ i) +-- injection on the right: n ↑ʳ "i" = "n + i" in Fin (n + m) +infixr 5 _↑ʳ_ +_↑ʳ_ : ∀ {m} n → Fin m → Fin (n ℕ.+ m) +zero ↑ʳ i = i +(suc n) ↑ʳ i = suc (n ↑ʳ i) --- reduce≥ "m + i" _ = "i". +-- reduce≥ "m + i" _ = "i". -reduce≥ : ∀ (i : Fin (m ℕ.+ n)) (i≥m : toℕ i ℕ.≥ m) → Fin n -reduce≥ {zero} i i≥m = i -reduce≥ {suc m} (suc i) (s≤s i≥m) = reduce≥ i i≥m +reduce≥ : ∀ (i : Fin (m ℕ.+ n)) → .(m ℕ.≤ toℕ i) → Fin n +reduce≥ {zero} i _ = i +reduce≥ {suc _} (suc i) m≤i = reduce≥ i (ℕ.s≤s⁻¹ m≤i) --- inject⋆ m "i" = "i". +-- inject⋆ m "i" = "i". -inject : ∀ {i : Fin n} → Fin′ i → Fin n -inject {i = suc i} zero = zero -inject {i = suc i} (suc j) = suc (inject j) +inject : ∀ {i : Fin n} → Fin′ i → Fin n +inject {i = suc i} zero = zero +inject {i = suc i} (suc j) = suc (inject j) -inject! : ∀ {i : Fin (suc n)} → Fin′ i → Fin n -inject! {n = suc _} {i = suc _} zero = zero -inject! {n = suc _} {i = suc _} (suc j) = suc (inject! j) +inject! : ∀ {i : Fin (suc n)} → Fin′ i → Fin n +inject! {n = suc _} {i = suc _} zero = zero +inject! {n = suc _} {i = suc _} (suc j) = suc (inject! j) -inject₁ : Fin n → Fin (suc n) -inject₁ zero = zero -inject₁ (suc i) = suc (inject₁ i) +inject₁ : Fin n → Fin (suc n) +inject₁ zero = zero +inject₁ (suc i) = suc (inject₁ i) -inject≤ : Fin m → m ℕ.≤ n → Fin n -inject≤ {_} {suc n} zero _ = zero -inject≤ {_} {suc n} (suc i) (s≤s m≤n) = suc (inject≤ i m≤n) +inject≤ : Fin m → .(m ℕ.≤ n) → Fin n +inject≤ {n = suc _} zero _ = zero +inject≤ {n = suc _} (suc i) m≤n = suc (inject≤ i (ℕ.s≤s⁻¹ m≤n)) --- lower₁ "i" _ = "i". +-- lower₁ "i" _ = "i". -lower₁ : ∀ (i : Fin (suc n)) → n ≢ toℕ i → Fin n -lower₁ {zero} zero ne = ⊥-elim (ne refl) -lower₁ {suc n} zero _ = zero -lower₁ {suc n} (suc i) ne = suc (lower₁ i (ne ∘ cong suc)) +lower₁ : ∀ (i : Fin (suc n)) → n ≢ toℕ i → Fin n +lower₁ {zero} zero ne = contradiction refl ne +lower₁ {suc n} zero _ = zero +lower₁ {suc n} (suc i) ne = suc (lower₁ i (ne ∘ cong suc)) --- A strengthening injection into the minimal Fin fibre. -strengthen : ∀ (i : Fin n) → Fin′ (suc i) -strengthen zero = zero -strengthen (suc i) = suc (strengthen i) +-- A strengthening injection into the minimal Fin fibre. +strengthen : ∀ (i : Fin n) → Fin′ (suc i) +strengthen zero = zero +strengthen (suc i) = suc (strengthen i) --- splitAt m "i" = inj₁ "i" if i < m --- inj₂ "i - m" if i ≥ m --- This is dual to splitAt from Data.Vec. +-- splitAt m "i" = inj₁ "i" if i < m +-- inj₂ "i - m" if i ≥ m +-- This is dual to splitAt from Data.Vec. -splitAt : ∀ m {n} → Fin (m ℕ.+ n) → Fin m ⊎ Fin n -splitAt zero i = inj₂ i -splitAt (suc m) zero = inj₁ zero -splitAt (suc m) (suc i) = Sum.map suc id (splitAt m i) +splitAt : ∀ m {n} → Fin (m ℕ.+ n) → Fin m ⊎ Fin n +splitAt zero i = inj₂ i +splitAt (suc m) zero = inj₁ zero +splitAt (suc m) (suc i) = Sum.map suc id (splitAt m i) --- inverse of above function -join : ∀ m n → Fin m ⊎ Fin n → Fin (m ℕ.+ n) -join m n = [ _↑ˡ n , m ↑ʳ_ ]′ +-- inverse of above function +join : ∀ m n → Fin m ⊎ Fin n → Fin (m ℕ.+ n) +join m n = [ _↑ˡ n , m ↑ʳ_ ]′ --- quotRem k "i" = "i % k" , "i / k" --- This is dual to group from Data.Vec. +-- quotRem k "i" = "i % k" , "i / k" +-- This is dual to group from Data.Vec. -quotRem : ∀ n → Fin (m ℕ.* n) → Fin n × Fin m -quotRem {suc m} n i with splitAt n i -... | inj₁ j = j , zero -... | inj₂ j = Product.map₂ suc (quotRem {m} n j) +quotRem : ∀ n → Fin (m ℕ.* n) → Fin n × Fin m +quotRem {suc m} n i with splitAt n i +... | inj₁ j = j , zero +... | inj₂ j = Product.map₂ suc (quotRem {m} n j) --- a variant of quotRem the type of whose result matches the order of multiplication -remQuot : ∀ n → Fin (m ℕ.* n) → Fin m × Fin n -remQuot i = Product.swap ∘ quotRem i +-- a variant of quotRem the type of whose result matches the order of multiplication +remQuot : ∀ n → Fin (m ℕ.* n) → Fin m × Fin n +remQuot i = Product.swap ∘ quotRem i -quotient : ∀ n → Fin (m ℕ.* n) → Fin m -quotient n = proj₁ ∘ remQuot n +quotient : ∀ n → Fin (m ℕ.* n) → Fin m +quotient n = proj₁ ∘ remQuot n -remainder : ∀ n → Fin (m ℕ.* n) → Fin n -remainder {m} n = proj₂ ∘ remQuot {m} n +remainder : ∀ n → Fin (m ℕ.* n) → Fin n +remainder {m} n = proj₂ ∘ remQuot {m} n --- inverse of remQuot -combine : Fin m → Fin n → Fin (m ℕ.* n) -combine {suc m} {n} zero j = j ↑ˡ (m ℕ.* n) -combine {suc m} {n} (suc i) j = n ↑ʳ (combine i j) +-- inverse of remQuot +combine : Fin m → Fin n → Fin (m ℕ.* n) +combine {suc m} {n} zero j = j ↑ˡ (m ℕ.* n) +combine {suc m} {n} (suc i) j = n ↑ʳ (combine i j) --- Next in progression after splitAt and remQuot -finToFun : Fin (m ^ n) → (Fin n → Fin m) -finToFun {m} {suc n} i zero = quotient (m ^ n) i -finToFun {m} {suc n} i (suc j) = finToFun (remainder {m} (m ^ n) i) j +-- Next in progression after splitAt and remQuot +finToFun : Fin (m ℕ.^ n) → (Fin n → Fin m) +finToFun {m} {suc n} i zero = quotient (m ℕ.^ n) i +finToFun {m} {suc n} i (suc j) = finToFun (remainder {m} (m ℕ.^ n) i) j --- inverse of above function -funToFin : (Fin m → Fin n) → Fin (n ^ m) -funToFin {zero} f = zero -funToFin {suc m} f = combine (f zero) (funToFin (f ∘ suc)) +-- inverse of above function +funToFin : (Fin m → Fin n) → Fin (n ℕ.^ m) +funToFin {zero} f = zero +funToFin {suc m} f = combine (f zero) (funToFin (f ∘ suc)) ------------------------------------------------------------------------- --- Operations +------------------------------------------------------------------------ +-- Operations --- Folds. +-- Folds. -fold : ∀ {t} (T : ℕ → Set t) {m} → - (∀ {n} → T n → T (suc n)) → - (∀ {n} → T (suc n)) → - Fin m → T m -fold T f x zero = x -fold T f x (suc i) = f (fold T f x i) +fold : ∀ {t} (T : ℕ → Set t) {m} → + (∀ {n} → T n → T (suc n)) → + (∀ {n} → T (suc n)) → + Fin m → T m +fold T f x zero = x +fold T f x (suc i) = f (fold T f x i) -fold′ : ∀ {n t} (T : Fin (suc n) → Set t) → - (∀ i → T (inject₁ i) → T (suc i)) → - T zero → - ∀ i → T i -fold′ T f x zero = x -fold′ {n = suc n} T f x (suc i) = - f i (fold′ (T ∘ inject₁) (f ∘ inject₁) x i) +fold′ : ∀ {n t} (T : Fin (suc n) → Set t) → + (∀ i → T (inject₁ i) → T (suc i)) → + T zero → + ∀ i → T i +fold′ T f x zero = x +fold′ {n = suc n} T f x (suc i) = + f i (fold′ (T ∘ inject₁) (f ∘ inject₁) x i) --- Lifts functions. +-- Lifts functions. -lift : ∀ k → (Fin m → Fin n) → Fin (k ℕ.+ m) → Fin (k ℕ.+ n) -lift zero f i = f i -lift (suc k) f zero = zero -lift (suc k) f (suc i) = suc (lift k f i) +lift : ∀ k → (Fin m → Fin n) → Fin (k ℕ.+ m) → Fin (k ℕ.+ n) +lift zero f i = f i +lift (suc k) f zero = zero +lift (suc k) f (suc i) = suc (lift k f i) --- "i" + "j" = "i + j". +-- "i" + "j" = "i + j". -infixl 6 _+_ +infixl 6 _+_ -_+_ : ∀ (i : Fin m) (j : Fin n) → Fin (toℕ i ℕ.+ n) -zero + j = j -suc i + j = suc (i + j) +_+_ : ∀ (i : Fin m) (j : Fin n) → Fin (toℕ i ℕ.+ n) +zero + j = j +suc i + j = suc (i + j) --- "i" - "j" = "i ∸ j". +-- "i" - "j" = "i ∸ j". -infixl 6 _-_ +infixl 6 _-_ -_-_ : ∀ (i : Fin n) (j : Fin′ (suc i)) → Fin (n ℕ.∸ toℕ j) -i - zero = i -suc i - suc j = i - j +_-_ : ∀ (i : Fin n) (j : Fin′ (suc i)) → Fin (n ℕ.∸ toℕ j) +i - zero = i +suc i - suc j = i - j --- m ℕ- "i" = "m ∸ i". +-- m ℕ- "i" = "m ∸ i". -infixl 6 _ℕ-_ +infixl 6 _ℕ-_ -_ℕ-_ : (n : ℕ) (j : Fin (suc n)) → Fin (suc n ℕ.∸ toℕ j) -n ℕ- zero = fromℕ n -suc n ℕ- suc i = n ℕ- i +_ℕ-_ : (n : ℕ) (j : Fin (suc n)) → Fin (suc n ℕ.∸ toℕ j) +n ℕ- zero = fromℕ n +suc n ℕ- suc i = n ℕ- i --- m ℕ-ℕ "i" = m ∸ i. +-- m ℕ-ℕ "i" = m ∸ i. -infixl 6 _ℕ-ℕ_ +infixl 6 _ℕ-ℕ_ -_ℕ-ℕ_ : (n : ℕ) → Fin (suc n) → ℕ -n ℕ-ℕ zero = n -suc n ℕ-ℕ suc i = n ℕ-ℕ i +_ℕ-ℕ_ : (n : ℕ) → Fin (suc n) → ℕ +n ℕ-ℕ zero = n +suc n ℕ-ℕ suc i = n ℕ-ℕ i --- pred "i" = "pred i". +-- pred "i" = "pred i". -pred : Fin n → Fin n -pred zero = zero -pred (suc i) = inject₁ i +pred : Fin n → Fin n +pred zero = zero +pred (suc i) = inject₁ i --- opposite "i" = "n - i" (i.e. the additive inverse). +-- opposite "i" = "n - i" (i.e. the additive inverse). -opposite : Fin n → Fin n -opposite {suc n} zero = fromℕ n -opposite {suc n} (suc i) = inject₁ (opposite i) +opposite : Fin n → Fin n +opposite {suc n} zero = fromℕ n +opposite {suc n} (suc i) = inject₁ (opposite i) --- The function f(i,j) = if j>i then j-1 else j --- This is a variant of the thick function from Conor --- McBride's "First-order unification by structural recursion". +-- The function f(i,j) = if j>i then j-1 else j +-- This is a variant of the thick function from Conor +-- McBride's "First-order unification by structural recursion". -punchOut : ∀ {i j : Fin (suc n)} → i ≢ j → Fin n -punchOut {_} {zero} {zero} i≢j = ⊥-elim (i≢j refl) -punchOut {_} {zero} {suc j} _ = j -punchOut {suc _} {suc i} {zero} _ = zero -punchOut {suc _} {suc i} {suc j} i≢j = suc (punchOut (i≢j ∘ cong suc)) +punchOut : ∀ {i j : Fin (suc n)} → i ≢ j → Fin n +punchOut {_} {zero} {zero} i≢j = contradiction refl i≢j +punchOut {_} {zero} {suc j} _ = j +punchOut {suc _} {suc i} {zero} _ = zero +punchOut {suc _} {suc i} {suc j} i≢j = suc (punchOut (i≢j ∘ cong suc)) --- The function f(i,j) = if j≥i then j+1 else j +-- The function f(i,j) = if j≥i then j+1 else j -punchIn : Fin (suc n) → Fin n → Fin (suc n) -punchIn zero j = suc j -punchIn (suc i) zero = zero -punchIn (suc i) (suc j) = suc (punchIn i j) +punchIn : Fin (suc n) → Fin n → Fin (suc n) +punchIn zero j = suc j +punchIn (suc i) zero = zero +punchIn (suc i) (suc j) = suc (punchIn i j) --- The function f(i,j) such that f(i,j) = if j≤i then j else j-1 +-- The function f(i,j) such that f(i,j) = if j≤i then j else j-1 -pinch : Fin n → Fin (suc n) → Fin n -pinch {suc n} _ zero = zero -pinch {suc n} zero (suc j) = j -pinch {suc n} (suc i) (suc j) = suc (pinch i j) +pinch : Fin n → Fin (suc n) → Fin n +pinch {suc n} _ zero = zero +pinch {suc n} zero (suc j) = j +pinch {suc n} (suc i) (suc j) = suc (pinch i j) ------------------------------------------------------------------------- --- Order relations +------------------------------------------------------------------------ +-- Order relations -infix 4 _≤_ _≥_ _<_ _>_ +infix 4 _≤_ _≥_ _<_ _>_ -_≤_ : IRel Fin 0ℓ -i ≤ j = toℕ i ℕ.≤ toℕ j +_≤_ : IRel Fin 0ℓ +i ≤ j = toℕ i ℕ.≤ toℕ j -_≥_ : IRel Fin 0ℓ -i ≥ j = toℕ i ℕ.≥ toℕ j +_≥_ : IRel Fin 0ℓ +i ≥ j = toℕ i ℕ.≥ toℕ j -_<_ : IRel Fin 0ℓ -i < j = toℕ i ℕ.< toℕ j +_<_ : IRel Fin 0ℓ +i < j = toℕ i ℕ.< toℕ j -_>_ : IRel Fin 0ℓ -i > j = toℕ i ℕ.> toℕ j +_>_ : IRel Fin 0ℓ +i > j = toℕ i ℕ.> toℕ j ------------------------------------------------------------------------- --- An ordering view. +------------------------------------------------------------------------ +-- An ordering view. -data Ordering {n : ℕ} : Fin n → Fin n → Set where - less : ∀ greatest (least : Fin′ greatest) → - Ordering (inject least) greatest - equal : ∀ i → Ordering i i - greater : ∀ greatest (least : Fin′ greatest) → - Ordering greatest (inject least) +data Ordering {n : ℕ} : Fin n → Fin n → Set where + less : ∀ greatest (least : Fin′ greatest) → + Ordering (inject least) greatest + equal : ∀ i → Ordering i i + greater : ∀ greatest (least : Fin′ greatest) → + Ordering greatest (inject least) -compare : ∀ (i j : Fin n) → Ordering i j -compare zero zero = equal zero -compare zero (suc j) = less (suc j) zero -compare (suc i) zero = greater (suc i) zero -compare (suc i) (suc j) with compare i j -... | less greatest least = less (suc greatest) (suc least) -... | greater greatest least = greater (suc greatest) (suc least) -... | equal i = equal (suc i) +compare : ∀ (i j : Fin n) → Ordering i j +compare zero zero = equal zero +compare zero (suc j) = less (suc j) zero +compare (suc i) zero = greater (suc i) zero +compare (suc i) (suc j) with compare i j +... | less greatest least = less (suc greatest) (suc least) +... | greater greatest least = greater (suc greatest) (suc least) +... | equal i = equal (suc i) ------------------------------------------------------------------------- --- DEPRECATED NAMES ------------------------------------------------------------------------- --- Please use the new names as continuing support for the old names is --- not guaranteed. +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. --- Version 2.0 +-- Version 2.0 -raise = _↑ʳ_ -{-# WARNING_ON_USAGE raise -"Warning: raise was deprecated in v2.0. +raise = _↑ʳ_ +{-# WARNING_ON_USAGE raise +"Warning: raise was deprecated in v2.0. Please use _↑_ʳ instead." -#-} -inject+ : ∀ {m} n → Fin m → Fin (m ℕ.+ n) -inject+ n i = i ↑ˡ n -{-# WARNING_ON_USAGE inject+ -"Warning: inject+ was deprecated in v2.0. +#-} +inject+ : ∀ {m} n → Fin m → Fin (m ℕ.+ n) +inject+ n i = i ↑ˡ n +{-# WARNING_ON_USAGE inject+ +"Warning: inject+ was deprecated in v2.0. Please use _↑ˡ_ instead. NB argument order has been flipped: the left-hand argument is the Fin m the right-hand is the Nat index increment." -#-} +#-} -data _≺_ : ℕ → ℕ → Set where - _≻toℕ_ : ∀ n (i : Fin n) → toℕ i ≺ n +data _≺_ : ℕ → ℕ → Set where + _≻toℕ_ : ∀ n (i : Fin n) → toℕ i ≺ n -{-# WARNING_ON_USAGE _≺_ -"Warning: _≺_ was deprecated in v2.0. +{-# WARNING_ON_USAGE _≺_ +"Warning: _≺_ was deprecated in v2.0. Please use equivalent relation _<_ instead." -#-} -{-# WARNING_ON_USAGE _≻toℕ_ -"Warning: _≻toℕ_ was deprecated in v2.0. +#-} +{-# WARNING_ON_USAGE _≻toℕ_ +"Warning: _≻toℕ_ was deprecated in v2.0. Please use toℕ<n from Data.Fin.Properties instead." -#-} +#-} \ No newline at end of file diff --git a/Data.Fin.Patterns.html b/Data.Fin.Patterns.html index 7ea810de..29a3153a 100644 --- a/Data.Fin.Patterns.html +++ b/Data.Fin.Patterns.html @@ -14,14 +14,14 @@ ------------------------------------------------------------------------ -- Constants -pattern 0F = zero -pattern 1F = suc 0F -pattern 2F = suc 1F -pattern 3F = suc 2F -pattern 4F = suc 3F -pattern 5F = suc 4F -pattern 6F = suc 5F -pattern 7F = suc 6F -pattern 8F = suc 7F -pattern 9F = suc 8F +pattern 0F = zero +pattern 1F = suc 0F +pattern 2F = suc 1F +pattern 3F = suc 2F +pattern 4F = suc 3F +pattern 5F = suc 4F +pattern 6F = suc 5F +pattern 7F = suc 6F +pattern 8F = suc 7F +pattern 9F = suc 8F \ No newline at end of file diff --git a/Data.Fin.Properties.html b/Data.Fin.Properties.html index 7b5481df..4d54e79c 100644 --- a/Data.Fin.Properties.html +++ b/Data.Fin.Properties.html @@ -12,1142 +12,1174 @@ module Data.Fin.Properties where open import Axiom.Extensionality.Propositional -open import Algebra.Definitions using (Involutive) -open import Effect.Applicative using (RawApplicative) +open import Algebra.Definitions using (Involutive) +open import Effect.Applicative using (RawApplicative) open import Effect.Functor using (RawFunctor) open import Data.Bool.Base using (Bool; true; false; not; _∧_; _∨_) open import Data.Empty using (⊥; ⊥-elim) open import Data.Fin.Base open import Data.Fin.Patterns -open import Data.Nat.Base as ℕ using (ℕ; zero; suc; s≤s; z≤n; z<s; s<s; _∸_; _^_) -import Data.Nat.Properties as ℕₚ -open import Data.Nat.Solver -open import Data.Unit using (⊤; tt) -open import Data.Product using (Σ-syntax; ∃; ∃₂; ∄; _×_; _,_; map; proj₁; proj₂; uncurry; <_,_>) -open import Data.Product.Properties using (,-injective) -open import Data.Product.Algebra using (×-cong) -open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂; [_,_]; [_,_]′) -open import Data.Sum.Properties using ([,]-map; [,]-∘) -open import Function.Base using (_∘_; id; _$_; flip) -open import Function.Bundles using (Injection; _↣_; _⇔_; _↔_; mk⇔; mk↔′) -open import Function.Definitions using (Injective) -open import Function.Definitions.Core2 using (Surjective) -open import Function.Consequences using (contraInjective) -open import Function.Construct.Composition as Comp hiding (injective) -open import Level using (Level) -open import Relation.Binary as B hiding (Decidable; _⇔_) -open import Relation.Binary.PropositionalEquality as P - using (_≡_; _≢_; refl; sym; trans; cong; cong₂; subst; _≗_; module ≡-Reasoning) -open import Relation.Nullary - using (Reflects; ofʸ; ofⁿ; Dec; _because_; does; proof; yes; no; ¬_; _×-dec_; _⊎-dec_; contradiction) -open import Relation.Nullary.Reflects -open import Relation.Nullary.Decidable as Dec using (map′) -open import Relation.Unary as U - using (U; Pred; Decidable; _⊆_; Satisfiable; Universal) -open import Relation.Unary.Properties using (U?) - -private - variable - a : Level - A : Set a - m n o : ℕ - i j : Fin n - ------------------------------------------------------------------------- --- Fin ------------------------------------------------------------------------- - -¬Fin0 : ¬ Fin 0 -¬Fin0 () - ------------------------------------------------------------------------- --- Bundles - -0↔⊥ : Fin 0 ↔ ⊥ -0↔⊥ = mk↔′ ¬Fin0 (λ ()) (λ ()) (λ ()) - -1↔⊤ : Fin 1 ↔ ⊤ -1↔⊤ = mk↔′ (λ { 0F → tt }) (λ { tt → 0F }) (λ { tt → refl }) λ { 0F → refl } - -2↔Bool : Fin 2 ↔ Bool -2↔Bool = mk↔′ (λ { 0F → false; 1F → true }) (λ { false → 0F ; true → 1F }) - (λ { false → refl ; true → refl }) (λ { 0F → refl ; 1F → refl }) - ------------------------------------------------------------------------- --- Properties of _≡_ ------------------------------------------------------------------------- - -0≢1+n : zero ≢ Fin.suc i -0≢1+n () - -suc-injective : Fin.suc i ≡ suc j → i ≡ j -suc-injective refl = refl - -infix 4 _≟_ - -_≟_ : DecidableEquality (Fin n) -zero ≟ zero = yes refl -zero ≟ suc y = no λ() -suc x ≟ zero = no λ() -suc x ≟ suc y = map′ (cong suc) suc-injective (x ≟ y) - ------------------------------------------------------------------------- --- Structures - -≡-isDecEquivalence : IsDecEquivalence {A = Fin n} _≡_ -≡-isDecEquivalence = record - { isEquivalence = P.isEquivalence - ; _≟_ = _≟_ - } - ------------------------------------------------------------------------- --- Bundles - -≡-preorder : ℕ → Preorder _ _ _ -≡-preorder n = P.preorder (Fin n) - -≡-setoid : ℕ → Setoid _ _ -≡-setoid n = P.setoid (Fin n) - -≡-decSetoid : ℕ → DecSetoid _ _ -≡-decSetoid n = record - { isDecEquivalence = ≡-isDecEquivalence {n} - } - ------------------------------------------------------------------------- --- toℕ ------------------------------------------------------------------------- - -toℕ-injective : toℕ i ≡ toℕ j → i ≡ j -toℕ-injective {zero} {} {} _ -toℕ-injective {suc n} {zero} {zero} eq = refl -toℕ-injective {suc n} {suc i} {suc j} eq = - cong suc (toℕ-injective (cong ℕ.pred eq)) - -toℕ-strengthen : ∀ (i : Fin n) → toℕ (strengthen i) ≡ toℕ i -toℕ-strengthen zero = refl -toℕ-strengthen (suc i) = cong suc (toℕ-strengthen i) - ------------------------------------------------------------------------- --- toℕ-↑ˡ: "i" ↑ˡ n = "i" in Fin (m + n) ------------------------------------------------------------------------- - -toℕ-↑ˡ : ∀ (i : Fin m) n → toℕ (i ↑ˡ n) ≡ toℕ i -toℕ-↑ˡ zero n = refl -toℕ-↑ˡ (suc i) n = cong suc (toℕ-↑ˡ i n) - -↑ˡ-injective : ∀ n (i j : Fin m) → i ↑ˡ n ≡ j ↑ˡ n → i ≡ j -↑ˡ-injective n zero zero refl = refl -↑ˡ-injective n (suc i) (suc j) eq = - cong suc (↑ˡ-injective n i j (suc-injective eq)) - ------------------------------------------------------------------------- --- toℕ-↑ʳ: n ↑ʳ "i" = "n + i" in Fin (n + m) ------------------------------------------------------------------------- - -toℕ-↑ʳ : ∀ n (i : Fin m) → toℕ (n ↑ʳ i) ≡ n ℕ.+ toℕ i -toℕ-↑ʳ zero i = refl -toℕ-↑ʳ (suc n) i = cong suc (toℕ-↑ʳ n i) - -↑ʳ-injective : ∀ n (i j : Fin m) → n ↑ʳ i ≡ n ↑ʳ j → i ≡ j -↑ʳ-injective zero i i refl = refl -↑ʳ-injective (suc n) i j eq = ↑ʳ-injective n i j (suc-injective eq) +open import Data.Nat.Base as ℕ + using (ℕ; zero; suc; s≤s; z≤n; z<s; s<s; s<s⁻¹; _∸_; _^_) +import Data.Nat.Properties as ℕₚ +open import Data.Nat.Solver +open import Data.Unit using (⊤; tt) +open import Data.Product.Base as Prod + using (∃; ∃₂; _×_; _,_; map; proj₁; proj₂; uncurry; <_,_>) +open import Data.Product.Properties using (,-injective) +open import Data.Product.Algebra using (×-cong) +open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂; [_,_]; [_,_]′) +open import Data.Sum.Properties using ([,]-map; [,]-∘) +open import Function.Base using (_∘_; id; _$_; flip) +open import Function.Bundles using (Injection; _↣_; _⇔_; _↔_; mk⇔; mk↔ₛ′) +open import Function.Definitions using (Injective; Surjective) +open import Function.Consequences.Propositional using (contraInjective) +open import Function.Construct.Composition as Comp hiding (injective) +open import Level using (Level) +open import Relation.Binary.Definitions as B hiding (Decidable) +open import Relation.Binary.Core using (_⇒_; _Preserves_⟶_) +open import Relation.Binary.Bundles + using (Preorder; Setoid; DecSetoid; Poset; TotalOrder; DecTotalOrder; StrictPartialOrder; StrictTotalOrder) +open import Relation.Binary.Structures + using (IsDecEquivalence; IsPreorder; IsPartialOrder; IsTotalOrder; IsDecTotalOrder; IsStrictPartialOrder; IsStrictTotalOrder) +open import Relation.Binary.PropositionalEquality as P + using (_≡_; _≢_; refl; sym; trans; cong; cong₂; subst; _≗_; module ≡-Reasoning) +open import Relation.Nullary.Decidable as Dec + using (Dec; _because_; yes; no; _×-dec_; _⊎-dec_; map′) +open import Relation.Nullary.Negation.Core using (¬_; contradiction) +open import Relation.Nullary.Reflects using (Reflects; invert) +open import Relation.Unary as U + using (U; Pred; Decidable; _⊆_; Satisfiable; Universal) +open import Relation.Unary.Properties using (U?) + +private + variable + a : Level + A : Set a + m n o : ℕ + i j : Fin n + +------------------------------------------------------------------------ +-- Fin +------------------------------------------------------------------------ + +¬Fin0 : ¬ Fin 0 +¬Fin0 () + +------------------------------------------------------------------------ +-- Bundles + +0↔⊥ : Fin 0 ↔ ⊥ +0↔⊥ = mk↔ₛ′ ¬Fin0 (λ ()) (λ ()) (λ ()) + +1↔⊤ : Fin 1 ↔ ⊤ +1↔⊤ = mk↔ₛ′ (λ { 0F → tt }) (λ { tt → 0F }) (λ { tt → refl }) λ { 0F → refl } + +2↔Bool : Fin 2 ↔ Bool +2↔Bool = mk↔ₛ′ (λ { 0F → false; 1F → true }) (λ { false → 0F ; true → 1F }) + (λ { false → refl ; true → refl }) (λ { 0F → refl ; 1F → refl }) + +------------------------------------------------------------------------ +-- Properties of _≡_ +------------------------------------------------------------------------ + +0≢1+n : zero ≢ Fin.suc i +0≢1+n () + +suc-injective : Fin.suc i ≡ suc j → i ≡ j +suc-injective refl = refl + +infix 4 _≟_ + +_≟_ : DecidableEquality (Fin n) +zero ≟ zero = yes refl +zero ≟ suc y = no λ() +suc x ≟ zero = no λ() +suc x ≟ suc y = map′ (cong suc) suc-injective (x ≟ y) + +------------------------------------------------------------------------ +-- Structures + +≡-isDecEquivalence : IsDecEquivalence {A = Fin n} _≡_ +≡-isDecEquivalence = record + { isEquivalence = P.isEquivalence + ; _≟_ = _≟_ + } + +------------------------------------------------------------------------ +-- Bundles + +≡-preorder : ℕ → Preorder _ _ _ +≡-preorder n = P.preorder (Fin n) + +≡-setoid : ℕ → Setoid _ _ +≡-setoid n = P.setoid (Fin n) + +≡-decSetoid : ℕ → DecSetoid _ _ +≡-decSetoid n = record + { isDecEquivalence = ≡-isDecEquivalence {n} + } + +------------------------------------------------------------------------ +-- toℕ +------------------------------------------------------------------------ + +toℕ-injective : toℕ i ≡ toℕ j → i ≡ j +toℕ-injective {zero} {} {} _ +toℕ-injective {suc n} {zero} {zero} eq = refl +toℕ-injective {suc n} {suc i} {suc j} eq = + cong suc (toℕ-injective (cong ℕ.pred eq)) + +toℕ-strengthen : ∀ (i : Fin n) → toℕ (strengthen i) ≡ toℕ i +toℕ-strengthen zero = refl +toℕ-strengthen (suc i) = cong suc (toℕ-strengthen i) + +------------------------------------------------------------------------ +-- toℕ-↑ˡ: "i" ↑ˡ n = "i" in Fin (m + n) +------------------------------------------------------------------------ + +toℕ-↑ˡ : ∀ (i : Fin m) n → toℕ (i ↑ˡ n) ≡ toℕ i +toℕ-↑ˡ zero n = refl +toℕ-↑ˡ (suc i) n = cong suc (toℕ-↑ˡ i n) + +↑ˡ-injective : ∀ n (i j : Fin m) → i ↑ˡ n ≡ j ↑ˡ n → i ≡ j +↑ˡ-injective n zero zero refl = refl +↑ˡ-injective n (suc i) (suc j) eq = + cong suc (↑ˡ-injective n i j (suc-injective eq)) + +------------------------------------------------------------------------ +-- toℕ-↑ʳ: n ↑ʳ "i" = "n + i" in Fin (n + m) +------------------------------------------------------------------------ + +toℕ-↑ʳ : ∀ n (i : Fin m) → toℕ (n ↑ʳ i) ≡ n ℕ.+ toℕ i +toℕ-↑ʳ zero i = refl +toℕ-↑ʳ (suc n) i = cong suc (toℕ-↑ʳ n i) + +↑ʳ-injective : ∀ n (i j : Fin m) → n ↑ʳ i ≡ n ↑ʳ j → i ≡ j +↑ʳ-injective zero i i refl = refl +↑ʳ-injective (suc n) i j eq = ↑ʳ-injective n i j (suc-injective eq) ------------------------------------------------------------------------- --- toℕ and the ordering relations ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- toℕ and the ordering relations +------------------------------------------------------------------------ -toℕ≤pred[n] : ∀ (i : Fin n) → toℕ i ℕ.≤ ℕ.pred n -toℕ≤pred[n] zero = z≤n -toℕ≤pred[n] (suc {n = suc n} i) = s≤s (toℕ≤pred[n] i) - -toℕ≤n : ∀ (i : Fin n) → toℕ i ℕ.≤ n -toℕ≤n {suc n} i = ℕₚ.m≤n⇒m≤1+n (toℕ≤pred[n] i) - -toℕ<n : ∀ (i : Fin n) → toℕ i ℕ.< n -toℕ<n {suc n} i = s<s (toℕ≤pred[n] i) - --- A simpler implementation of toℕ≤pred[n], --- however, with a different reduction behavior. --- If no one needs the reduction behavior of toℕ≤pred[n], --- it can be removed in favor of toℕ≤pred[n]′. -toℕ≤pred[n]′ : ∀ (i : Fin n) → toℕ i ℕ.≤ ℕ.pred n -toℕ≤pred[n]′ i = ℕₚ.<⇒≤pred (toℕ<n i) - -toℕ-mono-< : i < j → toℕ i ℕ.< toℕ j -toℕ-mono-< i<j = i<j - -toℕ-mono-≤ : i ≤ j → toℕ i ℕ.≤ toℕ j -toℕ-mono-≤ i≤j = i≤j - -toℕ-cancel-≤ : toℕ i ℕ.≤ toℕ j → i ≤ j -toℕ-cancel-≤ i≤j = i≤j - -toℕ-cancel-< : toℕ i ℕ.< toℕ j → i < j -toℕ-cancel-< i<j = i<j - ------------------------------------------------------------------------- --- fromℕ ------------------------------------------------------------------------- - -toℕ-fromℕ : ∀ n → toℕ (fromℕ n) ≡ n -toℕ-fromℕ zero = refl -toℕ-fromℕ (suc n) = cong suc (toℕ-fromℕ n) +toℕ<n : ∀ (i : Fin n) → toℕ i ℕ.< n +toℕ<n {n = suc _} zero = z<s +toℕ<n {n = suc _} (suc i) = s<s (toℕ<n i) + +toℕ≤pred[n] : ∀ (i : Fin n) → toℕ i ℕ.≤ ℕ.pred n +toℕ≤pred[n] zero = z≤n +toℕ≤pred[n] (suc {n = suc n} i) = s≤s (toℕ≤pred[n] i) + +toℕ≤n : ∀ (i : Fin n) → toℕ i ℕ.≤ n +toℕ≤n {suc n} i = ℕₚ.m≤n⇒m≤1+n (toℕ≤pred[n] i) + +-- A simpler implementation of toℕ≤pred[n], +-- however, with a different reduction behavior. +-- If no one needs the reduction behavior of toℕ≤pred[n], +-- it can be removed in favor of toℕ≤pred[n]′. +toℕ≤pred[n]′ : ∀ (i : Fin n) → toℕ i ℕ.≤ ℕ.pred n +toℕ≤pred[n]′ i = ℕₚ.<⇒≤pred (toℕ<n i) + +toℕ-mono-< : i < j → toℕ i ℕ.< toℕ j +toℕ-mono-< i<j = i<j + +toℕ-mono-≤ : i ≤ j → toℕ i ℕ.≤ toℕ j +toℕ-mono-≤ i≤j = i≤j + +toℕ-cancel-≤ : toℕ i ℕ.≤ toℕ j → i ≤ j +toℕ-cancel-≤ i≤j = i≤j + +toℕ-cancel-< : toℕ i ℕ.< toℕ j → i < j +toℕ-cancel-< i<j = i<j + +------------------------------------------------------------------------ +-- fromℕ +------------------------------------------------------------------------ + +toℕ-fromℕ : ∀ n → toℕ (fromℕ n) ≡ n +toℕ-fromℕ zero = refl +toℕ-fromℕ (suc n) = cong suc (toℕ-fromℕ n) + +fromℕ-toℕ : ∀ (i : Fin n) → fromℕ (toℕ i) ≡ strengthen i +fromℕ-toℕ zero = refl +fromℕ-toℕ (suc i) = cong suc (fromℕ-toℕ i) -fromℕ-toℕ : ∀ (i : Fin n) → fromℕ (toℕ i) ≡ strengthen i -fromℕ-toℕ zero = refl -fromℕ-toℕ (suc i) = cong suc (fromℕ-toℕ i) +≤fromℕ : ∀ (i : Fin (suc n)) → i ≤ fromℕ n +≤fromℕ {n = n} i rewrite toℕ-fromℕ n = ℕ.s≤s⁻¹ (toℕ<n i) -≤fromℕ : ∀ (i : Fin (ℕ.suc n)) → i ≤ fromℕ n -≤fromℕ i = subst (toℕ i ℕ.≤_) (sym (toℕ-fromℕ _)) (toℕ≤pred[n] i) +------------------------------------------------------------------------ +-- fromℕ< +------------------------------------------------------------------------ ------------------------------------------------------------------------- --- fromℕ< ------------------------------------------------------------------------- +fromℕ<-toℕ : ∀ (i : Fin n) .(i<n : toℕ i ℕ.< n) → fromℕ< i<n ≡ i +fromℕ<-toℕ zero _ = refl +fromℕ<-toℕ (suc i) i<n = cong suc (fromℕ<-toℕ i (ℕ.s<s⁻¹ i<n)) + +toℕ-fromℕ< : ∀ .(m<n : m ℕ.< n) → toℕ (fromℕ< m<n) ≡ m +toℕ-fromℕ< {m = zero} {n = suc _} _ = refl +toℕ-fromℕ< {m = suc m} {n = suc _} m<n = cong suc (toℕ-fromℕ< (ℕ.s<s⁻¹ m<n)) + +-- fromℕ is a special case of fromℕ<. +fromℕ-def : ∀ n → fromℕ n ≡ fromℕ< ℕₚ.≤-refl +fromℕ-def zero = refl +fromℕ-def (suc n) = cong suc (fromℕ-def n) + +fromℕ<-cong : ∀ m n {o} → m ≡ n → .(m<o : m ℕ.< o) .(n<o : n ℕ.< o) → + fromℕ< m<o ≡ fromℕ< n<o +fromℕ<-cong 0 0 _ _ _ = refl +fromℕ<-cong (suc _) (suc _) {o = suc _} r m<n n<o + = cong suc (fromℕ<-cong _ _ (ℕₚ.suc-injective r) (ℕ.s<s⁻¹ m<n) (ℕ.s<s⁻¹ n<o)) + +fromℕ<-injective : ∀ m n {o} → .(m<o : m ℕ.< o) .(n<o : n ℕ.< o) → + fromℕ< m<o ≡ fromℕ< n<o → m ≡ n +fromℕ<-injective 0 0 _ _ _ = refl +fromℕ<-injective 0 (suc _) {o = suc _} _ _ () +fromℕ<-injective (suc _) (suc _) {o = suc _} m<n n<o r + = cong suc (fromℕ<-injective _ _ (ℕ.s<s⁻¹ m<n) (ℕ.s<s⁻¹ n<o) (suc-injective r)) + +------------------------------------------------------------------------ +-- fromℕ<″ +------------------------------------------------------------------------ + +fromℕ<≡fromℕ<″ : ∀ (m<n : m ℕ.< n) (m<″n : m ℕ.<″ n) → + fromℕ< m<n ≡ fromℕ<″ m m<″n +fromℕ<≡fromℕ<″ {m = zero} m<n (ℕ.<″-offset _) = refl +fromℕ<≡fromℕ<″ {m = suc m} m<n (ℕ.<″-offset _) + = cong suc (fromℕ<≡fromℕ<″ (ℕ.s<s⁻¹ m<n) (ℕ.<″-offset _)) + +toℕ-fromℕ<″ : ∀ (m<n : m ℕ.<″ n) → toℕ (fromℕ<″ m m<n) ≡ m +toℕ-fromℕ<″ {m} {n} m<n = begin + toℕ (fromℕ<″ m m<n) ≡⟨ cong toℕ (sym (fromℕ<≡fromℕ<″ (ℕₚ.≤″⇒≤ m<n) m<n)) ⟩ + toℕ (fromℕ< _) ≡⟨ toℕ-fromℕ< (ℕₚ.≤″⇒≤ m<n) ⟩ + m ∎ + where open ≡-Reasoning + +------------------------------------------------------------------------ +-- Properties of cast +------------------------------------------------------------------------ + +toℕ-cast : ∀ .(eq : m ≡ n) (k : Fin m) → toℕ (cast eq k) ≡ toℕ k +toℕ-cast {n = suc n} eq zero = refl +toℕ-cast {n = suc n} eq (suc k) = cong suc (toℕ-cast (cong ℕ.pred eq) k) + +cast-is-id : .(eq : m ≡ m) (k : Fin m) → cast eq k ≡ k +cast-is-id eq zero = refl +cast-is-id eq (suc k) = cong suc (cast-is-id (ℕₚ.suc-injective eq) k) + +subst-is-cast : (eq : m ≡ n) (k : Fin m) → subst Fin eq k ≡ cast eq k +subst-is-cast refl k = sym (cast-is-id refl k) + +cast-trans : .(eq₁ : m ≡ n) .(eq₂ : n ≡ o) (k : Fin m) → + cast eq₂ (cast eq₁ k) ≡ cast (trans eq₁ eq₂) k +cast-trans {m = suc _} {n = suc _} {o = suc _} eq₁ eq₂ zero = refl +cast-trans {m = suc _} {n = suc _} {o = suc _} eq₁ eq₂ (suc k) = + cong suc (cast-trans (ℕₚ.suc-injective eq₁) (ℕₚ.suc-injective eq₂) k) + +------------------------------------------------------------------------ +-- Properties of _≤_ +------------------------------------------------------------------------ +-- Relational properties + +≤-reflexive : _≡_ ⇒ (_≤_ {n}) +≤-reflexive refl = ℕₚ.≤-refl + +≤-refl : Reflexive (_≤_ {n}) +≤-refl = ≤-reflexive refl + +≤-trans : Transitive (_≤_ {n}) +≤-trans = ℕₚ.≤-trans + +≤-antisym : Antisymmetric _≡_ (_≤_ {n}) +≤-antisym x≤y y≤x = toℕ-injective (ℕₚ.≤-antisym x≤y y≤x) + +≤-total : Total (_≤_ {n}) +≤-total x y = ℕₚ.≤-total (toℕ x) (toℕ y) + +≤-irrelevant : Irrelevant (_≤_ {m} {n}) +≤-irrelevant = ℕₚ.≤-irrelevant + +infix 4 _≤?_ _<?_ + +_≤?_ : B.Decidable (_≤_ {m} {n}) +a ≤? b = toℕ a ℕₚ.≤? toℕ b + +_<?_ : B.Decidable (_<_ {m} {n}) +m <? n = suc (toℕ m) ℕₚ.≤? toℕ n + +------------------------------------------------------------------------ +-- Structures + +≤-isPreorder : IsPreorder {A = Fin n} _≡_ _≤_ +≤-isPreorder = record + { isEquivalence = P.isEquivalence + ; reflexive = ≤-reflexive + ; trans = ≤-trans + } + +≤-isPartialOrder : IsPartialOrder {A = Fin n} _≡_ _≤_ +≤-isPartialOrder = record + { isPreorder = ≤-isPreorder + ; antisym = ≤-antisym + } + +≤-isTotalOrder : IsTotalOrder {A = Fin n} _≡_ _≤_ +≤-isTotalOrder = record + { isPartialOrder = ≤-isPartialOrder + ; total = ≤-total + } + +≤-isDecTotalOrder : IsDecTotalOrder {A = Fin n} _≡_ _≤_ +≤-isDecTotalOrder = record + { isTotalOrder = ≤-isTotalOrder + ; _≟_ = _≟_ + ; _≤?_ = _≤?_ + } + +------------------------------------------------------------------------ +-- Bundles + +≤-preorder : ℕ → Preorder _ _ _ +≤-preorder n = record + { isPreorder = ≤-isPreorder {n} + } + +≤-poset : ℕ → Poset _ _ _ +≤-poset n = record + { isPartialOrder = ≤-isPartialOrder {n} + } + +≤-totalOrder : ℕ → TotalOrder _ _ _ +≤-totalOrder n = record + { isTotalOrder = ≤-isTotalOrder {n} + } + +≤-decTotalOrder : ℕ → DecTotalOrder _ _ _ +≤-decTotalOrder n = record + { isDecTotalOrder = ≤-isDecTotalOrder {n} + } + +------------------------------------------------------------------------ +-- Properties of _<_ +------------------------------------------------------------------------ +-- Relational properties + +<-irrefl : Irreflexive _≡_ (_<_ {n}) +<-irrefl refl = ℕₚ.<-irrefl refl + +<-asym : Asymmetric (_<_ {n}) +<-asym = ℕₚ.<-asym + +<-trans : Transitive (_<_ {n}) +<-trans = ℕₚ.<-trans + +<-cmp : Trichotomous _≡_ (_<_ {n}) +<-cmp zero zero = tri≈ (λ()) refl (λ()) +<-cmp zero (suc j) = tri< z<s (λ()) (λ()) +<-cmp (suc i) zero = tri> (λ()) (λ()) z<s +<-cmp (suc i) (suc j) with <-cmp i j +... | tri< i<j i≢j j≮i = tri< (s<s i<j) (i≢j ∘ suc-injective) (j≮i ∘ s<s⁻¹) +... | tri> i≮j i≢j j<i = tri> (i≮j ∘ s<s⁻¹) (i≢j ∘ suc-injective) (s<s j<i) +... | tri≈ i≮j i≡j j≮i = tri≈ (i≮j ∘ s<s⁻¹) (cong suc i≡j) (j≮i ∘ s<s⁻¹) -fromℕ<-toℕ : ∀ (i : Fin n) (i<n : toℕ i ℕ.< n) → fromℕ< i<n ≡ i -fromℕ<-toℕ zero z<s = refl -fromℕ<-toℕ (suc i) (s<s i<n) = cong suc (fromℕ<-toℕ i i<n) - -toℕ-fromℕ< : ∀ (m<n : m ℕ.< n) → toℕ (fromℕ< m<n) ≡ m -toℕ-fromℕ< z<s = refl -toℕ-fromℕ< (s<s m<n@(s≤s _)) = cong suc (toℕ-fromℕ< m<n) - --- fromℕ is a special case of fromℕ<. -fromℕ-def : ∀ n → fromℕ n ≡ fromℕ< ℕₚ.≤-refl -fromℕ-def zero = refl -fromℕ-def (suc n) = cong suc (fromℕ-def n) - -fromℕ<-cong : ∀ m n {o} → m ≡ n → (m<o : m ℕ.< o) (n<o : n ℕ.< o) → - fromℕ< m<o ≡ fromℕ< n<o -fromℕ<-cong 0 0 r z<s z<s = refl -fromℕ<-cong (suc _) (suc _) r (s<s m<n) (s<s n<o) - = cong suc (fromℕ<-cong _ _ (ℕₚ.suc-injective r) m<n n<o) - -fromℕ<-injective : ∀ m n {o} → (m<o : m ℕ.< o) (n<o : n ℕ.< o) → - fromℕ< m<o ≡ fromℕ< n<o → m ≡ n -fromℕ<-injective 0 0 z<s z<s r = refl -fromℕ<-injective (suc _) (suc _) (s<s m<n@(s≤s _)) (s<s n<o@(s≤s _)) r - = cong suc (fromℕ<-injective _ _ m<n n<o (suc-injective r)) - ------------------------------------------------------------------------- --- fromℕ<″ ------------------------------------------------------------------------- - -fromℕ<≡fromℕ<″ : ∀ (m<n : m ℕ.< n) (m<″n : m ℕ.<″ n) → - fromℕ< m<n ≡ fromℕ<″ m m<″n -fromℕ<≡fromℕ<″ z<s (ℕ.less-than-or-equal refl) = refl -fromℕ<≡fromℕ<″ (s<s m<n@(s≤s _)) (ℕ.less-than-or-equal refl) = - cong suc (fromℕ<≡fromℕ<″ m<n (ℕ.less-than-or-equal refl)) - -toℕ-fromℕ<″ : ∀ (m<n : m ℕ.<″ n) → toℕ (fromℕ<″ m m<n) ≡ m -toℕ-fromℕ<″ {m} {n} m<n = begin - toℕ (fromℕ<″ m m<n) ≡⟨ cong toℕ (sym (fromℕ<≡fromℕ<″ (ℕₚ.≤″⇒≤ m<n) m<n)) ⟩ - toℕ (fromℕ< _) ≡⟨ toℕ-fromℕ< (ℕₚ.≤″⇒≤ m<n) ⟩ - m ∎ - where open ≡-Reasoning - ------------------------------------------------------------------------- --- Properties of cast ------------------------------------------------------------------------- - -toℕ-cast : ∀ .(eq : m ≡ n) (k : Fin m) → toℕ (cast eq k) ≡ toℕ k -toℕ-cast {n = suc n} eq zero = refl -toℕ-cast {n = suc n} eq (suc k) = cong suc (toℕ-cast (cong ℕ.pred eq) k) - -cast-is-id : .(eq : m ≡ m) (k : Fin m) → cast eq k ≡ k -cast-is-id eq zero = refl -cast-is-id eq (suc k) = cong suc (cast-is-id (ℕₚ.suc-injective eq) k) - -subst-is-cast : (eq : m ≡ n) (k : Fin m) → subst Fin eq k ≡ cast eq k -subst-is-cast refl k = sym (cast-is-id refl k) - -cast-trans : .(eq₁ : m ≡ n) (eq₂ : n ≡ o) (k : Fin m) → - cast eq₂ (cast eq₁ k) ≡ cast (trans eq₁ eq₂) k -cast-trans {m = suc _} {n = suc _} {o = suc _} eq₁ eq₂ zero = refl -cast-trans {m = suc _} {n = suc _} {o = suc _} eq₁ eq₂ (suc k) = - cong suc (cast-trans (ℕₚ.suc-injective eq₁) (ℕₚ.suc-injective eq₂) k) - ------------------------------------------------------------------------- --- Properties of _≤_ ------------------------------------------------------------------------- --- Relational properties - -≤-reflexive : _≡_ ⇒ (_≤_ {n}) -≤-reflexive refl = ℕₚ.≤-refl - -≤-refl : Reflexive (_≤_ {n}) -≤-refl = ≤-reflexive refl - -≤-trans : Transitive (_≤_ {n}) -≤-trans = ℕₚ.≤-trans - -≤-antisym : Antisymmetric _≡_ (_≤_ {n}) -≤-antisym x≤y y≤x = toℕ-injective (ℕₚ.≤-antisym x≤y y≤x) - -≤-total : Total (_≤_ {n}) -≤-total x y = ℕₚ.≤-total (toℕ x) (toℕ y) - -≤-irrelevant : Irrelevant (_≤_ {m} {n}) -≤-irrelevant = ℕₚ.≤-irrelevant - -infix 4 _≤?_ _<?_ - -_≤?_ : B.Decidable (_≤_ {m} {n}) -a ≤? b = toℕ a ℕₚ.≤? toℕ b - -_<?_ : B.Decidable (_<_ {m} {n}) -m <? n = suc (toℕ m) ℕₚ.≤? toℕ n - ------------------------------------------------------------------------- --- Structures - -≤-isPreorder : IsPreorder {A = Fin n} _≡_ _≤_ -≤-isPreorder = record - { isEquivalence = P.isEquivalence - ; reflexive = ≤-reflexive - ; trans = ≤-trans - } - -≤-isPartialOrder : IsPartialOrder {A = Fin n} _≡_ _≤_ -≤-isPartialOrder = record - { isPreorder = ≤-isPreorder - ; antisym = ≤-antisym - } - -≤-isTotalOrder : IsTotalOrder {A = Fin n} _≡_ _≤_ -≤-isTotalOrder = record - { isPartialOrder = ≤-isPartialOrder - ; total = ≤-total - } - -≤-isDecTotalOrder : IsDecTotalOrder {A = Fin n} _≡_ _≤_ -≤-isDecTotalOrder = record - { isTotalOrder = ≤-isTotalOrder - ; _≟_ = _≟_ - ; _≤?_ = _≤?_ - } - ------------------------------------------------------------------------- --- Bundles - -≤-preorder : ℕ → Preorder _ _ _ -≤-preorder n = record - { isPreorder = ≤-isPreorder {n} - } - -≤-poset : ℕ → Poset _ _ _ -≤-poset n = record - { isPartialOrder = ≤-isPartialOrder {n} - } - -≤-totalOrder : ℕ → TotalOrder _ _ _ -≤-totalOrder n = record - { isTotalOrder = ≤-isTotalOrder {n} - } - -≤-decTotalOrder : ℕ → DecTotalOrder _ _ _ -≤-decTotalOrder n = record - { isDecTotalOrder = ≤-isDecTotalOrder {n} - } - ------------------------------------------------------------------------- --- Properties of _<_ ------------------------------------------------------------------------- --- Relational properties - -<-irrefl : Irreflexive _≡_ (_<_ {n}) -<-irrefl refl = ℕₚ.<-irrefl refl - -<-asym : Asymmetric (_<_ {n}) -<-asym = ℕₚ.<-asym - -<-trans : Transitive (_<_ {n}) -<-trans = ℕₚ.<-trans - -<-cmp : Trichotomous _≡_ (_<_ {n}) -<-cmp zero zero = tri≈ (λ()) refl (λ()) -<-cmp zero (suc j) = tri< z<s (λ()) (λ()) -<-cmp (suc i) zero = tri> (λ()) (λ()) z<s -<-cmp (suc i) (suc j) with <-cmp i j -... | tri< i<j i≢j j≮i = tri< (s<s i<j) (i≢j ∘ suc-injective) (j≮i ∘ ℕₚ.≤-pred) -... | tri> i≮j i≢j j<i = tri> (i≮j ∘ ℕₚ.≤-pred) (i≢j ∘ suc-injective) (s<s j<i) -... | tri≈ i≮j i≡j j≮i = tri≈ (i≮j ∘ ℕₚ.≤-pred) (cong suc i≡j) (j≮i ∘ ℕₚ.≤-pred) - -<-respˡ-≡ : (_<_ {m} {n}) Respectsˡ _≡_ -<-respˡ-≡ refl x≤y = x≤y - -<-respʳ-≡ : (_<_ {m} {n}) Respectsʳ _≡_ -<-respʳ-≡ refl x≤y = x≤y - -<-resp₂-≡ : (_<_ {n}) Respects₂ _≡_ -<-resp₂-≡ = <-respʳ-≡ , <-respˡ-≡ - -<-irrelevant : Irrelevant (_<_ {m} {n}) -<-irrelevant = ℕₚ.<-irrelevant - ------------------------------------------------------------------------- --- Structures - -<-isStrictPartialOrder : IsStrictPartialOrder {A = Fin n} _≡_ _<_ -<-isStrictPartialOrder = record - { isEquivalence = P.isEquivalence - ; irrefl = <-irrefl - ; trans = <-trans - ; <-resp-≈ = <-resp₂-≡ - } - -<-isStrictTotalOrder : IsStrictTotalOrder {A = Fin n} _≡_ _<_ -<-isStrictTotalOrder = record - { isEquivalence = P.isEquivalence - ; trans = <-trans - ; compare = <-cmp - } - ------------------------------------------------------------------------- --- Bundles - -<-strictPartialOrder : ℕ → StrictPartialOrder _ _ _ -<-strictPartialOrder n = record - { isStrictPartialOrder = <-isStrictPartialOrder {n} - } - -<-strictTotalOrder : ℕ → StrictTotalOrder _ _ _ -<-strictTotalOrder n = record - { isStrictTotalOrder = <-isStrictTotalOrder {n} - } - ------------------------------------------------------------------------- --- Other properties - -i<1+i : ∀ (i : Fin n) → i < suc i -i<1+i = ℕₚ.n<1+n ∘ toℕ - -<⇒≢ : i < j → i ≢ j -<⇒≢ i<i refl = ℕₚ.n≮n _ i<i - -≤∧≢⇒< : i ≤ j → i ≢ j → i < j -≤∧≢⇒< {i = zero} {zero} _ 0≢0 = contradiction refl 0≢0 -≤∧≢⇒< {i = zero} {suc j} _ _ = z<s -≤∧≢⇒< {i = suc i} {suc j} (s≤s i≤j) 1+i≢1+j = - s<s (≤∧≢⇒< i≤j (1+i≢1+j ∘ (cong suc))) - ------------------------------------------------------------------------- --- inject ------------------------------------------------------------------------- - -toℕ-inject : ∀ {i : Fin n} (j : Fin′ i) → toℕ (inject j) ≡ toℕ j -toℕ-inject {i = suc i} zero = refl -toℕ-inject {i = suc i} (suc j) = cong suc (toℕ-inject j) - ------------------------------------------------------------------------- --- inject₁ ------------------------------------------------------------------------- - -inject₁-injective : inject₁ i ≡ inject₁ j → i ≡ j -inject₁-injective {i = zero} {zero} i≡j = refl -inject₁-injective {i = suc i} {suc j} i≡j = - cong suc (inject₁-injective (suc-injective i≡j)) - -toℕ-inject₁ : ∀ (i : Fin n) → toℕ (inject₁ i) ≡ toℕ i -toℕ-inject₁ zero = refl -toℕ-inject₁ (suc i) = cong suc (toℕ-inject₁ i) - -toℕ-inject₁-≢ : ∀ (i : Fin n) → n ≢ toℕ (inject₁ i) -toℕ-inject₁-≢ (suc i) = toℕ-inject₁-≢ i ∘ ℕₚ.suc-injective - -inject₁ℕ< : ∀ (i : Fin n) → toℕ (inject₁ i) ℕ.< n -inject₁ℕ< i rewrite toℕ-inject₁ i = toℕ<n i - -inject₁ℕ≤ : ∀ (i : Fin n) → toℕ (inject₁ i) ℕ.≤ n -inject₁ℕ≤ = ℕₚ.<⇒≤ ∘ inject₁ℕ< - -≤̄⇒inject₁< : i ≤ j → inject₁ i < suc j -≤̄⇒inject₁< {i = i} i≤j rewrite sym (toℕ-inject₁ i) = s<s i≤j - -ℕ<⇒inject₁< : ∀ {i : Fin (ℕ.suc n)} {j : Fin n} → j < i → inject₁ j < i -ℕ<⇒inject₁< {i = suc i} (s≤s j≤i) = ≤̄⇒inject₁< j≤i - -i≤inject₁[j]⇒i≤1+j : i ≤ inject₁ j → i ≤ suc j -i≤inject₁[j]⇒i≤1+j {i = zero} i≤j = z≤n -i≤inject₁[j]⇒i≤1+j {i = suc i} {j = suc j} (s≤s i≤j) = s≤s (ℕₚ.m≤n⇒m≤1+n (subst (toℕ i ℕ.≤_) (toℕ-inject₁ j) i≤j)) - ------------------------------------------------------------------------- --- lower₁ ------------------------------------------------------------------------- - -toℕ-lower₁ : ∀ i (p : n ≢ toℕ i) → toℕ (lower₁ i p) ≡ toℕ i -toℕ-lower₁ {ℕ.zero} zero p = contradiction refl p -toℕ-lower₁ {ℕ.suc m} zero p = refl -toℕ-lower₁ {ℕ.suc m} (suc i) p = cong ℕ.suc (toℕ-lower₁ i (p ∘ cong ℕ.suc)) - -lower₁-injective : ∀ {n≢i : n ≢ toℕ i} {n≢j : n ≢ toℕ j} → - lower₁ i n≢i ≡ lower₁ j n≢j → i ≡ j -lower₁-injective {zero} {zero} {_} {n≢i} {_} _ = ⊥-elim (n≢i refl) -lower₁-injective {zero} {_} {zero} {_} {n≢j} _ = ⊥-elim (n≢j refl) -lower₁-injective {suc n} {zero} {zero} {_} {_} refl = refl -lower₁-injective {suc n} {suc i} {suc j} {n≢i} {n≢j} eq = - cong suc (lower₁-injective (suc-injective eq)) - ------------------------------------------------------------------------- --- inject₁ and lower₁ - -inject₁-lower₁ : ∀ (i : Fin (suc n)) (n≢i : n ≢ toℕ i) → - inject₁ (lower₁ i n≢i) ≡ i -inject₁-lower₁ {zero} zero 0≢0 = contradiction refl 0≢0 -inject₁-lower₁ {suc n} zero _ = refl -inject₁-lower₁ {suc n} (suc i) n+1≢i+1 = - cong suc (inject₁-lower₁ i (n+1≢i+1 ∘ cong suc)) - -lower₁-inject₁′ : ∀ (i : Fin n) (n≢i : n ≢ toℕ (inject₁ i)) → - lower₁ (inject₁ i) n≢i ≡ i -lower₁-inject₁′ zero _ = refl -lower₁-inject₁′ (suc i) n+1≢i+1 = - cong suc (lower₁-inject₁′ i (n+1≢i+1 ∘ cong suc)) - -lower₁-inject₁ : ∀ (i : Fin n) → - lower₁ (inject₁ i) (toℕ-inject₁-≢ i) ≡ i -lower₁-inject₁ i = lower₁-inject₁′ i (toℕ-inject₁-≢ i) - -lower₁-irrelevant : ∀ (i : Fin (suc n)) (n≢i₁ n≢i₂ : n ≢ toℕ i) → - lower₁ i n≢i₁ ≡ lower₁ i n≢i₂ -lower₁-irrelevant {zero} zero 0≢0 _ = contradiction refl 0≢0 -lower₁-irrelevant {suc n} zero _ _ = refl -lower₁-irrelevant {suc n} (suc i) _ _ = - cong suc (lower₁-irrelevant i _ _) - -inject₁≡⇒lower₁≡ : ∀ {i : Fin n} {j : Fin (ℕ.suc n)} → - (n≢j : n ≢ toℕ j) → inject₁ i ≡ j → lower₁ j n≢j ≡ i -inject₁≡⇒lower₁≡ n≢j i≡j = inject₁-injective (trans (inject₁-lower₁ _ n≢j) (sym i≡j)) - ------------------------------------------------------------------------- --- inject≤ ------------------------------------------------------------------------- - -toℕ-inject≤ : ∀ i (m≤n : m ℕ.≤ n) → toℕ (inject≤ i m≤n) ≡ toℕ i -toℕ-inject≤ {_} {suc n} zero _ = refl -toℕ-inject≤ {_} {suc n} (suc i) (s≤s m≤n) = cong suc (toℕ-inject≤ i m≤n) - -inject≤-refl : ∀ i (n≤n : n ℕ.≤ n) → inject≤ i n≤n ≡ i -inject≤-refl {suc n} zero _ = refl -inject≤-refl {suc n} (suc i) (s≤s n≤n) = cong suc (inject≤-refl i n≤n) - -inject≤-idempotent : ∀ (i : Fin m) - (m≤n : m ℕ.≤ n) (n≤o : n ℕ.≤ o) (m≤o : m ℕ.≤ o) → - inject≤ (inject≤ i m≤n) n≤o ≡ inject≤ i m≤o -inject≤-idempotent {_} {suc n} {suc o} zero _ _ _ = refl -inject≤-idempotent {_} {suc n} {suc o} (suc i) (s≤s m≤n) (s≤s n≤o) (s≤s m≤o) = - cong suc (inject≤-idempotent i m≤n n≤o m≤o) - -inject≤-injective : ∀ (m≤n m≤n′ : m ℕ.≤ n) i j → - inject≤ i m≤n ≡ inject≤ j m≤n′ → i ≡ j -inject≤-injective (s≤s p) (s≤s q) zero zero eq = refl -inject≤-injective (s≤s p) (s≤s q) (suc i) (suc j) eq = - cong suc (inject≤-injective p q i j (suc-injective eq)) - ------------------------------------------------------------------------- --- pred ------------------------------------------------------------------------- - -pred< : ∀ (i : Fin (suc n)) → i ≢ zero → pred i < i -pred< zero i≢0 = contradiction refl i≢0 -pred< (suc i) _ = ≤̄⇒inject₁< ℕₚ.≤-refl - ------------------------------------------------------------------------- --- splitAt ------------------------------------------------------------------------- - --- Fin (m + n) ↔ Fin m ⊎ Fin n - -splitAt-↑ˡ : ∀ m i n → splitAt m (i ↑ˡ n) ≡ inj₁ i -splitAt-↑ˡ (suc m) zero n = refl -splitAt-↑ˡ (suc m) (suc i) n rewrite splitAt-↑ˡ m i n = refl - -splitAt-↑ʳ : ∀ m n i → splitAt m (m ↑ʳ i) ≡ inj₂ {B = Fin n} i -splitAt-↑ʳ zero n i = refl -splitAt-↑ʳ (suc m) n i rewrite splitAt-↑ʳ m n i = refl - -splitAt-join : ∀ m n i → splitAt m (join m n i) ≡ i -splitAt-join m n (inj₁ x) = splitAt-↑ˡ m x n -splitAt-join m n (inj₂ y) = splitAt-↑ʳ m n y - -join-splitAt : ∀ m n i → join m n (splitAt m i) ≡ i -join-splitAt zero n i = refl -join-splitAt (suc m) n zero = refl -join-splitAt (suc m) n (suc i) = begin - [ _↑ˡ n , (suc m) ↑ʳ_ ]′ (splitAt (suc m) (suc i)) ≡⟨ [,]-map (splitAt m i) ⟩ - [ suc ∘ (_↑ˡ n) , suc ∘ (m ↑ʳ_) ]′ (splitAt m i) ≡˘⟨ [,]-∘ suc (splitAt m i) ⟩ - suc ([ _↑ˡ n , m ↑ʳ_ ]′ (splitAt m i)) ≡⟨ cong suc (join-splitAt m n i) ⟩ - suc i ∎ - where open ≡-Reasoning - --- splitAt "m" "i" ≡ inj₁ "i" if i < m - -splitAt-< : ∀ m {n} (i : Fin (m ℕ.+ n)) (i<m : toℕ i ℕ.< m) → - splitAt m i ≡ inj₁ (fromℕ< i<m) -splitAt-< (suc m) zero z<s = refl -splitAt-< (suc m) (suc i) (s<s i<m) = cong (Sum.map suc id) (splitAt-< m i i<m) - --- splitAt "m" "i" ≡ inj₂ "i - m" if i ≥ m - -splitAt-≥ : ∀ m {n} (i : Fin (m ℕ.+ n)) (i≥m : toℕ i ℕ.≥ m) → - splitAt m i ≡ inj₂ (reduce≥ i i≥m) -splitAt-≥ zero i _ = refl -splitAt-≥ (suc m) (suc i) (s≤s i≥m) = cong (Sum.map suc id) (splitAt-≥ m i i≥m) - ------------------------------------------------------------------------- --- Bundles - -+↔⊎ : Fin (m ℕ.+ n) ↔ (Fin m ⊎ Fin n) -+↔⊎ {m} {n} = mk↔′ (splitAt m {n}) (join m n) (splitAt-join m n) (join-splitAt m n) - ------------------------------------------------------------------------- --- remQuot ------------------------------------------------------------------------- - --- Fin (m * n) ↔ Fin m × Fin n - -remQuot-combine : ∀ {n k} (i : Fin n) j → remQuot k (combine i j) ≡ (i , j) -remQuot-combine {suc n} {k} zero j rewrite splitAt-↑ˡ k j (n ℕ.* k) = refl -remQuot-combine {suc n} {k} (suc i) j rewrite splitAt-↑ʳ k (n ℕ.* k) (combine i j) = - cong (Data.Product.map₁ suc) (remQuot-combine i j) - -combine-remQuot : ∀ {n} k (i : Fin (n ℕ.* k)) → uncurry combine (remQuot {n} k i) ≡ i -combine-remQuot {suc n} k i with splitAt k i | P.inspect (splitAt k) i -... | inj₁ j | P.[ eq ] = begin - join k (n ℕ.* k) (inj₁ j) ≡˘⟨ cong (join k (n ℕ.* k)) eq ⟩ - join k (n ℕ.* k) (splitAt k i) ≡⟨ join-splitAt k (n ℕ.* k) i ⟩ - i ∎ - where open ≡-Reasoning -... | inj₂ j | P.[ eq ] = begin - k ↑ʳ (uncurry combine (remQuot {n} k j)) ≡⟨ cong (k ↑ʳ_) (combine-remQuot {n} k j) ⟩ - join k (n ℕ.* k) (inj₂ j) ≡˘⟨ cong (join k (n ℕ.* k)) eq ⟩ - join k (n ℕ.* k) (splitAt k i) ≡⟨ join-splitAt k (n ℕ.* k) i ⟩ - i ∎ - where open ≡-Reasoning - -toℕ-combine : ∀ (i : Fin m) (j : Fin n) → toℕ (combine i j) ≡ n ℕ.* toℕ i ℕ.+ toℕ j -toℕ-combine {suc m} {n} i@0F j = begin - toℕ (combine i j) ≡⟨⟩ - toℕ (j ↑ˡ (m ℕ.* n)) ≡⟨ toℕ-↑ˡ j (m ℕ.* n) ⟩ - toℕ j ≡⟨⟩ - 0 ℕ.+ toℕ j ≡˘⟨ cong (ℕ._+ toℕ j) (ℕₚ.*-zeroʳ n) ⟩ - n ℕ.* toℕ i ℕ.+ toℕ j ∎ - where open ≡-Reasoning -toℕ-combine {suc m} {n} (suc i) j = begin - toℕ (combine (suc i) j) ≡⟨⟩ - toℕ (n ↑ʳ combine i j) ≡⟨ toℕ-↑ʳ n (combine i j) ⟩ - n ℕ.+ toℕ (combine i j) ≡⟨ cong (n ℕ.+_) (toℕ-combine i j) ⟩ - n ℕ.+ (n ℕ.* toℕ i ℕ.+ toℕ j) ≡⟨ solve 3 (λ n i j → n :+ (n :* i :+ j) := n :* (con 1 :+ i) :+ j) refl n (toℕ i) (toℕ j) ⟩ - n ℕ.* toℕ (suc i) ℕ.+ toℕ j ∎ - where open ≡-Reasoning; open +-*-Solver - -combine-monoˡ-< : ∀ {i j : Fin m} (k l : Fin n) → - i < j → combine i k < combine j l -combine-monoˡ-< {m} {n} {i} {j} k l i<j = begin-strict - toℕ (combine i k) ≡⟨ toℕ-combine i k ⟩ - n ℕ.* toℕ i ℕ.+ toℕ k <⟨ ℕₚ.+-monoʳ-< (n ℕ.* toℕ i) (toℕ<n k) ⟩ - n ℕ.* toℕ i ℕ.+ n ≡⟨ ℕₚ.+-comm _ n ⟩ - n ℕ.+ n ℕ.* toℕ i ≡⟨ cong (n ℕ.+_) (ℕₚ.*-comm n _) ⟩ - n ℕ.+ toℕ i ℕ.* n ≡⟨ ℕₚ.*-comm (suc (toℕ i)) n ⟩ - n ℕ.* suc (toℕ i) ≤⟨ ℕₚ.*-monoʳ-≤ n (toℕ-mono-< i<j) ⟩ - n ℕ.* toℕ j ≤⟨ ℕₚ.m≤m+n (n ℕ.* toℕ j) (toℕ l) ⟩ - n ℕ.* toℕ j ℕ.+ toℕ l ≡˘⟨ toℕ-combine j l ⟩ - toℕ (combine j l) ∎ - where open ℕₚ.≤-Reasoning; open +-*-Solver - -combine-injectiveˡ : ∀ (i : Fin m) (j : Fin n) (k : Fin m) (l : Fin n) → - combine i j ≡ combine k l → i ≡ k -combine-injectiveˡ i j k l cᵢⱼ≡cₖₗ with <-cmp i k -... | tri< i<k _ _ = contradiction cᵢⱼ≡cₖₗ (<⇒≢ (combine-monoˡ-< j l i<k)) -... | tri≈ _ i≡k _ = i≡k -... | tri> _ _ i>k = contradiction (sym cᵢⱼ≡cₖₗ) (<⇒≢ (combine-monoˡ-< l j i>k)) - -combine-injectiveʳ : ∀ (i : Fin m) (j : Fin n) (k : Fin m) (l : Fin n) → - combine i j ≡ combine k l → j ≡ l -combine-injectiveʳ {m} {n} i j k l cᵢⱼ≡cₖₗ with combine-injectiveˡ i j k l cᵢⱼ≡cₖₗ -... | refl = toℕ-injective (ℕₚ.+-cancelˡ-≡ (n ℕ.* toℕ i) _ _ (begin - n ℕ.* toℕ i ℕ.+ toℕ j ≡˘⟨ toℕ-combine i j ⟩ - toℕ (combine i j) ≡⟨ cong toℕ cᵢⱼ≡cₖₗ ⟩ - toℕ (combine i l) ≡⟨ toℕ-combine i l ⟩ - n ℕ.* toℕ i ℕ.+ toℕ l ∎)) - where open ≡-Reasoning - -combine-injective : ∀ (i : Fin m) (j : Fin n) (k : Fin m) (l : Fin n) → - combine i j ≡ combine k l → i ≡ k × j ≡ l -combine-injective i j k l cᵢⱼ≡cₖₗ = - combine-injectiveˡ i j k l cᵢⱼ≡cₖₗ , - combine-injectiveʳ i j k l cᵢⱼ≡cₖₗ - -combine-surjective : ∀ (i : Fin (m ℕ.* n)) → ∃₂ λ j k → combine j k ≡ i -combine-surjective {m} {n} i with remQuot {m} n i | P.inspect (remQuot {m} n) i -... | j , k | P.[ eq ] = j , k , (begin - combine j k ≡˘⟨ uncurry (cong₂ combine) (,-injective eq) ⟩ - uncurry combine (remQuot {m} n i) ≡⟨ combine-remQuot {m} n i ⟩ - i ∎) - where open ≡-Reasoning - ------------------------------------------------------------------------- --- Bundles - -*↔× : Fin (m ℕ.* n) ↔ (Fin m × Fin n) -*↔× {m} {n} = mk↔′ (remQuot {m} n) (uncurry combine) - (uncurry remQuot-combine) - (combine-remQuot {m} n) - ------------------------------------------------------------------------- --- fin→fun ------------------------------------------------------------------------- - -funToFin-finToFin : funToFin {m} {n} ∘ finToFun ≗ id -funToFin-finToFin {zero} {n} zero = refl -funToFin-finToFin {suc m} {n} k = - begin - combine (finToFun {n} {suc m} k zero) (funToFin (finToFun {n} {suc m} k ∘ suc)) - ≡⟨⟩ - combine (quotient {n} (n ^ m) k) - (funToFin (finToFun {n} {m} (remainder {n} (n ^ m) k))) - ≡⟨ cong (combine (quotient {n} (n ^ m) k)) - (funToFin-finToFin {m} (remainder {n} (n ^ m) k)) ⟩ - combine (quotient {n} (n ^ m) k) (remainder {n} (n ^ m) k) - ≡⟨⟩ - uncurry combine (remQuot {n} (n ^ m) k) - ≡⟨ combine-remQuot {n = n} (n ^ m) k ⟩ - k - ∎ where open ≡-Reasoning - -finToFun-funToFin : (f : Fin m → Fin n) → finToFun (funToFin f) ≗ f -finToFun-funToFin {suc m} {n} f zero = - begin - quotient (n ^ m) (combine (f zero) (funToFin (f ∘ suc))) - ≡⟨ cong proj₁ (remQuot-combine _ _) ⟩ - proj₁ (f zero , funToFin (f ∘ suc)) - ≡⟨⟩ - f zero - ∎ where open ≡-Reasoning -finToFun-funToFin {suc m} {n} f (suc i) = - begin - finToFun (remainder {n} (n ^ m) (combine (f zero) (funToFin (f ∘ suc)))) i - ≡⟨ cong (λ rq → finToFun (proj₂ rq) i) (remQuot-combine {n} _ _) ⟩ - finToFun (proj₂ (f zero , funToFin (f ∘ suc))) i - ≡⟨⟩ - finToFun (funToFin (f ∘ suc)) i - ≡⟨ finToFun-funToFin (f ∘ suc) i ⟩ - (f ∘ suc) i - ≡⟨⟩ - f (suc i) - ∎ where open ≡-Reasoning - ------------------------------------------------------------------------- --- Bundles - -^↔→ : Extensionality _ _ → Fin (m ^ n) ↔ (Fin n → Fin m) -^↔→ {m} {n} ext = mk↔′ finToFun funToFin - (ext ∘ finToFun-funToFin) - (funToFin-finToFin {n} {m}) - ------------------------------------------------------------------------- --- lift ------------------------------------------------------------------------- - -lift-injective : ∀ (f : Fin m → Fin n) → Injective _≡_ _≡_ f → - ∀ k → Injective _≡_ _≡_ (lift k f) -lift-injective f inj zero {_} {_} eq = inj eq -lift-injective f inj (suc k) {zero} {zero} eq = refl -lift-injective f inj (suc k) {suc _} {suc _} eq = - cong suc (lift-injective f inj k (suc-injective eq)) - ------------------------------------------------------------------------- --- pred ------------------------------------------------------------------------- - -<⇒≤pred : i < j → i ≤ pred j -<⇒≤pred {i = zero} {j = suc j} z<s = z≤n -<⇒≤pred {i = suc i} {j = suc j} (s<s i<j) rewrite toℕ-inject₁ j = i<j - ------------------------------------------------------------------------- --- _ℕ-_ ------------------------------------------------------------------------- - -toℕ‿ℕ- : ∀ n i → toℕ (n ℕ- i) ≡ n ∸ toℕ i -toℕ‿ℕ- n zero = toℕ-fromℕ n -toℕ‿ℕ- (suc n) (suc i) = toℕ‿ℕ- n i - ------------------------------------------------------------------------- --- _ℕ-ℕ_ ------------------------------------------------------------------------- - -ℕ-ℕ≡toℕ‿ℕ- : ∀ n i → n ℕ-ℕ i ≡ toℕ (n ℕ- i) -ℕ-ℕ≡toℕ‿ℕ- n zero = sym (toℕ-fromℕ n) -ℕ-ℕ≡toℕ‿ℕ- (suc n) (suc i) = ℕ-ℕ≡toℕ‿ℕ- n i - -nℕ-ℕi≤n : ∀ n i → n ℕ-ℕ i ℕ.≤ n -nℕ-ℕi≤n n zero = ℕₚ.≤-refl -nℕ-ℕi≤n (suc n) (suc i) = begin - n ℕ-ℕ i ≤⟨ nℕ-ℕi≤n n i ⟩ - n ≤⟨ ℕₚ.n≤1+n n ⟩ - suc n ∎ - where open ℕₚ.≤-Reasoning - ------------------------------------------------------------------------- --- punchIn ------------------------------------------------------------------------- - -punchIn-injective : ∀ i (j k : Fin n) → - punchIn i j ≡ punchIn i k → j ≡ k -punchIn-injective zero _ _ refl = refl -punchIn-injective (suc i) zero zero _ = refl -punchIn-injective (suc i) (suc j) (suc k) ↑j+1≡↑k+1 = - cong suc (punchIn-injective i j k (suc-injective ↑j+1≡↑k+1)) - -punchInᵢ≢i : ∀ i (j : Fin n) → punchIn i j ≢ i -punchInᵢ≢i (suc i) (suc j) = punchInᵢ≢i i j ∘ suc-injective - ------------------------------------------------------------------------- --- punchOut ------------------------------------------------------------------------- - --- A version of 'cong' for 'punchOut' in which the inequality argument can be --- changed out arbitrarily (reflecting the proof-irrelevance of that argument). - -punchOut-cong : ∀ (i : Fin (suc n)) {j k} {i≢j : i ≢ j} {i≢k : i ≢ k} → - j ≡ k → punchOut i≢j ≡ punchOut i≢k -punchOut-cong {_} zero {zero} {i≢j = 0≢0} = contradiction refl 0≢0 -punchOut-cong {_} zero {suc j} {zero} {i≢k = 0≢0} = contradiction refl 0≢0 -punchOut-cong {_} zero {suc j} {suc k} = suc-injective -punchOut-cong {suc n} (suc i) {zero} {zero} _ = refl -punchOut-cong {suc n} (suc i) {suc j} {suc k} = cong suc ∘ punchOut-cong i ∘ suc-injective - --- An alternative to 'punchOut-cong' in the which the new inequality argument is --- specific. Useful for enabling the omission of that argument during equational --- reasoning. - -punchOut-cong′ : ∀ (i : Fin (suc n)) {j k} {p : i ≢ j} (q : j ≡ k) → - punchOut p ≡ punchOut (p ∘ sym ∘ trans q ∘ sym) -punchOut-cong′ i q = punchOut-cong i q - -punchOut-injective : ∀ {i j k : Fin (suc n)} - (i≢j : i ≢ j) (i≢k : i ≢ k) → - punchOut i≢j ≡ punchOut i≢k → j ≡ k -punchOut-injective {_} {zero} {zero} {_} 0≢0 _ _ = contradiction refl 0≢0 -punchOut-injective {_} {zero} {_} {zero} _ 0≢0 _ = contradiction refl 0≢0 -punchOut-injective {_} {zero} {suc j} {suc k} _ _ pⱼ≡pₖ = cong suc pⱼ≡pₖ -punchOut-injective {suc n} {suc i} {zero} {zero} _ _ _ = refl -punchOut-injective {suc n} {suc i} {suc j} {suc k} i≢j i≢k pⱼ≡pₖ = - cong suc (punchOut-injective (i≢j ∘ cong suc) (i≢k ∘ cong suc) (suc-injective pⱼ≡pₖ)) - -punchIn-punchOut : ∀ {i j : Fin (suc n)} (i≢j : i ≢ j) → - punchIn i (punchOut i≢j) ≡ j -punchIn-punchOut {_} {zero} {zero} 0≢0 = contradiction refl 0≢0 -punchIn-punchOut {_} {zero} {suc j} _ = refl -punchIn-punchOut {suc m} {suc i} {zero} i≢j = refl -punchIn-punchOut {suc m} {suc i} {suc j} i≢j = - cong suc (punchIn-punchOut (i≢j ∘ cong suc)) - -punchOut-punchIn : ∀ i {j : Fin n} → punchOut {i = i} {j = punchIn i j} (punchInᵢ≢i i j ∘ sym) ≡ j -punchOut-punchIn zero {j} = refl -punchOut-punchIn (suc i) {zero} = refl -punchOut-punchIn (suc i) {suc j} = cong suc (begin - punchOut (punchInᵢ≢i i j ∘ suc-injective ∘ sym ∘ cong suc) ≡⟨ punchOut-cong i refl ⟩ - punchOut (punchInᵢ≢i i j ∘ sym) ≡⟨ punchOut-punchIn i ⟩ - j ∎) - where open ≡-Reasoning - - ------------------------------------------------------------------------- --- pinch ------------------------------------------------------------------------- - -pinch-surjective : ∀ (i : Fin n) → Surjective _≡_ (pinch i) -pinch-surjective _ zero = zero , refl -pinch-surjective zero (suc j) = suc (suc j) , refl -pinch-surjective (suc i) (suc j) = map suc (cong suc) (pinch-surjective i j) - -pinch-mono-≤ : ∀ (i : Fin n) → (pinch i) Preserves _≤_ ⟶ _≤_ -pinch-mono-≤ 0F {0F} {k} 0≤n = z≤n -pinch-mono-≤ 0F {suc j} {suc k} (s≤s j≤k) = j≤k -pinch-mono-≤ (suc i) {0F} {k} 0≤n = z≤n -pinch-mono-≤ (suc i) {suc j} {suc k} (s≤s j≤k) = s≤s (pinch-mono-≤ i j≤k) - -pinch-injective : ∀ {i : Fin n} {j k : Fin (ℕ.suc n)} → - suc i ≢ j → suc i ≢ k → pinch i j ≡ pinch i k → j ≡ k -pinch-injective {i = i} {zero} {zero} _ _ _ = refl -pinch-injective {i = zero} {zero} {suc k} _ 1+i≢k eq = - contradiction (cong suc eq) 1+i≢k -pinch-injective {i = zero} {suc j} {zero} 1+i≢j _ eq = - contradiction (cong suc (sym eq)) 1+i≢j -pinch-injective {i = zero} {suc j} {suc k} _ _ eq = - cong suc eq -pinch-injective {i = suc i} {suc j} {suc k} 1+i≢j 1+i≢k eq = - cong suc - (pinch-injective (1+i≢j ∘ cong suc) (1+i≢k ∘ cong suc) - (suc-injective eq)) - ------------------------------------------------------------------------- --- Quantification ------------------------------------------------------------------------- - -module _ {p} {P : Pred (Fin (suc n)) p} where - - ∀-cons : P zero → Π[ P ∘ suc ] → Π[ P ] - ∀-cons z s zero = z - ∀-cons z s (suc i) = s i - - ∀-cons-⇔ : (P zero × Π[ P ∘ suc ]) ⇔ Π[ P ] - ∀-cons-⇔ = mk⇔ (uncurry ∀-cons) < _$ zero , _∘ suc > - - ∃-here : P zero → ∃⟨ P ⟩ - ∃-here = zero ,_ - - ∃-there : ∃⟨ P ∘ suc ⟩ → ∃⟨ P ⟩ - ∃-there = map suc id - - ∃-toSum : ∃⟨ P ⟩ → P zero ⊎ ∃⟨ P ∘ suc ⟩ - ∃-toSum ( zero , P₀ ) = inj₁ P₀ - ∃-toSum (suc f , P₁₊) = inj₂ (f , P₁₊) - - ⊎⇔∃ : (P zero ⊎ ∃⟨ P ∘ suc ⟩) ⇔ ∃⟨ P ⟩ - ⊎⇔∃ = mk⇔ [ ∃-here , ∃-there ] ∃-toSum - -decFinSubset : ∀ {p q} {P : Pred (Fin n) p} {Q : Pred (Fin n) q} → - Decidable Q → (∀ {i} → Q i → Dec (P i)) → Dec (Q ⊆ P) -decFinSubset {zero} {_} {_} Q? P? = yes λ {} -decFinSubset {suc n} {P = P} {Q} Q? P? - with Q? zero | ∀-cons {P = λ x → Q x → P x} -... | false because [¬Q0] | cons = - map′ (λ f {x} → cons (⊥-elim ∘ invert [¬Q0]) (λ x → f {x}) x) - (λ f {x} → f {suc x}) - (decFinSubset (Q? ∘ suc) P?) -... | true because [Q0] | cons = - map′ (uncurry λ P0 rec {x} → cons (λ _ → P0) (λ x → rec {x}) x) - < _$ invert [Q0] , (λ f {x} → f {suc x}) > - (P? (invert [Q0]) ×-dec decFinSubset (Q? ∘ suc) P?) - -any? : ∀ {p} {P : Pred (Fin n) p} → Decidable P → Dec (∃ P) -any? {zero} {P = _} P? = no λ { (() , _) } -any? {suc n} {P = P} P? = Dec.map ⊎⇔∃ (P? zero ⊎-dec any? (P? ∘ suc)) - -all? : ∀ {p} {P : Pred (Fin n) p} → Decidable P → Dec (∀ f → P f) -all? P? = map′ (λ ∀p f → ∀p tt) (λ ∀p {x} _ → ∀p x) - (decFinSubset U? (λ {f} _ → P? f)) - -private - -- A nice computational property of `all?`: - -- The boolean component of the result is exactly the - -- obvious fold of boolean tests (`foldr _∧_ true`). - note : ∀ {p} {P : Pred (Fin 3) p} (P? : Decidable P) → - ∃ λ z → does (all? P?) ≡ z - note P? = does (P? 0F) ∧ does (P? 1F) ∧ does (P? 2F) ∧ true - , refl - --- If a decidable predicate P over a finite set is sometimes false, --- then we can find the smallest value for which this is the case. - -¬∀⟶∃¬-smallest : ∀ n {p} (P : Pred (Fin n) p) → Decidable P → - ¬ (∀ i → P i) → ∃ λ i → ¬ P i × ((j : Fin′ i) → P (inject j)) -¬∀⟶∃¬-smallest zero P P? ¬∀P = contradiction (λ()) ¬∀P -¬∀⟶∃¬-smallest (suc n) P P? ¬∀P with P? zero -... | false because [¬P₀] = (zero , invert [¬P₀] , λ ()) -... | true because [P₀] = map suc (map id (∀-cons (invert [P₀]))) - (¬∀⟶∃¬-smallest n (P ∘ suc) (P? ∘ suc) (¬∀P ∘ (∀-cons (invert [P₀])))) - --- When P is a decidable predicate over a finite set the following --- lemma can be proved. - -¬∀⟶∃¬ : ∀ n {p} (P : Pred (Fin n) p) → Decidable P → - ¬ (∀ i → P i) → (∃ λ i → ¬ P i) -¬∀⟶∃¬ n P P? ¬P = map id proj₁ (¬∀⟶∃¬-smallest n P P? ¬P) - ------------------------------------------------------------------------- --- Properties of functions to and from Fin ------------------------------------------------------------------------- - --- The pigeonhole principle. - -pigeonhole : m ℕ.< n → (f : Fin n → Fin m) → ∃₂ λ i j → i < j × f i ≡ f j -pigeonhole z<s f = contradiction (f zero) λ() -pigeonhole (s<s m<n@(s≤s _)) f with any? (λ k → f zero ≟ f (suc k)) -... | yes (j , f₀≡fⱼ) = zero , suc j , z<s , f₀≡fⱼ -... | no f₀≢fₖ with pigeonhole m<n (λ j → punchOut (f₀≢fₖ ∘ (j ,_ ))) -... | (i , j , i<j , fᵢ≡fⱼ) = - suc i , suc j , s<s i<j , - punchOut-injective (f₀≢fₖ ∘ (i ,_)) _ fᵢ≡fⱼ - -injective⇒≤ : ∀ {f : Fin m → Fin n} → Injective _≡_ _≡_ f → m ℕ.≤ n -injective⇒≤ {zero} {_} {f} _ = z≤n -injective⇒≤ {suc _} {zero} {f} _ = contradiction (f zero) ¬Fin0 -injective⇒≤ {suc _} {suc _} {f} inj = s≤s (injective⇒≤ (λ eq → - suc-injective (inj (punchOut-injective - (contraInjective _≡_ _≡_ inj 0≢1+n) - (contraInjective _≡_ _≡_ inj 0≢1+n) eq)))) - -<⇒notInjective : ∀ {f : Fin m → Fin n} → n ℕ.< m → ¬ (Injective _≡_ _≡_ f) -<⇒notInjective n<m inj = ℕₚ.≤⇒≯ (injective⇒≤ inj) n<m - -ℕ→Fin-notInjective : ∀ (f : ℕ → Fin n) → ¬ (Injective _≡_ _≡_ f) -ℕ→Fin-notInjective f inj = ℕₚ.<-irrefl refl - (injective⇒≤ (Comp.injective _≡_ _≡_ _≡_ toℕ-injective inj)) - --- Cantor-Schröder-Bernstein for finite sets - -cantor-schröder-bernstein : ∀ {f : Fin m → Fin n} {g : Fin n → Fin m} → - Injective _≡_ _≡_ f → Injective _≡_ _≡_ g → - m ≡ n -cantor-schröder-bernstein f-inj g-inj = ℕₚ.≤-antisym - (injective⇒≤ f-inj) (injective⇒≤ g-inj) - ------------------------------------------------------------------------- --- Effectful ------------------------------------------------------------------------- - -module _ {f} {F : Set f → Set f} (RA : RawApplicative F) where - - open RawApplicative RA - - sequence : ∀ {n} {P : Pred (Fin n) f} → - (∀ i → F (P i)) → F (∀ i → P i) - sequence {zero} ∀iPi = pure λ() - sequence {suc n} ∀iPi = ∀-cons <$> ∀iPi zero <*> sequence (∀iPi ∘ suc) - -module _ {f} {F : Set f → Set f} (RF : RawFunctor F) where - - open RawFunctor RF - - sequence⁻¹ : ∀ {A : Set f} {P : Pred A f} → - F (∀ i → P i) → (∀ i → F (P i)) - sequence⁻¹ F∀iPi i = (λ f → f i) <$> F∀iPi - ------------------------------------------------------------------------- --- If there is an injection from a type A to a finite set, then the type --- has decidable equality. - -module _ {ℓ} {S : Setoid a ℓ} (inj : Injection S (≡-setoid n)) where - open Setoid S - - inj⇒≟ : B.Decidable _≈_ - inj⇒≟ = Dec.via-injection inj _≟_ - - inj⇒decSetoid : DecSetoid a ℓ - inj⇒decSetoid = record - { isDecEquivalence = record - { isEquivalence = isEquivalence - ; _≟_ = inj⇒≟ - } - } - ------------------------------------------------------------------------- --- Opposite ------------------------------------------------------------------------- - -opposite-prop : ∀ (i : Fin n) → toℕ (opposite i) ≡ n ∸ suc (toℕ i) -opposite-prop {suc n} zero = toℕ-fromℕ n -opposite-prop {suc n} (suc i) = begin - toℕ (inject₁ (opposite i)) ≡⟨ toℕ-inject₁ (opposite i) ⟩ - toℕ (opposite i) ≡⟨ opposite-prop i ⟩ - n ∸ suc (toℕ i) ∎ - where open ≡-Reasoning - -opposite-involutive : Involutive {A = Fin n} _≡_ opposite -opposite-involutive {suc n} i = toℕ-injective (begin - toℕ (opposite (opposite i)) ≡⟨ opposite-prop (opposite i) ⟩ - n ∸ (toℕ (opposite i)) ≡⟨ cong (n ∸_) (opposite-prop i) ⟩ - n ∸ (n ∸ (toℕ i)) ≡⟨ ℕₚ.m∸[m∸n]≡n (toℕ≤pred[n] i) ⟩ - toℕ i ∎) - where open ≡-Reasoning - -opposite-suc : ∀ (i : Fin n) → toℕ (opposite (suc i)) ≡ toℕ (opposite i) -opposite-suc {n} i = begin - toℕ (opposite (suc i)) ≡⟨ opposite-prop (suc i) ⟩ - suc n ∸ suc (toℕ (suc i)) ≡⟨⟩ - n ∸ toℕ (suc i) ≡⟨⟩ - n ∸ suc (toℕ i) ≡⟨ sym (opposite-prop i) ⟩ - toℕ (opposite i) ∎ - where open ≡-Reasoning - - ------------------------------------------------------------------------- --- DEPRECATED NAMES ------------------------------------------------------------------------- --- Please use the new names as continuing support for the old names is --- not guaranteed. - --- Version 1.5 - -inject+-raise-splitAt = join-splitAt -{-# WARNING_ON_USAGE inject+-raise-splitAt -"Warning: inject+-raise-splitAt was deprecated in v1.5. +<-respˡ-≡ : (_<_ {m} {n}) Respectsˡ _≡_ +<-respˡ-≡ refl x≤y = x≤y + +<-respʳ-≡ : (_<_ {m} {n}) Respectsʳ _≡_ +<-respʳ-≡ refl x≤y = x≤y + +<-resp₂-≡ : (_<_ {n}) Respects₂ _≡_ +<-resp₂-≡ = <-respʳ-≡ , <-respˡ-≡ + +<-irrelevant : Irrelevant (_<_ {m} {n}) +<-irrelevant = ℕₚ.<-irrelevant + +------------------------------------------------------------------------ +-- Structures + +<-isStrictPartialOrder : IsStrictPartialOrder {A = Fin n} _≡_ _<_ +<-isStrictPartialOrder = record + { isEquivalence = P.isEquivalence + ; irrefl = <-irrefl + ; trans = <-trans + ; <-resp-≈ = <-resp₂-≡ + } + +<-isStrictTotalOrder : IsStrictTotalOrder {A = Fin n} _≡_ _<_ +<-isStrictTotalOrder = record + { isStrictPartialOrder = <-isStrictPartialOrder + ; compare = <-cmp + } + +------------------------------------------------------------------------ +-- Bundles + +<-strictPartialOrder : ℕ → StrictPartialOrder _ _ _ +<-strictPartialOrder n = record + { isStrictPartialOrder = <-isStrictPartialOrder {n} + } + +<-strictTotalOrder : ℕ → StrictTotalOrder _ _ _ +<-strictTotalOrder n = record + { isStrictTotalOrder = <-isStrictTotalOrder {n} + } + +------------------------------------------------------------------------ +-- Other properties + +i<1+i : ∀ (i : Fin n) → i < suc i +i<1+i = ℕₚ.n<1+n ∘ toℕ + +<⇒≢ : i < j → i ≢ j +<⇒≢ i<i refl = ℕₚ.n≮n _ i<i + +≤∧≢⇒< : i ≤ j → i ≢ j → i < j +≤∧≢⇒< {i = zero} {zero} _ 0≢0 = contradiction refl 0≢0 +≤∧≢⇒< {i = zero} {suc j} _ _ = z<s +≤∧≢⇒< {i = suc i} {suc j} 1+i≤1+j 1+i≢1+j = + s<s (≤∧≢⇒< (ℕ.s≤s⁻¹ 1+i≤1+j) (1+i≢1+j ∘ (cong suc))) + +------------------------------------------------------------------------ +-- inject +------------------------------------------------------------------------ + +toℕ-inject : ∀ {i : Fin n} (j : Fin′ i) → toℕ (inject j) ≡ toℕ j +toℕ-inject {i = suc i} zero = refl +toℕ-inject {i = suc i} (suc j) = cong suc (toℕ-inject j) + +------------------------------------------------------------------------ +-- inject₁ +------------------------------------------------------------------------ + +fromℕ≢inject₁ : fromℕ n ≢ inject₁ i +fromℕ≢inject₁ {i = suc i} eq = fromℕ≢inject₁ {i = i} (suc-injective eq) + +inject₁-injective : inject₁ i ≡ inject₁ j → i ≡ j +inject₁-injective {i = zero} {zero} i≡j = refl +inject₁-injective {i = suc i} {suc j} i≡j = + cong suc (inject₁-injective (suc-injective i≡j)) + +toℕ-inject₁ : ∀ (i : Fin n) → toℕ (inject₁ i) ≡ toℕ i +toℕ-inject₁ zero = refl +toℕ-inject₁ (suc i) = cong suc (toℕ-inject₁ i) + +toℕ-inject₁-≢ : ∀ (i : Fin n) → n ≢ toℕ (inject₁ i) +toℕ-inject₁-≢ (suc i) = toℕ-inject₁-≢ i ∘ ℕₚ.suc-injective + +inject₁ℕ< : ∀ (i : Fin n) → toℕ (inject₁ i) ℕ.< n +inject₁ℕ< i rewrite toℕ-inject₁ i = toℕ<n i + +inject₁ℕ≤ : ∀ (i : Fin n) → toℕ (inject₁ i) ℕ.≤ n +inject₁ℕ≤ = ℕₚ.<⇒≤ ∘ inject₁ℕ< + +≤̄⇒inject₁< : i ≤ j → inject₁ i < suc j +≤̄⇒inject₁< {i = i} i≤j rewrite sym (toℕ-inject₁ i) = s<s i≤j + +ℕ<⇒inject₁< : ∀ {i : Fin (ℕ.suc n)} {j : Fin n} → j < i → inject₁ j < i +ℕ<⇒inject₁< {i = suc i} j≤i = ≤̄⇒inject₁< (ℕ.s≤s⁻¹ j≤i) + +i≤inject₁[j]⇒i≤1+j : i ≤ inject₁ j → i ≤ suc j +i≤inject₁[j]⇒i≤1+j {i = zero} _ = z≤n +i≤inject₁[j]⇒i≤1+j {i = suc i} {j = suc j} i≤j = s≤s (ℕₚ.m≤n⇒m≤1+n (subst (toℕ i ℕ.≤_) (toℕ-inject₁ j) (ℕ.s≤s⁻¹ i≤j))) + +------------------------------------------------------------------------ +-- lower₁ +------------------------------------------------------------------------ + +toℕ-lower₁ : ∀ i (p : n ≢ toℕ i) → toℕ (lower₁ i p) ≡ toℕ i +toℕ-lower₁ {ℕ.zero} zero p = contradiction refl p +toℕ-lower₁ {ℕ.suc m} zero p = refl +toℕ-lower₁ {ℕ.suc m} (suc i) p = cong ℕ.suc (toℕ-lower₁ i (p ∘ cong ℕ.suc)) + +lower₁-injective : ∀ {n≢i : n ≢ toℕ i} {n≢j : n ≢ toℕ j} → + lower₁ i n≢i ≡ lower₁ j n≢j → i ≡ j +lower₁-injective {zero} {zero} {_} {n≢i} {_} _ = contradiction refl n≢i +lower₁-injective {zero} {_} {zero} {_} {n≢j} _ = contradiction refl n≢j +lower₁-injective {suc n} {zero} {zero} {_} {_} refl = refl +lower₁-injective {suc n} {suc i} {suc j} {n≢i} {n≢j} eq = + cong suc (lower₁-injective (suc-injective eq)) + +------------------------------------------------------------------------ +-- inject₁ and lower₁ + +inject₁-lower₁ : ∀ (i : Fin (suc n)) (n≢i : n ≢ toℕ i) → + inject₁ (lower₁ i n≢i) ≡ i +inject₁-lower₁ {zero} zero 0≢0 = contradiction refl 0≢0 +inject₁-lower₁ {suc n} zero _ = refl +inject₁-lower₁ {suc n} (suc i) n+1≢i+1 = + cong suc (inject₁-lower₁ i (n+1≢i+1 ∘ cong suc)) + +lower₁-inject₁′ : ∀ (i : Fin n) (n≢i : n ≢ toℕ (inject₁ i)) → + lower₁ (inject₁ i) n≢i ≡ i +lower₁-inject₁′ zero _ = refl +lower₁-inject₁′ (suc i) n+1≢i+1 = + cong suc (lower₁-inject₁′ i (n+1≢i+1 ∘ cong suc)) + +lower₁-inject₁ : ∀ (i : Fin n) → + lower₁ (inject₁ i) (toℕ-inject₁-≢ i) ≡ i +lower₁-inject₁ i = lower₁-inject₁′ i (toℕ-inject₁-≢ i) + +lower₁-irrelevant : ∀ (i : Fin (suc n)) (n≢i₁ n≢i₂ : n ≢ toℕ i) → + lower₁ i n≢i₁ ≡ lower₁ i n≢i₂ +lower₁-irrelevant {zero} zero 0≢0 _ = contradiction refl 0≢0 +lower₁-irrelevant {suc n} zero _ _ = refl +lower₁-irrelevant {suc n} (suc i) _ _ = + cong suc (lower₁-irrelevant i _ _) + +inject₁≡⇒lower₁≡ : ∀ {i : Fin n} {j : Fin (ℕ.suc n)} → + (n≢j : n ≢ toℕ j) → inject₁ i ≡ j → lower₁ j n≢j ≡ i +inject₁≡⇒lower₁≡ n≢j i≡j = inject₁-injective (trans (inject₁-lower₁ _ n≢j) (sym i≡j)) + +------------------------------------------------------------------------ +-- inject≤ +------------------------------------------------------------------------ + +toℕ-inject≤ : ∀ i .(m≤n : m ℕ.≤ n) → toℕ (inject≤ i m≤n) ≡ toℕ i +toℕ-inject≤ {_} {suc n} zero _ = refl +toℕ-inject≤ {_} {suc n} (suc i) _ = cong suc (toℕ-inject≤ i _) + +inject≤-refl : ∀ i .(n≤n : n ℕ.≤ n) → inject≤ i n≤n ≡ i +inject≤-refl {suc n} zero _ = refl +inject≤-refl {suc n} (suc i) _ = cong suc (inject≤-refl i _) + +inject≤-idempotent : ∀ (i : Fin m) + .(m≤n : m ℕ.≤ n) .(n≤o : n ℕ.≤ o) .(m≤o : m ℕ.≤ o) → + inject≤ (inject≤ i m≤n) n≤o ≡ inject≤ i m≤o +inject≤-idempotent {_} {suc n} {suc o} zero _ _ _ = refl +inject≤-idempotent {_} {suc n} {suc o} (suc i) _ _ _ = + cong suc (inject≤-idempotent i _ _ _) + +inject≤-trans : ∀ (i : Fin m) .(m≤n : m ℕ.≤ n) .(n≤o : n ℕ.≤ o) → + inject≤ (inject≤ i m≤n) n≤o ≡ inject≤ i (ℕₚ.≤-trans m≤n n≤o) +inject≤-trans i _ _ = inject≤-idempotent i _ _ _ + +inject≤-injective : ∀ .(m≤n m≤n′ : m ℕ.≤ n) i j → + inject≤ i m≤n ≡ inject≤ j m≤n′ → i ≡ j +inject≤-injective {n = suc _} _ _ zero zero eq = refl +inject≤-injective {n = suc _} _ _ (suc i) (suc j) eq = + cong suc (inject≤-injective _ _ i j (suc-injective eq)) + +inject≤-irrelevant : ∀ .(m≤n m≤n′ : m ℕ.≤ n) i → + inject≤ i m≤n ≡ inject≤ i m≤n′ +inject≤-irrelevant _ _ i = refl + +------------------------------------------------------------------------ +-- pred +------------------------------------------------------------------------ + +pred< : ∀ (i : Fin (suc n)) → i ≢ zero → pred i < i +pred< zero i≢0 = contradiction refl i≢0 +pred< (suc i) _ = ≤̄⇒inject₁< ℕₚ.≤-refl + +------------------------------------------------------------------------ +-- splitAt +------------------------------------------------------------------------ + +-- Fin (m + n) ↔ Fin m ⊎ Fin n + +splitAt-↑ˡ : ∀ m i n → splitAt m (i ↑ˡ n) ≡ inj₁ i +splitAt-↑ˡ (suc m) zero n = refl +splitAt-↑ˡ (suc m) (suc i) n rewrite splitAt-↑ˡ m i n = refl + +splitAt⁻¹-↑ˡ : ∀ {m} {n} {i} {j} → splitAt m {n} i ≡ inj₁ j → j ↑ˡ n ≡ i +splitAt⁻¹-↑ˡ {suc m} {n} {0F} {.0F} refl = refl +splitAt⁻¹-↑ˡ {suc m} {n} {suc i} {j} eq + with inj₁ k ← splitAt m i in splitAt[m][i]≡inj₁[j] + with refl ← eq + = cong suc (splitAt⁻¹-↑ˡ {i = i} {j = k} splitAt[m][i]≡inj₁[j]) + +splitAt-↑ʳ : ∀ m n i → splitAt m (m ↑ʳ i) ≡ inj₂ {B = Fin n} i +splitAt-↑ʳ zero n i = refl +splitAt-↑ʳ (suc m) n i rewrite splitAt-↑ʳ m n i = refl + +splitAt⁻¹-↑ʳ : ∀ {m} {n} {i} {j} → splitAt m {n} i ≡ inj₂ j → m ↑ʳ j ≡ i +splitAt⁻¹-↑ʳ {zero} {n} {i} {j} refl = refl +splitAt⁻¹-↑ʳ {suc m} {n} {suc i} {j} eq + with inj₂ k ← splitAt m i in splitAt[m][i]≡inj₂[k] + with refl ← eq + = cong suc (splitAt⁻¹-↑ʳ {i = i} {j = k} splitAt[m][i]≡inj₂[k]) + +splitAt-join : ∀ m n i → splitAt m (join m n i) ≡ i +splitAt-join m n (inj₁ x) = splitAt-↑ˡ m x n +splitAt-join m n (inj₂ y) = splitAt-↑ʳ m n y + +join-splitAt : ∀ m n i → join m n (splitAt m i) ≡ i +join-splitAt zero n i = refl +join-splitAt (suc m) n zero = refl +join-splitAt (suc m) n (suc i) = begin + [ _↑ˡ n , (suc m) ↑ʳ_ ]′ (splitAt (suc m) (suc i)) ≡⟨ [,]-map (splitAt m i) ⟩ + [ suc ∘ (_↑ˡ n) , suc ∘ (m ↑ʳ_) ]′ (splitAt m i) ≡⟨ [,]-∘ suc (splitAt m i) ⟨ + suc ([ _↑ˡ n , m ↑ʳ_ ]′ (splitAt m i)) ≡⟨ cong suc (join-splitAt m n i) ⟩ + suc i ∎ + where open ≡-Reasoning + +-- splitAt "m" "i" ≡ inj₁ "i" if i < m + +splitAt-< : ∀ m {n} (i : Fin (m ℕ.+ n)) .(i<m : toℕ i ℕ.< m) → + splitAt m i ≡ inj₁ (fromℕ< i<m) +splitAt-< (suc m) zero _ = refl +splitAt-< (suc m) (suc i) i<m = cong (Sum.map suc id) (splitAt-< m i (ℕ.s<s⁻¹ i<m)) + +-- splitAt "m" "i" ≡ inj₂ "i - m" if i ≥ m + +splitAt-≥ : ∀ m {n} (i : Fin (m ℕ.+ n)) .(i≥m : toℕ i ℕ.≥ m) → + splitAt m i ≡ inj₂ (reduce≥ i i≥m) +splitAt-≥ zero i _ = refl +splitAt-≥ (suc m) (suc i) i≥m = cong (Sum.map suc id) (splitAt-≥ m i (ℕ.s≤s⁻¹ i≥m)) + +------------------------------------------------------------------------ +-- Bundles + ++↔⊎ : Fin (m ℕ.+ n) ↔ (Fin m ⊎ Fin n) ++↔⊎ {m} {n} = mk↔ₛ′ (splitAt m {n}) (join m n) (splitAt-join m n) (join-splitAt m n) + +------------------------------------------------------------------------ +-- remQuot +------------------------------------------------------------------------ + +-- Fin (m * n) ↔ Fin m × Fin n + +remQuot-combine : ∀ {n k} (i : Fin n) j → remQuot k (combine i j) ≡ (i , j) +remQuot-combine {suc n} {k} zero j rewrite splitAt-↑ˡ k j (n ℕ.* k) = refl +remQuot-combine {suc n} {k} (suc i) j rewrite splitAt-↑ʳ k (n ℕ.* k) (combine i j) = + cong (Prod.map₁ suc) (remQuot-combine i j) + +combine-remQuot : ∀ {n} k (i : Fin (n ℕ.* k)) → uncurry combine (remQuot {n} k i) ≡ i +combine-remQuot {suc n} k i with splitAt k i in eq +... | inj₁ j = begin + join k (n ℕ.* k) (inj₁ j) ≡⟨ cong (join k (n ℕ.* k)) eq ⟨ + join k (n ℕ.* k) (splitAt k i) ≡⟨ join-splitAt k (n ℕ.* k) i ⟩ + i ∎ + where open ≡-Reasoning +... | inj₂ j = begin + k ↑ʳ (uncurry combine (remQuot {n} k j)) ≡⟨ cong (k ↑ʳ_) (combine-remQuot {n} k j) ⟩ + join k (n ℕ.* k) (inj₂ j) ≡⟨ cong (join k (n ℕ.* k)) eq ⟨ + join k (n ℕ.* k) (splitAt k i) ≡⟨ join-splitAt k (n ℕ.* k) i ⟩ + i ∎ + where open ≡-Reasoning + +toℕ-combine : ∀ (i : Fin m) (j : Fin n) → toℕ (combine i j) ≡ n ℕ.* toℕ i ℕ.+ toℕ j +toℕ-combine {suc m} {n} i@0F j = begin + toℕ (combine i j) ≡⟨⟩ + toℕ (j ↑ˡ (m ℕ.* n)) ≡⟨ toℕ-↑ˡ j (m ℕ.* n) ⟩ + toℕ j ≡⟨⟩ + 0 ℕ.+ toℕ j ≡⟨ cong (ℕ._+ toℕ j) (ℕₚ.*-zeroʳ n) ⟨ + n ℕ.* toℕ i ℕ.+ toℕ j ∎ + where open ≡-Reasoning +toℕ-combine {suc m} {n} (suc i) j = begin + toℕ (combine (suc i) j) ≡⟨⟩ + toℕ (n ↑ʳ combine i j) ≡⟨ toℕ-↑ʳ n (combine i j) ⟩ + n ℕ.+ toℕ (combine i j) ≡⟨ cong (n ℕ.+_) (toℕ-combine i j) ⟩ + n ℕ.+ (n ℕ.* toℕ i ℕ.+ toℕ j) ≡⟨ solve 3 (λ n i j → n :+ (n :* i :+ j) := n :* (con 1 :+ i) :+ j) refl n (toℕ i) (toℕ j) ⟩ + n ℕ.* toℕ (suc i) ℕ.+ toℕ j ∎ + where open ≡-Reasoning; open +-*-Solver + +combine-monoˡ-< : ∀ {i j : Fin m} (k l : Fin n) → + i < j → combine i k < combine j l +combine-monoˡ-< {m} {n} {i} {j} k l i<j = begin-strict + toℕ (combine i k) ≡⟨ toℕ-combine i k ⟩ + n ℕ.* toℕ i ℕ.+ toℕ k <⟨ ℕₚ.+-monoʳ-< (n ℕ.* toℕ i) (toℕ<n k) ⟩ + n ℕ.* toℕ i ℕ.+ n ≡⟨ ℕₚ.+-comm _ n ⟩ + n ℕ.+ n ℕ.* toℕ i ≡⟨ cong (n ℕ.+_) (ℕₚ.*-comm n _) ⟩ + n ℕ.+ toℕ i ℕ.* n ≡⟨ ℕₚ.*-comm (suc (toℕ i)) n ⟩ + n ℕ.* suc (toℕ i) ≤⟨ ℕₚ.*-monoʳ-≤ n (toℕ-mono-< i<j) ⟩ + n ℕ.* toℕ j ≤⟨ ℕₚ.m≤m+n (n ℕ.* toℕ j) (toℕ l) ⟩ + n ℕ.* toℕ j ℕ.+ toℕ l ≡⟨ toℕ-combine j l ⟨ + toℕ (combine j l) ∎ + where open ℕₚ.≤-Reasoning; open +-*-Solver + +combine-injectiveˡ : ∀ (i : Fin m) (j : Fin n) (k : Fin m) (l : Fin n) → + combine i j ≡ combine k l → i ≡ k +combine-injectiveˡ i j k l cᵢⱼ≡cₖₗ with <-cmp i k +... | tri< i<k _ _ = contradiction cᵢⱼ≡cₖₗ (<⇒≢ (combine-monoˡ-< j l i<k)) +... | tri≈ _ i≡k _ = i≡k +... | tri> _ _ i>k = contradiction (sym cᵢⱼ≡cₖₗ) (<⇒≢ (combine-monoˡ-< l j i>k)) + +combine-injectiveʳ : ∀ (i : Fin m) (j : Fin n) (k : Fin m) (l : Fin n) → + combine i j ≡ combine k l → j ≡ l +combine-injectiveʳ {m} {n} i j k l cᵢⱼ≡cₖₗ + with refl ← combine-injectiveˡ i j k l cᵢⱼ≡cₖₗ + = toℕ-injective (ℕₚ.+-cancelˡ-≡ (n ℕ.* toℕ i) _ _ (begin + n ℕ.* toℕ i ℕ.+ toℕ j ≡⟨ toℕ-combine i j ⟨ + toℕ (combine i j) ≡⟨ cong toℕ cᵢⱼ≡cₖₗ ⟩ + toℕ (combine i l) ≡⟨ toℕ-combine i l ⟩ + n ℕ.* toℕ i ℕ.+ toℕ l ∎)) + where open ≡-Reasoning + +combine-injective : ∀ (i : Fin m) (j : Fin n) (k : Fin m) (l : Fin n) → + combine i j ≡ combine k l → i ≡ k × j ≡ l +combine-injective i j k l cᵢⱼ≡cₖₗ = + combine-injectiveˡ i j k l cᵢⱼ≡cₖₗ , + combine-injectiveʳ i j k l cᵢⱼ≡cₖₗ + +combine-surjective : ∀ (i : Fin (m ℕ.* n)) → ∃₂ λ j k → combine j k ≡ i +combine-surjective {m} {n} i with j , k ← remQuot {m} n i in eq + = j , k , (begin + combine j k ≡⟨ uncurry (cong₂ combine) (,-injective eq) ⟨ + uncurry combine (remQuot {m} n i) ≡⟨ combine-remQuot {m} n i ⟩ + i ∎) + where open ≡-Reasoning + +------------------------------------------------------------------------ +-- Bundles + +*↔× : Fin (m ℕ.* n) ↔ (Fin m × Fin n) +*↔× {m} {n} = mk↔ₛ′ (remQuot {m} n) (uncurry combine) + (uncurry remQuot-combine) + (combine-remQuot {m} n) + +------------------------------------------------------------------------ +-- fin→fun +------------------------------------------------------------------------ + +funToFin-finToFin : funToFin {m} {n} ∘ finToFun ≗ id +funToFin-finToFin {zero} {n} zero = refl +funToFin-finToFin {suc m} {n} k = + begin + combine (finToFun {n} {suc m} k zero) (funToFin (finToFun {n} {suc m} k ∘ suc)) + ≡⟨⟩ + combine (quotient {n} (n ^ m) k) + (funToFin (finToFun {n} {m} (remainder {n} (n ^ m) k))) + ≡⟨ cong (combine (quotient {n} (n ^ m) k)) + (funToFin-finToFin {m} (remainder {n} (n ^ m) k)) ⟩ + combine (quotient {n} (n ^ m) k) (remainder {n} (n ^ m) k) + ≡⟨⟩ + uncurry combine (remQuot {n} (n ^ m) k) + ≡⟨ combine-remQuot {n = n} (n ^ m) k ⟩ + k + ∎ where open ≡-Reasoning + +finToFun-funToFin : (f : Fin m → Fin n) → finToFun (funToFin f) ≗ f +finToFun-funToFin {suc m} {n} f zero = + begin + quotient (n ^ m) (combine (f zero) (funToFin (f ∘ suc))) + ≡⟨ cong proj₁ (remQuot-combine _ _) ⟩ + proj₁ (f zero , funToFin (f ∘ suc)) + ≡⟨⟩ + f zero + ∎ where open ≡-Reasoning +finToFun-funToFin {suc m} {n} f (suc i) = + begin + finToFun (remainder {n} (n ^ m) (combine (f zero) (funToFin (f ∘ suc)))) i + ≡⟨ cong (λ rq → finToFun (proj₂ rq) i) (remQuot-combine {n} _ _) ⟩ + finToFun (proj₂ (f zero , funToFin (f ∘ suc))) i + ≡⟨⟩ + finToFun (funToFin (f ∘ suc)) i + ≡⟨ finToFun-funToFin (f ∘ suc) i ⟩ + (f ∘ suc) i + ≡⟨⟩ + f (suc i) + ∎ where open ≡-Reasoning + +------------------------------------------------------------------------ +-- Bundles + +^↔→ : Extensionality _ _ → Fin (m ^ n) ↔ (Fin n → Fin m) +^↔→ {m} {n} ext = mk↔ₛ′ finToFun funToFin + (ext ∘ finToFun-funToFin) + (funToFin-finToFin {n} {m}) + +------------------------------------------------------------------------ +-- lift +------------------------------------------------------------------------ + +lift-injective : ∀ (f : Fin m → Fin n) → Injective _≡_ _≡_ f → + ∀ k → Injective _≡_ _≡_ (lift k f) +lift-injective f inj zero {_} {_} eq = inj eq +lift-injective f inj (suc k) {zero} {zero} eq = refl +lift-injective f inj (suc k) {suc _} {suc _} eq = + cong suc (lift-injective f inj k (suc-injective eq)) + +------------------------------------------------------------------------ +-- pred +------------------------------------------------------------------------ + +<⇒≤pred : i < j → i ≤ pred j +<⇒≤pred {i = zero} {j = suc j} z<s = z≤n +<⇒≤pred {i = suc i} {j = suc j} (s<s i<j) rewrite toℕ-inject₁ j = i<j + +------------------------------------------------------------------------ +-- _ℕ-_ +------------------------------------------------------------------------ + +toℕ‿ℕ- : ∀ n i → toℕ (n ℕ- i) ≡ n ∸ toℕ i +toℕ‿ℕ- n zero = toℕ-fromℕ n +toℕ‿ℕ- (suc n) (suc i) = toℕ‿ℕ- n i + +------------------------------------------------------------------------ +-- _ℕ-ℕ_ +------------------------------------------------------------------------ + +ℕ-ℕ≡toℕ‿ℕ- : ∀ n i → n ℕ-ℕ i ≡ toℕ (n ℕ- i) +ℕ-ℕ≡toℕ‿ℕ- n zero = sym (toℕ-fromℕ n) +ℕ-ℕ≡toℕ‿ℕ- (suc n) (suc i) = ℕ-ℕ≡toℕ‿ℕ- n i + +nℕ-ℕi≤n : ∀ n i → n ℕ-ℕ i ℕ.≤ n +nℕ-ℕi≤n n zero = ℕₚ.≤-refl +nℕ-ℕi≤n (suc n) (suc i) = begin + n ℕ-ℕ i ≤⟨ nℕ-ℕi≤n n i ⟩ + n ≤⟨ ℕₚ.n≤1+n n ⟩ + suc n ∎ + where open ℕₚ.≤-Reasoning + +------------------------------------------------------------------------ +-- punchIn +------------------------------------------------------------------------ + +punchIn-injective : ∀ i (j k : Fin n) → + punchIn i j ≡ punchIn i k → j ≡ k +punchIn-injective zero _ _ refl = refl +punchIn-injective (suc i) zero zero _ = refl +punchIn-injective (suc i) (suc j) (suc k) ↑j+1≡↑k+1 = + cong suc (punchIn-injective i j k (suc-injective ↑j+1≡↑k+1)) + +punchInᵢ≢i : ∀ i (j : Fin n) → punchIn i j ≢ i +punchInᵢ≢i (suc i) (suc j) = punchInᵢ≢i i j ∘ suc-injective + +------------------------------------------------------------------------ +-- punchOut +------------------------------------------------------------------------ + +-- A version of 'cong' for 'punchOut' in which the inequality argument +-- can be changed out arbitrarily (reflecting the proof-irrelevance of +-- that argument). + +punchOut-cong : ∀ (i : Fin (suc n)) {j k} {i≢j : i ≢ j} {i≢k : i ≢ k} → + j ≡ k → punchOut i≢j ≡ punchOut i≢k +punchOut-cong {_} zero {zero} {i≢j = 0≢0} = contradiction refl 0≢0 +punchOut-cong {_} zero {suc j} {zero} {i≢k = 0≢0} = contradiction refl 0≢0 +punchOut-cong {_} zero {suc j} {suc k} = suc-injective +punchOut-cong {suc n} (suc i) {zero} {zero} _ = refl +punchOut-cong {suc n} (suc i) {suc j} {suc k} = cong suc ∘ punchOut-cong i ∘ suc-injective + +-- An alternative to 'punchOut-cong' in the which the new inequality +-- argument is specific. Useful for enabling the omission of that +-- argument during equational reasoning. + +punchOut-cong′ : ∀ (i : Fin (suc n)) {j k} {p : i ≢ j} (q : j ≡ k) → + punchOut p ≡ punchOut (p ∘ sym ∘ trans q ∘ sym) +punchOut-cong′ i q = punchOut-cong i q + +punchOut-injective : ∀ {i j k : Fin (suc n)} + (i≢j : i ≢ j) (i≢k : i ≢ k) → + punchOut i≢j ≡ punchOut i≢k → j ≡ k +punchOut-injective {_} {zero} {zero} {_} 0≢0 _ _ = contradiction refl 0≢0 +punchOut-injective {_} {zero} {_} {zero} _ 0≢0 _ = contradiction refl 0≢0 +punchOut-injective {_} {zero} {suc j} {suc k} _ _ pⱼ≡pₖ = cong suc pⱼ≡pₖ +punchOut-injective {suc n} {suc i} {zero} {zero} _ _ _ = refl +punchOut-injective {suc n} {suc i} {suc j} {suc k} i≢j i≢k pⱼ≡pₖ = + cong suc (punchOut-injective (i≢j ∘ cong suc) (i≢k ∘ cong suc) (suc-injective pⱼ≡pₖ)) + +punchIn-punchOut : ∀ {i j : Fin (suc n)} (i≢j : i ≢ j) → + punchIn i (punchOut i≢j) ≡ j +punchIn-punchOut {_} {zero} {zero} 0≢0 = contradiction refl 0≢0 +punchIn-punchOut {_} {zero} {suc j} _ = refl +punchIn-punchOut {suc m} {suc i} {zero} i≢j = refl +punchIn-punchOut {suc m} {suc i} {suc j} i≢j = + cong suc (punchIn-punchOut (i≢j ∘ cong suc)) + +punchOut-punchIn : ∀ i {j : Fin n} → punchOut {i = i} {j = punchIn i j} (punchInᵢ≢i i j ∘ sym) ≡ j +punchOut-punchIn zero {j} = refl +punchOut-punchIn (suc i) {zero} = refl +punchOut-punchIn (suc i) {suc j} = cong suc (begin + punchOut (punchInᵢ≢i i j ∘ suc-injective ∘ sym ∘ cong suc) ≡⟨ punchOut-cong i refl ⟩ + punchOut (punchInᵢ≢i i j ∘ sym) ≡⟨ punchOut-punchIn i ⟩ + j ∎) + where open ≡-Reasoning + + +------------------------------------------------------------------------ +-- pinch +------------------------------------------------------------------------ + +pinch-surjective : ∀ (i : Fin n) → Surjective _≡_ _≡_ (pinch i) +pinch-surjective _ zero = zero , λ { refl → refl } +pinch-surjective zero (suc j) = suc (suc j) , λ { refl → refl } +pinch-surjective (suc i) (suc j) = map suc (λ {f refl → cong suc (f refl)}) (pinch-surjective i j) + +pinch-mono-≤ : ∀ (i : Fin n) → (pinch i) Preserves _≤_ ⟶ _≤_ +pinch-mono-≤ 0F {0F} {k} 0≤n = z≤n +pinch-mono-≤ 0F {suc j} {suc k} j≤k = ℕ.s≤s⁻¹ j≤k +pinch-mono-≤ (suc i) {0F} {k} 0≤n = z≤n +pinch-mono-≤ (suc i) {suc j} {suc k} j≤k = s≤s (pinch-mono-≤ i (ℕ.s≤s⁻¹ j≤k)) + +pinch-injective : ∀ {i : Fin n} {j k : Fin (ℕ.suc n)} → + suc i ≢ j → suc i ≢ k → pinch i j ≡ pinch i k → j ≡ k +pinch-injective {i = i} {zero} {zero} _ _ _ = refl +pinch-injective {i = zero} {zero} {suc k} _ 1+i≢k eq = + contradiction (cong suc eq) 1+i≢k +pinch-injective {i = zero} {suc j} {zero} 1+i≢j _ eq = + contradiction (cong suc (sym eq)) 1+i≢j +pinch-injective {i = zero} {suc j} {suc k} _ _ eq = + cong suc eq +pinch-injective {i = suc i} {suc j} {suc k} 1+i≢j 1+i≢k eq = + cong suc + (pinch-injective (1+i≢j ∘ cong suc) (1+i≢k ∘ cong suc) + (suc-injective eq)) + +------------------------------------------------------------------------ +-- Quantification +------------------------------------------------------------------------ + +module _ {p} {P : Pred (Fin (suc n)) p} where + + ∀-cons : P zero → Π[ P ∘ suc ] → Π[ P ] + ∀-cons z s zero = z + ∀-cons z s (suc i) = s i + + ∀-cons-⇔ : (P zero × Π[ P ∘ suc ]) ⇔ Π[ P ] + ∀-cons-⇔ = mk⇔ (uncurry ∀-cons) < _$ zero , _∘ suc > + + ∃-here : P zero → ∃⟨ P ⟩ + ∃-here = zero ,_ + + ∃-there : ∃⟨ P ∘ suc ⟩ → ∃⟨ P ⟩ + ∃-there = map suc id + + ∃-toSum : ∃⟨ P ⟩ → P zero ⊎ ∃⟨ P ∘ suc ⟩ + ∃-toSum ( zero , P₀ ) = inj₁ P₀ + ∃-toSum (suc f , P₁₊) = inj₂ (f , P₁₊) + + ⊎⇔∃ : (P zero ⊎ ∃⟨ P ∘ suc ⟩) ⇔ ∃⟨ P ⟩ + ⊎⇔∃ = mk⇔ [ ∃-here , ∃-there ] ∃-toSum + +decFinSubset : ∀ {p q} {P : Pred (Fin n) p} {Q : Pred (Fin n) q} → + Decidable Q → (∀ {i} → Q i → Dec (P i)) → Dec (Q ⊆ P) +decFinSubset {zero} {_} {_} Q? P? = yes λ {} +decFinSubset {suc n} {P = P} {Q} Q? P? + with Q? zero | ∀-cons {P = λ x → Q x → P x} +... | false because [¬Q0] | cons = + map′ (λ f {x} → cons (⊥-elim ∘ invert [¬Q0]) (λ x → f {x}) x) + (λ f {x} → f {suc x}) + (decFinSubset (Q? ∘ suc) P?) +... | true because [Q0] | cons = + map′ (uncurry λ P0 rec {x} → cons (λ _ → P0) (λ x → rec {x}) x) + < _$ invert [Q0] , (λ f {x} → f {suc x}) > + (P? (invert [Q0]) ×-dec decFinSubset (Q? ∘ suc) P?) + +any? : ∀ {p} {P : Pred (Fin n) p} → Decidable P → Dec (∃ P) +any? {zero} {P = _} P? = no λ { (() , _) } +any? {suc n} {P = P} P? = Dec.map ⊎⇔∃ (P? zero ⊎-dec any? (P? ∘ suc)) + +all? : ∀ {p} {P : Pred (Fin n) p} → Decidable P → Dec (∀ f → P f) +all? P? = map′ (λ ∀p f → ∀p tt) (λ ∀p {x} _ → ∀p x) + (decFinSubset U? (λ {f} _ → P? f)) + +private + -- A nice computational property of `all?`: + -- The boolean component of the result is exactly the + -- obvious fold of boolean tests (`foldr _∧_ true`). + note : ∀ {p} {P : Pred (Fin 3) p} (P? : Decidable P) → + ∃ λ z → Dec.does (all? P?) ≡ z + note P? = Dec.does (P? 0F) ∧ Dec.does (P? 1F) ∧ Dec.does (P? 2F) ∧ true + , refl + +-- If a decidable predicate P over a finite set is sometimes false, +-- then we can find the smallest value for which this is the case. + +¬∀⟶∃¬-smallest : ∀ n {p} (P : Pred (Fin n) p) → Decidable P → + ¬ (∀ i → P i) → ∃ λ i → ¬ P i × ((j : Fin′ i) → P (inject j)) +¬∀⟶∃¬-smallest zero P P? ¬∀P = contradiction (λ()) ¬∀P +¬∀⟶∃¬-smallest (suc n) P P? ¬∀P with P? zero +... | false because [¬P₀] = (zero , invert [¬P₀] , λ ()) +... | true because [P₀] = map suc (map id (∀-cons (invert [P₀]))) + (¬∀⟶∃¬-smallest n (P ∘ suc) (P? ∘ suc) (¬∀P ∘ (∀-cons (invert [P₀])))) + +-- When P is a decidable predicate over a finite set the following +-- lemma can be proved. + +¬∀⟶∃¬ : ∀ n {p} (P : Pred (Fin n) p) → Decidable P → + ¬ (∀ i → P i) → (∃ λ i → ¬ P i) +¬∀⟶∃¬ n P P? ¬P = map id proj₁ (¬∀⟶∃¬-smallest n P P? ¬P) + +------------------------------------------------------------------------ +-- Properties of functions to and from Fin +------------------------------------------------------------------------ + +-- The pigeonhole principle. + +pigeonhole : m ℕ.< n → (f : Fin n → Fin m) → ∃₂ λ i j → i < j × f i ≡ f j +pigeonhole z<s f = contradiction (f zero) λ() +pigeonhole (s<s m<n@(s≤s _)) f with any? (λ k → f zero ≟ f (suc k)) +... | yes (j , f₀≡fⱼ) = zero , suc j , z<s , f₀≡fⱼ +... | no f₀≢fₖ + with i , j , i<j , fᵢ≡fⱼ ← pigeonhole m<n (λ j → punchOut (f₀≢fₖ ∘ (j ,_ ))) + = suc i , suc j , s<s i<j , punchOut-injective (f₀≢fₖ ∘ (i ,_)) _ fᵢ≡fⱼ + +injective⇒≤ : ∀ {f : Fin m → Fin n} → Injective _≡_ _≡_ f → m ℕ.≤ n +injective⇒≤ {zero} {_} {f} _ = z≤n +injective⇒≤ {suc _} {zero} {f} _ = contradiction (f zero) ¬Fin0 +injective⇒≤ {suc _} {suc _} {f} inj = s≤s (injective⇒≤ (λ eq → + suc-injective (inj (punchOut-injective + (contraInjective inj 0≢1+n) + (contraInjective inj 0≢1+n) eq)))) + +<⇒notInjective : ∀ {f : Fin m → Fin n} → n ℕ.< m → ¬ (Injective _≡_ _≡_ f) +<⇒notInjective n<m inj = ℕₚ.≤⇒≯ (injective⇒≤ inj) n<m + +ℕ→Fin-notInjective : ∀ (f : ℕ → Fin n) → ¬ (Injective _≡_ _≡_ f) +ℕ→Fin-notInjective f inj = ℕₚ.<-irrefl refl + (injective⇒≤ (Comp.injective _≡_ _≡_ _≡_ toℕ-injective inj)) + +-- Cantor-Schröder-Bernstein for finite sets + +cantor-schröder-bernstein : ∀ {f : Fin m → Fin n} {g : Fin n → Fin m} → + Injective _≡_ _≡_ f → Injective _≡_ _≡_ g → + m ≡ n +cantor-schröder-bernstein f-inj g-inj = ℕₚ.≤-antisym + (injective⇒≤ f-inj) (injective⇒≤ g-inj) + +------------------------------------------------------------------------ +-- Effectful +------------------------------------------------------------------------ + +module _ {f} {F : Set f → Set f} (RA : RawApplicative F) where + + open RawApplicative RA + + sequence : ∀ {n} {P : Pred (Fin n) f} → + (∀ i → F (P i)) → F (∀ i → P i) + sequence {zero} ∀iPi = pure λ() + sequence {suc n} ∀iPi = ∀-cons <$> ∀iPi zero <*> sequence (∀iPi ∘ suc) + +module _ {f} {F : Set f → Set f} (RF : RawFunctor F) where + + open RawFunctor RF + + sequence⁻¹ : ∀ {A : Set f} {P : Pred A f} → + F (∀ i → P i) → (∀ i → F (P i)) + sequence⁻¹ F∀iPi i = (λ f → f i) <$> F∀iPi + +------------------------------------------------------------------------ +-- If there is an injection from a type A to a finite set, then the type +-- has decidable equality. + +module _ {ℓ} {S : Setoid a ℓ} (inj : Injection S (≡-setoid n)) where + open Setoid S + + inj⇒≟ : B.Decidable _≈_ + inj⇒≟ = Dec.via-injection inj _≟_ + + inj⇒decSetoid : DecSetoid a ℓ + inj⇒decSetoid = record + { isDecEquivalence = record + { isEquivalence = isEquivalence + ; _≟_ = inj⇒≟ + } + } + +------------------------------------------------------------------------ +-- Opposite +------------------------------------------------------------------------ + +opposite-prop : ∀ (i : Fin n) → toℕ (opposite i) ≡ n ∸ suc (toℕ i) +opposite-prop {suc n} zero = toℕ-fromℕ n +opposite-prop {suc n} (suc i) = begin + toℕ (inject₁ (opposite i)) ≡⟨ toℕ-inject₁ (opposite i) ⟩ + toℕ (opposite i) ≡⟨ opposite-prop i ⟩ + n ∸ suc (toℕ i) ∎ + where open ≡-Reasoning + +opposite-involutive : Involutive {A = Fin n} _≡_ opposite +opposite-involutive {suc n} i = toℕ-injective (begin + toℕ (opposite (opposite i)) ≡⟨ opposite-prop (opposite i) ⟩ + n ∸ (toℕ (opposite i)) ≡⟨ cong (n ∸_) (opposite-prop i) ⟩ + n ∸ (n ∸ (toℕ i)) ≡⟨ ℕₚ.m∸[m∸n]≡n (toℕ≤pred[n] i) ⟩ + toℕ i ∎) + where open ≡-Reasoning + +opposite-suc : ∀ (i : Fin n) → toℕ (opposite (suc i)) ≡ toℕ (opposite i) +opposite-suc {n} i = begin + toℕ (opposite (suc i)) ≡⟨ opposite-prop (suc i) ⟩ + suc n ∸ suc (toℕ (suc i)) ≡⟨⟩ + n ∸ toℕ (suc i) ≡⟨⟩ + n ∸ suc (toℕ i) ≡⟨ opposite-prop i ⟨ + toℕ (opposite i) ∎ + where open ≡-Reasoning + + +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 1.5 + +inject+-raise-splitAt = join-splitAt +{-# WARNING_ON_USAGE inject+-raise-splitAt +"Warning: inject+-raise-splitAt was deprecated in v1.5. Please use join-splitAt instead." -#-} +#-} --- Version 2.0 +-- Version 2.0 -toℕ-raise = toℕ-↑ʳ -{-# WARNING_ON_USAGE toℕ-raise -"Warning: toℕ-raise was deprecated in v2.0. +toℕ-raise = toℕ-↑ʳ +{-# WARNING_ON_USAGE toℕ-raise +"Warning: toℕ-raise was deprecated in v2.0. Please use toℕ-↑ʳ instead." -#-} -toℕ-inject+ : ∀ {m} n (i : Fin m) → toℕ i ≡ toℕ (i ↑ˡ n) -toℕ-inject+ n i = sym (toℕ-↑ˡ i n) -{-# WARNING_ON_USAGE toℕ-inject+ -"Warning: toℕ-inject+ was deprecated in v2.0. +#-} +toℕ-inject+ : ∀ {m} n (i : Fin m) → toℕ i ≡ toℕ (i ↑ˡ n) +toℕ-inject+ n i = sym (toℕ-↑ˡ i n) +{-# WARNING_ON_USAGE toℕ-inject+ +"Warning: toℕ-inject+ was deprecated in v2.0. Please use toℕ-↑ˡ instead. NB argument order has been flipped: the left-hand argument is the Fin m the right-hand is the Nat index increment." -#-} -splitAt-inject+ : ∀ m n i → splitAt m (i ↑ˡ n) ≡ inj₁ i -splitAt-inject+ m n i = splitAt-↑ˡ m i n -{-# WARNING_ON_USAGE splitAt-inject+ -"Warning: splitAt-inject+ was deprecated in v2.0. +#-} +splitAt-inject+ : ∀ m n i → splitAt m (i ↑ˡ n) ≡ inj₁ i +splitAt-inject+ m n i = splitAt-↑ˡ m i n +{-# WARNING_ON_USAGE splitAt-inject+ +"Warning: splitAt-inject+ was deprecated in v2.0. Please use splitAt-↑ˡ instead. NB argument order has been flipped." -#-} -splitAt-raise : ∀ m n i → splitAt m (m ↑ʳ i) ≡ inj₂ {B = Fin n} i -splitAt-raise = splitAt-↑ʳ -{-# WARNING_ON_USAGE splitAt-raise -"Warning: splitAt-raise was deprecated in v2.0. +#-} +splitAt-raise : ∀ m n i → splitAt m (m ↑ʳ i) ≡ inj₂ {B = Fin n} i +splitAt-raise = splitAt-↑ʳ +{-# WARNING_ON_USAGE splitAt-raise +"Warning: splitAt-raise was deprecated in v2.0. Please use splitAt-↑ʳ instead." -#-} -Fin0↔⊥ : Fin 0 ↔ ⊥ -Fin0↔⊥ = 0↔⊥ -{-# WARNING_ON_USAGE Fin0↔⊥ -"Warning: Fin0↔⊥ was deprecated in v2.0. +#-} +Fin0↔⊥ : Fin 0 ↔ ⊥ +Fin0↔⊥ = 0↔⊥ +{-# WARNING_ON_USAGE Fin0↔⊥ +"Warning: Fin0↔⊥ was deprecated in v2.0. Please use 0↔⊥ instead." -#-} -eq? : A ↣ Fin n → DecidableEquality A -eq? = inj⇒≟ -{-# WARNING_ON_USAGE eq? -"Warning: eq? was deprecated in v2.0. +#-} +eq? : A ↣ Fin n → DecidableEquality A +eq? = inj⇒≟ +{-# WARNING_ON_USAGE eq? +"Warning: eq? was deprecated in v2.0. Please use inj⇒≟ instead." -#-} +#-} -private +private - z≺s : ∀ {n} → zero ≺ suc n - z≺s = _ ≻toℕ zero + z≺s : ∀ {n} → zero ≺ suc n + z≺s = _ ≻toℕ zero - s≺s : ∀ {m n} → m ≺ n → suc m ≺ suc n - s≺s (n ≻toℕ i) = (suc n) ≻toℕ (suc i) + s≺s : ∀ {m n} → m ≺ n → suc m ≺ suc n + s≺s (n ≻toℕ i) = (suc n) ≻toℕ (suc i) - <⇒≺ : ℕ._<_ ⇒ _≺_ - <⇒≺ {zero} z<s = z≺s - <⇒≺ {suc m} (s<s lt) = s≺s (<⇒≺ lt) + <⇒≺ : ℕ._<_ ⇒ _≺_ + <⇒≺ {zero} z<s = z≺s + <⇒≺ {suc m} (s<s lt) = s≺s (<⇒≺ lt) - ≺⇒< : _≺_ ⇒ ℕ._<_ - ≺⇒< (n ≻toℕ i) = toℕ<n i + ≺⇒< : _≺_ ⇒ ℕ._<_ + ≺⇒< (n ≻toℕ i) = toℕ<n i -≺⇒<′ : _≺_ ⇒ ℕ._<′_ -≺⇒<′ lt = ℕₚ.<⇒<′ (≺⇒< lt) -{-# WARNING_ON_USAGE ≺⇒<′ -"Warning: ≺⇒<′ was deprecated in v2.0. +≺⇒<′ : _≺_ ⇒ ℕ._<′_ +≺⇒<′ lt = ℕₚ.<⇒<′ (≺⇒< lt) +{-# WARNING_ON_USAGE ≺⇒<′ +"Warning: ≺⇒<′ was deprecated in v2.0. Please use <⇒<′ instead." -#-} +#-} -<′⇒≺ : ℕ._<′_ ⇒ _≺_ -<′⇒≺ lt = <⇒≺ (ℕₚ.<′⇒< lt) -{-# WARNING_ON_USAGE <′⇒≺ -"Warning: <′⇒≺ was deprecated in v2.0. +<′⇒≺ : ℕ._<′_ ⇒ _≺_ +<′⇒≺ lt = <⇒≺ (ℕₚ.<′⇒< lt) +{-# WARNING_ON_USAGE <′⇒≺ +"Warning: <′⇒≺ was deprecated in v2.0. Please use <′⇒< instead." -#-} - +#-} \ No newline at end of file diff --git a/Data.Fin.html b/Data.Fin.html index 265b10a6..e65fd14b 100644 --- a/Data.Fin.html +++ b/Data.Fin.html @@ -22,12 +22,12 @@ -- Publicly re-export queries open import Data.Fin.Properties public - using (_≟_; _≤?_; _<?_) + using (_≟_; _≤?_; _<?_) -- # m = "m". infix 10 #_ -#_ : ∀ m {n} {m<n : True (suc m ℕₚ.≤? n)} → Fin n -#_ _ {m<n = m<n} = fromℕ< (toWitness m<n) +#_ : ∀ m {n} {m<n : True (suc m ℕₚ.≤? n)} → Fin n +#_ _ {m<n = m<n} = fromℕ< (toWitness m<n) \ No newline at end of file diff --git a/Data.Integer.Base.html b/Data.Integer.Base.html index 6cc3c8fb..1f1973ad 100644 --- a/Data.Integer.Base.html +++ b/Data.Integer.Base.html @@ -13,335 +13,338 @@ module Data.Integer.Base where open import Algebra.Bundles.Raw - using (RawMagma; RawMonoid; RawGroup; RawNearSemiring; RawSemiring; RawRing) -open import Data.Bool.Base using (Bool; T; true; false) -open import Data.Nat.Base as ℕ using (ℕ; z≤n; s≤s) -open import Data.Sign.Base as Sign using (Sign) -open import Level using (0ℓ) -open import Relation.Binary.Core using (Rel) -open import Relation.Binary.PropositionalEquality.Core - using (_≡_; _≢_; refl) -open import Relation.Nullary.Negation.Core using (¬_; contradiction) -open import Relation.Unary using (Pred) + using (RawMagma; RawMonoid; RawGroup; RawNearSemiring; RawSemiring; RawRing) +open import Data.Bool.Base using (Bool; T; true; false) +open import Data.Nat.Base as ℕ using (ℕ; z≤n; s≤s) hiding (module ℕ) +open import Data.Sign.Base as Sign using (Sign) +open import Level using (0ℓ) +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.PropositionalEquality.Core + using (_≡_; _≢_; refl) +open import Relation.Nullary.Negation.Core using (¬_; contradiction) +open import Relation.Unary using (Pred) -infix 8 -_ -infixr 8 _^_ -infixl 7 _*_ _⊓_ _/ℕ_ _/_ _%ℕ_ _%_ -infixl 6 _+_ _-_ _⊖_ _⊔_ -infix 4 _≤_ _≥_ _<_ _>_ _≰_ _≱_ _≮_ _≯_ -infix 4 _≤ᵇ_ +infix 8 -_ +infixr 8 _^_ +infixl 7 _*_ _⊓_ _/ℕ_ _/_ _%ℕ_ _%_ +infixl 6 _+_ _-_ _⊖_ _⊔_ +infix 4 _≤_ _≥_ _<_ _>_ _≰_ _≱_ _≮_ _≯_ +infix 4 _≤ᵇ_ ------------------------------------------------------------------------- --- Types +------------------------------------------------------------------------ +-- Types -open import Agda.Builtin.Int public - using () - renaming - ( Int to ℤ - ; pos to +_ -- "+ n" stands for "n" - ; negsuc to -[1+_] -- "-[1+ n ]" stands for "- (1 + n)" - ) +open import Agda.Builtin.Int public + using () + renaming + ( Int to ℤ + ; pos to +_ -- "+ n" stands for "n" + ; negsuc to -[1+_] -- "-[1+ n ]" stands for "- (1 + n)" + ) --- Some additional patterns that provide symmetry around 0 +-- Some additional patterns that provide symmetry around 0 -pattern +0 = + 0 -pattern +[1+_] n = + (ℕ.suc n) +pattern +0 = + 0 +pattern +[1+_] n = + (ℕ.suc n) ------------------------------------------------------------------------- --- Constants +------------------------------------------------------------------------ +-- Constants -0ℤ : ℤ -0ℤ = +0 +0ℤ : ℤ +0ℤ = +0 --1ℤ : ℤ --1ℤ = -[1+ 0 ] +-1ℤ : ℤ +-1ℤ = -[1+ 0 ] -1ℤ : ℤ -1ℤ = +[1+ 0 ] +1ℤ : ℤ +1ℤ = +[1+ 0 ] ------------------------------------------------------------------------- --- Conversion +------------------------------------------------------------------------ +-- Conversion --- Absolute value. +-- Absolute value. -∣_∣ : ℤ → ℕ -∣ + n ∣ = n -∣ -[1+ n ] ∣ = ℕ.suc n +∣_∣ : ℤ → ℕ +∣ + n ∣ = n +∣ -[1+ n ] ∣ = ℕ.suc n --- Gives the sign. For zero the sign is arbitrarily chosen to be +. +-- Gives the sign. For zero the sign is arbitrarily chosen to be +. -sign : ℤ → Sign -sign (+ _) = Sign.+ -sign -[1+ _ ] = Sign.- +sign : ℤ → Sign +sign (+ _) = Sign.+ +sign -[1+ _ ] = Sign.- ------------------------------------------------------------------------- --- Ordering +------------------------------------------------------------------------ +-- Ordering -data _≤_ : ℤ → ℤ → Set where - -≤- : ∀ {m n} → (n≤m : n ℕ.≤ m) → -[1+ m ] ≤ -[1+ n ] - -≤+ : ∀ {m n} → -[1+ m ] ≤ + n - +≤+ : ∀ {m n} → (m≤n : m ℕ.≤ n) → + m ≤ + n +data _≤_ : ℤ → ℤ → Set where + -≤- : ∀ {m n} → (n≤m : n ℕ.≤ m) → -[1+ m ] ≤ -[1+ n ] + -≤+ : ∀ {m n} → -[1+ m ] ≤ + n + +≤+ : ∀ {m n} → (m≤n : m ℕ.≤ n) → + m ≤ + n -data _<_ : ℤ → ℤ → Set where - -<- : ∀ {m n} → (n<m : n ℕ.< m) → -[1+ m ] < -[1+ n ] - -<+ : ∀ {m n} → -[1+ m ] < + n - +<+ : ∀ {m n} → (m<n : m ℕ.< n) → + m < + n +data _<_ : ℤ → ℤ → Set where + -<- : ∀ {m n} → (n<m : n ℕ.< m) → -[1+ m ] < -[1+ n ] + -<+ : ∀ {m n} → -[1+ m ] < + n + +<+ : ∀ {m n} → (m<n : m ℕ.< n) → + m < + n -_≥_ : Rel ℤ 0ℓ -x ≥ y = y ≤ x +_≥_ : Rel ℤ 0ℓ +x ≥ y = y ≤ x -_>_ : Rel ℤ 0ℓ -x > y = y < x +_>_ : Rel ℤ 0ℓ +x > y = y < x -_≰_ : Rel ℤ 0ℓ -x ≰ y = ¬ (x ≤ y) +_≰_ : Rel ℤ 0ℓ +x ≰ y = ¬ (x ≤ y) -_≱_ : Rel ℤ 0ℓ -x ≱ y = ¬ (x ≥ y) +_≱_ : Rel ℤ 0ℓ +x ≱ y = ¬ (x ≥ y) -_≮_ : Rel ℤ 0ℓ -x ≮ y = ¬ (x < y) +_≮_ : Rel ℤ 0ℓ +x ≮ y = ¬ (x < y) -_≯_ : Rel ℤ 0ℓ -x ≯ y = ¬ (x > y) +_≯_ : Rel ℤ 0ℓ +x ≯ y = ¬ (x > y) ------------------------------------------------------------------------- --- Boolean ordering +------------------------------------------------------------------------ +-- Boolean ordering --- A boolean version. -_≤ᵇ_ : ℤ → ℤ → Bool --[1+ m ] ≤ᵇ -[1+ n ] = n ℕ.≤ᵇ m -(+ m) ≤ᵇ -[1+ n ] = false --[1+ m ] ≤ᵇ (+ n) = true -(+ m) ≤ᵇ (+ n) = m ℕ.≤ᵇ n +-- A boolean version. +_≤ᵇ_ : ℤ → ℤ → Bool +-[1+ m ] ≤ᵇ -[1+ n ] = n ℕ.≤ᵇ m +(+ m) ≤ᵇ -[1+ n ] = false +-[1+ m ] ≤ᵇ (+ n) = true +(+ m) ≤ᵇ (+ n) = m ℕ.≤ᵇ n ------------------------------------------------------------------------- --- Simple predicates +------------------------------------------------------------------------ +-- Simple predicates --- See `Data.Nat.Base` for a discussion on the design of these. +-- See `Data.Nat.Base` for a discussion on the design of these. -NonZero : Pred ℤ 0ℓ -NonZero i = ℕ.NonZero ∣ i ∣ +NonZero : Pred ℤ 0ℓ +NonZero i = ℕ.NonZero ∣ i ∣ -record Positive (i : ℤ) : Set where - field - pos : T (1ℤ ≤ᵇ i) +record Positive (i : ℤ) : Set where + field + pos : T (1ℤ ≤ᵇ i) -record NonNegative (i : ℤ) : Set where - field - nonNeg : T (0ℤ ≤ᵇ i) +record NonNegative (i : ℤ) : Set where + field + nonNeg : T (0ℤ ≤ᵇ i) -record NonPositive (i : ℤ) : Set where - field - nonPos : T (i ≤ᵇ 0ℤ) +record NonPositive (i : ℤ) : Set where + field + nonPos : T (i ≤ᵇ 0ℤ) -record Negative (i : ℤ) : Set where - field - neg : T (i ≤ᵇ -1ℤ) +record Negative (i : ℤ) : Set where + field + neg : T (i ≤ᵇ -1ℤ) --- Instances +-- Instances -instance - pos : ∀ {n} → Positive +[1+ n ] - pos = _ +open ℕ public + using (nonZero) - nonNeg : ∀ {n} → NonNegative (+ n) - nonNeg = _ +instance + pos : ∀ {n} → Positive +[1+ n ] + pos = _ - nonPos0 : NonPositive 0ℤ - nonPos0 = _ + nonNeg : ∀ {n} → NonNegative (+ n) + nonNeg = _ - nonPos : ∀ {n} → NonPositive -[1+ n ] - nonPos = _ + nonPos0 : NonPositive 0ℤ + nonPos0 = _ - neg : ∀ {n} → Negative -[1+ n ] - neg = _ + nonPos : ∀ {n} → NonPositive -[1+ n ] + nonPos = _ --- Constructors + neg : ∀ {n} → Negative -[1+ n ] + neg = _ -≢-nonZero : ∀ {i} → i ≢ 0ℤ → NonZero i -≢-nonZero { +[1+ n ]} _ = _ -≢-nonZero { +0} 0≢0 = contradiction refl 0≢0 -≢-nonZero { -[1+ n ]} _ = _ +-- Constructors ->-nonZero : ∀ {i} → i > 0ℤ → NonZero i ->-nonZero (+<+ (s≤s m<n)) = _ +≢-nonZero : ∀ {i} → i ≢ 0ℤ → NonZero i +≢-nonZero { +[1+ n ]} _ = _ +≢-nonZero { +0} 0≢0 = contradiction refl 0≢0 +≢-nonZero { -[1+ n ]} _ = _ -<-nonZero : ∀ {i} → i < 0ℤ → NonZero i -<-nonZero -<+ = _ +>-nonZero : ∀ {i} → i > 0ℤ → NonZero i +>-nonZero (+<+ (s≤s m<n)) = _ -positive : ∀ {i} → i > 0ℤ → Positive i -positive (+<+ (s≤s m<n)) = _ +<-nonZero : ∀ {i} → i < 0ℤ → NonZero i +<-nonZero -<+ = _ -negative : ∀ {i} → i < 0ℤ → Negative i -negative -<+ = _ +positive : ∀ {i} → i > 0ℤ → Positive i +positive (+<+ (s≤s m<n)) = _ -nonPositive : ∀ {i} → i ≤ 0ℤ → NonPositive i -nonPositive -≤+ = _ -nonPositive (+≤+ z≤n) = _ +negative : ∀ {i} → i < 0ℤ → Negative i +negative -<+ = _ -nonNegative : ∀ {i} → i ≥ 0ℤ → NonNegative i -nonNegative {+0} _ = _ -nonNegative {+[1+ n ]} _ = _ +nonPositive : ∀ {i} → i ≤ 0ℤ → NonPositive i +nonPositive -≤+ = _ +nonPositive (+≤+ z≤n) = _ ------------------------------------------------------------------------- --- A view of integers as sign + absolute value +nonNegative : ∀ {i} → i ≥ 0ℤ → NonNegative i +nonNegative {+0} _ = _ +nonNegative {+[1+ n ]} _ = _ -infix 5 _◂_ _◃_ +------------------------------------------------------------------------ +-- A view of integers as sign + absolute value -_◃_ : Sign → ℕ → ℤ -_ ◃ ℕ.zero = +0 -Sign.+ ◃ n = + n -Sign.- ◃ ℕ.suc n = -[1+ n ] +infix 5 _◂_ _◃_ -data SignAbs : ℤ → Set where - _◂_ : (s : Sign) (n : ℕ) → SignAbs (s ◃ n) +_◃_ : Sign → ℕ → ℤ +_ ◃ ℕ.zero = +0 +Sign.+ ◃ n = + n +Sign.- ◃ ℕ.suc n = -[1+ n ] -signAbs : ∀ i → SignAbs i -signAbs -[1+ n ] = Sign.- ◂ ℕ.suc n -signAbs +0 = Sign.+ ◂ ℕ.zero -signAbs +[1+ n ] = Sign.+ ◂ ℕ.suc n +data SignAbs : ℤ → Set where + _◂_ : (s : Sign) (n : ℕ) → SignAbs (s ◃ n) ------------------------------------------------------------------------- --- Arithmetic +signAbs : ∀ i → SignAbs i +signAbs -[1+ n ] = Sign.- ◂ ℕ.suc n +signAbs +0 = Sign.+ ◂ ℕ.zero +signAbs +[1+ n ] = Sign.+ ◂ ℕ.suc n --- Negation. +------------------------------------------------------------------------ +-- Arithmetic --_ : ℤ → ℤ -- -[1+ n ] = +[1+ n ] -- +0 = +0 -- +[1+ n ] = -[1+ n ] +-- Negation. --- Subtraction of natural numbers. --- We define it using _<ᵇ_ and _∸_ rather than inductively so that it --- is backed by builtin operations. This makes it much faster. -_⊖_ : ℕ → ℕ → ℤ -m ⊖ n with m ℕ.<ᵇ n -... | true = - + (n ℕ.∸ m) -... | false = + (m ℕ.∸ n) +-_ : ℤ → ℤ +- -[1+ n ] = +[1+ n ] +- +0 = +0 +- +[1+ n ] = -[1+ n ] --- Addition. +-- Subtraction of natural numbers. +-- We define it using _<ᵇ_ and _∸_ rather than inductively so that it +-- is backed by builtin operations. This makes it much faster. +_⊖_ : ℕ → ℕ → ℤ +m ⊖ n with m ℕ.<ᵇ n +... | true = - + (n ℕ.∸ m) +... | false = + (m ℕ.∸ n) -_+_ : ℤ → ℤ → ℤ --[1+ m ] + -[1+ n ] = -[1+ ℕ.suc (m ℕ.+ n) ] --[1+ m ] + + n = n ⊖ ℕ.suc m -+ m + -[1+ n ] = m ⊖ ℕ.suc n -+ m + + n = + (m ℕ.+ n) +-- Addition. --- Subtraction. +_+_ : ℤ → ℤ → ℤ +-[1+ m ] + -[1+ n ] = -[1+ ℕ.suc (m ℕ.+ n) ] +-[1+ m ] + + n = n ⊖ ℕ.suc m ++ m + -[1+ n ] = m ⊖ ℕ.suc n ++ m + + n = + (m ℕ.+ n) -_-_ : ℤ → ℤ → ℤ -i - j = i + (- j) +-- Subtraction. --- Successor. +_-_ : ℤ → ℤ → ℤ +i - j = i + (- j) -suc : ℤ → ℤ -suc i = 1ℤ + i +-- Successor. --- Predecessor. +suc : ℤ → ℤ +suc i = 1ℤ + i -pred : ℤ → ℤ -pred i = -1ℤ + i +-- Predecessor. --- Multiplication. +pred : ℤ → ℤ +pred i = -1ℤ + i -_*_ : ℤ → ℤ → ℤ -i * j = sign i Sign.* sign j ◃ ∣ i ∣ ℕ.* ∣ j ∣ +-- Multiplication. --- Naïve exponentiation. +_*_ : ℤ → ℤ → ℤ +i * j = sign i Sign.* sign j ◃ ∣ i ∣ ℕ.* ∣ j ∣ -_^_ : ℤ → ℕ → ℤ -i ^ ℕ.zero = 1ℤ -i ^ (ℕ.suc m) = i * i ^ m +-- Naïve exponentiation. --- Maximum. +_^_ : ℤ → ℕ → ℤ +i ^ ℕ.zero = 1ℤ +i ^ (ℕ.suc m) = i * i ^ m -_⊔_ : ℤ → ℤ → ℤ --[1+ m ] ⊔ -[1+ n ] = -[1+ ℕ._⊓_ m n ] --[1+ m ] ⊔ + n = + n -+ m ⊔ -[1+ n ] = + m -+ m ⊔ + n = + (ℕ._⊔_ m n) +-- Maximum. --- Minimum. +_⊔_ : ℤ → ℤ → ℤ +-[1+ m ] ⊔ -[1+ n ] = -[1+ ℕ._⊓_ m n ] +-[1+ m ] ⊔ + n = + n ++ m ⊔ -[1+ n ] = + m ++ m ⊔ + n = + (ℕ._⊔_ m n) -_⊓_ : ℤ → ℤ → ℤ --[1+ m ] ⊓ -[1+ n ] = -[1+ m ℕ.⊔ n ] --[1+ m ] ⊓ + n = -[1+ m ] -+ m ⊓ -[1+ n ] = -[1+ n ] -+ m ⊓ + n = + (m ℕ.⊓ n) +-- Minimum. --- Division by a natural +_⊓_ : ℤ → ℤ → ℤ +-[1+ m ] ⊓ -[1+ n ] = -[1+ m ℕ.⊔ n ] +-[1+ m ] ⊓ + n = -[1+ m ] ++ m ⊓ -[1+ n ] = -[1+ n ] ++ m ⊓ + n = + (m ℕ.⊓ n) -_/ℕ_ : (dividend : ℤ) (divisor : ℕ) .{{_ : ℕ.NonZero divisor}} → ℤ -(+ n /ℕ d) = + (n ℕ./ d) -(-[1+ n ] /ℕ d) with ℕ.suc n ℕ.% d -... | ℕ.zero = - (+ (ℕ.suc n ℕ./ d)) -... | ℕ.suc r = -[1+ (ℕ.suc n ℕ./ d) ] +-- Division by a natural --- Division +_/ℕ_ : (dividend : ℤ) (divisor : ℕ) .{{_ : ℕ.NonZero divisor}} → ℤ +(+ n /ℕ d) = + (n ℕ./ d) +(-[1+ n ] /ℕ d) with ℕ.suc n ℕ.% d +... | ℕ.zero = - (+ (ℕ.suc n ℕ./ d)) +... | ℕ.suc r = -[1+ (ℕ.suc n ℕ./ d) ] -_/_ : (dividend divisor : ℤ) .{{_ : NonZero divisor}} → ℤ -i / j = (sign j ◃ 1) * (i /ℕ ∣ j ∣) +-- Division --- Modulus by a natural +_/_ : (dividend divisor : ℤ) .{{_ : NonZero divisor}} → ℤ +i / j = (sign j ◃ 1) * (i /ℕ ∣ j ∣) -_%ℕ_ : (dividend : ℤ) (divisor : ℕ) .{{_ : ℕ.NonZero divisor}} → ℕ -(+ n %ℕ d) = n ℕ.% d -(-[1+ n ] %ℕ d) with ℕ.suc n ℕ.% d -... | ℕ.zero = 0 -... | r@(ℕ.suc _) = d ℕ.∸ r +-- Modulus by a natural --- Modulus +_%ℕ_ : (dividend : ℤ) (divisor : ℕ) .{{_ : ℕ.NonZero divisor}} → ℕ +(+ n %ℕ d) = n ℕ.% d +(-[1+ n ] %ℕ d) with ℕ.suc n ℕ.% d +... | ℕ.zero = 0 +... | r@(ℕ.suc _) = d ℕ.∸ r -_%_ : (dividend divisor : ℤ) .{{_ : NonZero divisor}} → ℕ -i % j = i %ℕ ∣ j ∣ +-- Modulus ------------------------------------------------------------------------- --- Bundles +_%_ : (dividend divisor : ℤ) .{{_ : NonZero divisor}} → ℕ +i % j = i %ℕ ∣ j ∣ -+-rawMagma : RawMagma 0ℓ 0ℓ -+-rawMagma = record { _≈_ = _≡_ ; _∙_ = _+_ } +------------------------------------------------------------------------ +-- Bundles -+-0-rawMonoid : RawMonoid 0ℓ 0ℓ -+-0-rawMonoid = record { _≈_ = _≡_ ; _∙_ = _+_ ; ε = 0ℤ } ++-rawMagma : RawMagma 0ℓ 0ℓ ++-rawMagma = record { _≈_ = _≡_ ; _∙_ = _+_ } -+-0-rawGroup : RawGroup 0ℓ 0ℓ -+-0-rawGroup = record { _≈_ = _≡_ ; _∙_ = _+_ ; _⁻¹ = -_; ε = 0ℤ } ++-0-rawMonoid : RawMonoid 0ℓ 0ℓ ++-0-rawMonoid = record { _≈_ = _≡_ ; _∙_ = _+_ ; ε = 0ℤ } -*-rawMagma : RawMagma 0ℓ 0ℓ -*-rawMagma = record { _≈_ = _≡_ ; _∙_ = _*_ } ++-0-rawGroup : RawGroup 0ℓ 0ℓ ++-0-rawGroup = record { _≈_ = _≡_ ; _∙_ = _+_ ; _⁻¹ = -_; ε = 0ℤ } -*-1-rawMonoid : RawMonoid 0ℓ 0ℓ -*-1-rawMonoid = record { _≈_ = _≡_ ; _∙_ = _*_ ; ε = 1ℤ } +*-rawMagma : RawMagma 0ℓ 0ℓ +*-rawMagma = record { _≈_ = _≡_ ; _∙_ = _*_ } -+-*-rawNearSemiring : RawNearSemiring 0ℓ 0ℓ -+-*-rawNearSemiring = record - { Carrier = _ - ; _≈_ = _≡_ - ; _+_ = _+_ - ; _*_ = _*_ - ; 0# = 0ℤ - } +*-1-rawMonoid : RawMonoid 0ℓ 0ℓ +*-1-rawMonoid = record { _≈_ = _≡_ ; _∙_ = _*_ ; ε = 1ℤ } -+-*-rawSemiring : RawSemiring 0ℓ 0ℓ -+-*-rawSemiring = record - { Carrier = _ - ; _≈_ = _≡_ - ; _+_ = _+_ - ; _*_ = _*_ - ; 0# = 0ℤ - ; 1# = 1ℤ - } ++-*-rawNearSemiring : RawNearSemiring 0ℓ 0ℓ ++-*-rawNearSemiring = record + { Carrier = _ + ; _≈_ = _≡_ + ; _+_ = _+_ + ; _*_ = _*_ + ; 0# = 0ℤ + } -+-*-rawRing : RawRing 0ℓ 0ℓ -+-*-rawRing = record - { Carrier = _ - ; _≈_ = _≡_ - ; _+_ = _+_ - ; _*_ = _*_ - ; -_ = -_ - ; 0# = 0ℤ - ; 1# = 1ℤ - } ++-*-rawSemiring : RawSemiring 0ℓ 0ℓ ++-*-rawSemiring = record + { Carrier = _ + ; _≈_ = _≡_ + ; _+_ = _+_ + ; _*_ = _*_ + ; 0# = 0ℤ + ; 1# = 1ℤ + } + ++-*-rawRing : RawRing 0ℓ 0ℓ ++-*-rawRing = record + { Carrier = _ + ; _≈_ = _≡_ + ; _+_ = _+_ + ; _*_ = _*_ + ; -_ = -_ + ; 0# = 0ℤ + ; 1# = 1ℤ + } \ No newline at end of file diff --git a/Data.Integer.Coprimality.html b/Data.Integer.Coprimality.html index 52aa3146..721da18b 100644 --- a/Data.Integer.Coprimality.html +++ b/Data.Integer.Coprimality.html @@ -14,27 +14,28 @@ open import Data.Integer.Properties import Data.Nat.Coprimality as ℕ import Data.Nat.Divisibility as ℕ -open import Function.Base using (_on_) +open import Function.Base using (_on_) open import Level using (0ℓ) -open import Relation.Binary using (Rel; Decidable; Symmetric) -open import Relation.Binary.PropositionalEquality using (subst) +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Definitions using (Decidable; Symmetric) +open import Relation.Binary.PropositionalEquality.Core using (subst) ------------------------------------------------------------------------- --- Definition +------------------------------------------------------------------------ +-- Definition -Coprime : Rel ℤ 0ℓ -Coprime = ℕ.Coprime on ∣_∣ +Coprime : Rel ℤ 0ℓ +Coprime = ℕ.Coprime on ∣_∣ ------------------------------------------------------------------------- --- Properties of coprimality +------------------------------------------------------------------------ +-- Properties of coprimality -sym : Symmetric Coprime -sym = ℕ.sym +sym : Symmetric Coprime +sym = ℕ.sym -coprime? : Decidable Coprime -coprime? x y = ℕ.coprime? ∣ x ∣ ∣ y ∣ +coprime? : Decidable Coprime +coprime? x y = ℕ.coprime? ∣ x ∣ ∣ y ∣ -coprime-divisor : ∀ i j k → Coprime i j → i ∣ j * k → i ∣ k -coprime-divisor i j k c eq = - ℕ.coprime-divisor c (subst (∣ i ∣ ℕ.∣_ ) (abs-* j k) eq) +coprime-divisor : ∀ i j k → Coprime i j → i ∣ j * k → i ∣ k +coprime-divisor i j k c eq = + ℕ.coprime-divisor c (subst (∣ i ∣ ℕ.∣_ ) (abs-* j k) eq) \ No newline at end of file diff --git a/Data.Integer.Divisibility.html b/Data.Integer.Divisibility.html index faabfb7f..f76249f3 100644 --- a/Data.Integer.Divisibility.html +++ b/Data.Integer.Divisibility.html @@ -11,49 +11,49 @@ module Data.Integer.Divisibility where -open import Function -open import Data.Integer.Base -open import Data.Integer.Properties -import Data.Nat.Base as ℕ -import Data.Nat.Properties as ℕᵖ -import Data.Nat.Divisibility as ℕᵈ -import Data.Nat.Coprimality as ℕᶜ -open import Level -open import Relation.Binary -open import Relation.Binary.PropositionalEquality - ------------------------------------------------------------------------- --- Divisibility - -infix 4 _∣_ - -_∣_ : Rel ℤ 0ℓ -_∣_ = ℕᵈ._∣_ on ∣_∣ - -open ℕᵈ public using (divides) - ------------------------------------------------------------------------- --- Properties of divisibility - -*-monoʳ-∣ : ∀ k → (k *_) Preserves _∣_ ⟶ _∣_ -*-monoʳ-∣ k {i} {j} i∣j = begin - ∣ k * i ∣ ≡⟨ abs-* k i ⟩ - ∣ k ∣ ℕ.* ∣ i ∣ ∣⟨ ℕᵈ.*-monoʳ-∣ ∣ k ∣ i∣j ⟩ - ∣ k ∣ ℕ.* ∣ j ∣ ≡⟨ sym (abs-* k j) ⟩ - ∣ k * j ∣ ∎ - where open ℕᵈ.∣-Reasoning - -*-monoˡ-∣ : ∀ k → (_* k) Preserves _∣_ ⟶ _∣_ -*-monoˡ-∣ k {i} {j} rewrite *-comm i k | *-comm j k = *-monoʳ-∣ k - -*-cancelˡ-∣ : ∀ k {i j} .{{_ : NonZero k}} → k * i ∣ k * j → i ∣ j -*-cancelˡ-∣ k {i} {j} k*i∣k*j = ℕᵈ.*-cancelˡ-∣ ∣ k ∣ $ begin - ∣ k ∣ ℕ.* ∣ i ∣ ≡⟨ sym (abs-* k i) ⟩ - ∣ k * i ∣ ∣⟨ k*i∣k*j ⟩ - ∣ k * j ∣ ≡⟨ abs-* k j ⟩ - ∣ k ∣ ℕ.* ∣ j ∣ ∎ - where open ℕᵈ.∣-Reasoning - -*-cancelʳ-∣ : ∀ k {i j} .{{_ : NonZero k}} → i * k ∣ j * k → i ∣ j -*-cancelʳ-∣ k {i} {j} rewrite *-comm i k | *-comm j k = *-cancelˡ-∣ k +open import Function.Base using (_on_; _$_) +open import Data.Integer.Base +open import Data.Integer.Properties +import Data.Nat.Base as ℕ +import Data.Nat.Properties as ℕᵖ +import Data.Nat.Divisibility as ℕᵈ +import Data.Nat.Coprimality as ℕᶜ +open import Level +open import Relation.Binary.Core using (Rel; _Preserves_⟶_) +open import Relation.Binary.PropositionalEquality + +------------------------------------------------------------------------ +-- Divisibility + +infix 4 _∣_ + +_∣_ : Rel ℤ 0ℓ +_∣_ = ℕᵈ._∣_ on ∣_∣ + +open ℕᵈ public using (divides) + +------------------------------------------------------------------------ +-- Properties of divisibility + +*-monoʳ-∣ : ∀ k → (k *_) Preserves _∣_ ⟶ _∣_ +*-monoʳ-∣ k {i} {j} i∣j = begin + ∣ k * i ∣ ≡⟨ abs-* k i ⟩ + ∣ k ∣ ℕ.* ∣ i ∣ ∣⟨ ℕᵈ.*-monoʳ-∣ ∣ k ∣ i∣j ⟩ + ∣ k ∣ ℕ.* ∣ j ∣ ≡⟨ sym (abs-* k j) ⟩ + ∣ k * j ∣ ∎ + where open ℕᵈ.∣-Reasoning + +*-monoˡ-∣ : ∀ k → (_* k) Preserves _∣_ ⟶ _∣_ +*-monoˡ-∣ k {i} {j} rewrite *-comm i k | *-comm j k = *-monoʳ-∣ k + +*-cancelˡ-∣ : ∀ k {i j} .{{_ : NonZero k}} → k * i ∣ k * j → i ∣ j +*-cancelˡ-∣ k {i} {j} k*i∣k*j = ℕᵈ.*-cancelˡ-∣ ∣ k ∣ $ begin + ∣ k ∣ ℕ.* ∣ i ∣ ≡⟨ sym (abs-* k i) ⟩ + ∣ k * i ∣ ∣⟨ k*i∣k*j ⟩ + ∣ k * j ∣ ≡⟨ abs-* k j ⟩ + ∣ k ∣ ℕ.* ∣ j ∣ ∎ + where open ℕᵈ.∣-Reasoning + +*-cancelʳ-∣ : ∀ k {i j} .{{_ : NonZero k}} → i * k ∣ j * k → i ∣ j +*-cancelʳ-∣ k {i} {j} rewrite *-comm i k | *-comm j k = *-cancelˡ-∣ k \ No newline at end of file diff --git a/Data.Integer.GCD.html b/Data.Integer.GCD.html index d6e905f7..b106ad62 100644 --- a/Data.Integer.GCD.html +++ b/Data.Integer.GCD.html @@ -14,53 +14,53 @@ open import Data.Integer.Properties open import Data.Nat.Base import Data.Nat.GCD as ℕ -open import Data.Product -open import Relation.Binary.PropositionalEquality +open import Data.Product.Base using (_,_) +open import Relation.Binary.PropositionalEquality -open import Algebra.Definitions {A = ℤ} _≡_ as Algebra - using (Associative; Commutative; LeftIdentity; RightIdentity; LeftZero; RightZero; Zero) +open import Algebra.Definitions {A = ℤ} _≡_ as Algebra + using (Associative; Commutative; LeftIdentity; RightIdentity; LeftZero; RightZero; Zero) ------------------------------------------------------------------------- --- Definition ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Definition +------------------------------------------------------------------------ -gcd : ℤ → ℤ → ℤ -gcd i j = + ℕ.gcd ∣ i ∣ ∣ j ∣ +gcd : ℤ → ℤ → ℤ +gcd i j = + ℕ.gcd ∣ i ∣ ∣ j ∣ ------------------------------------------------------------------------- --- Properties ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Properties +------------------------------------------------------------------------ -gcd[i,j]∣i : ∀ i j → gcd i j ∣ i -gcd[i,j]∣i i j = ℕ.gcd[m,n]∣m ∣ i ∣ ∣ j ∣ +gcd[i,j]∣i : ∀ i j → gcd i j ∣ i +gcd[i,j]∣i i j = ℕ.gcd[m,n]∣m ∣ i ∣ ∣ j ∣ -gcd[i,j]∣j : ∀ i j → gcd i j ∣ j -gcd[i,j]∣j i j = ℕ.gcd[m,n]∣n ∣ i ∣ ∣ j ∣ +gcd[i,j]∣j : ∀ i j → gcd i j ∣ j +gcd[i,j]∣j i j = ℕ.gcd[m,n]∣n ∣ i ∣ ∣ j ∣ -gcd-greatest : ∀ {i j c} → c ∣ i → c ∣ j → c ∣ gcd i j -gcd-greatest c∣i c∣j = ℕ.gcd-greatest c∣i c∣j +gcd-greatest : ∀ {i j c} → c ∣ i → c ∣ j → c ∣ gcd i j +gcd-greatest c∣i c∣j = ℕ.gcd-greatest c∣i c∣j -gcd[0,0]≡0 : gcd 0ℤ 0ℤ ≡ 0ℤ -gcd[0,0]≡0 = cong (+_) ℕ.gcd[0,0]≡0 +gcd[0,0]≡0 : gcd 0ℤ 0ℤ ≡ 0ℤ +gcd[0,0]≡0 = cong (+_) ℕ.gcd[0,0]≡0 -gcd[i,j]≡0⇒i≡0 : ∀ i j → gcd i j ≡ 0ℤ → i ≡ 0ℤ -gcd[i,j]≡0⇒i≡0 i j eq = ∣i∣≡0⇒i≡0 (ℕ.gcd[m,n]≡0⇒m≡0 (+-injective eq)) +gcd[i,j]≡0⇒i≡0 : ∀ i j → gcd i j ≡ 0ℤ → i ≡ 0ℤ +gcd[i,j]≡0⇒i≡0 i j eq = ∣i∣≡0⇒i≡0 (ℕ.gcd[m,n]≡0⇒m≡0 (+-injective eq)) -gcd[i,j]≡0⇒j≡0 : ∀ {i j} → gcd i j ≡ 0ℤ → j ≡ 0ℤ -gcd[i,j]≡0⇒j≡0 {i} eq = ∣i∣≡0⇒i≡0 (ℕ.gcd[m,n]≡0⇒n≡0 ∣ i ∣ (+-injective eq)) +gcd[i,j]≡0⇒j≡0 : ∀ {i j} → gcd i j ≡ 0ℤ → j ≡ 0ℤ +gcd[i,j]≡0⇒j≡0 {i} eq = ∣i∣≡0⇒i≡0 (ℕ.gcd[m,n]≡0⇒n≡0 ∣ i ∣ (+-injective eq)) -gcd-comm : Commutative gcd -gcd-comm i j = cong (+_) (ℕ.gcd-comm ∣ i ∣ ∣ j ∣) +gcd-comm : Commutative gcd +gcd-comm i j = cong (+_) (ℕ.gcd-comm ∣ i ∣ ∣ j ∣) -gcd-assoc : Associative gcd -gcd-assoc i j k = cong (+_) (ℕ.gcd-assoc ∣ i ∣ ∣ j ∣ (∣ k ∣)) +gcd-assoc : Associative gcd +gcd-assoc i j k = cong (+_) (ℕ.gcd-assoc ∣ i ∣ ∣ j ∣ (∣ k ∣)) -gcd-zeroˡ : LeftZero 1ℤ gcd -gcd-zeroˡ i = cong (+_) (ℕ.gcd-zeroˡ ∣ i ∣) +gcd-zeroˡ : LeftZero 1ℤ gcd +gcd-zeroˡ i = cong (+_) (ℕ.gcd-zeroˡ ∣ i ∣) -gcd-zeroʳ : RightZero 1ℤ gcd -gcd-zeroʳ i = cong (+_) (ℕ.gcd-zeroʳ ∣ i ∣) +gcd-zeroʳ : RightZero 1ℤ gcd +gcd-zeroʳ i = cong (+_) (ℕ.gcd-zeroʳ ∣ i ∣) -gcd-zero : Zero 1ℤ gcd -gcd-zero = gcd-zeroˡ , gcd-zeroʳ +gcd-zero : Zero 1ℤ gcd +gcd-zero = gcd-zeroˡ , gcd-zeroʳ \ No newline at end of file diff --git a/Data.Integer.Properties.html b/Data.Integer.Properties.html index f8bdc0f9..d436de90 100644 --- a/Data.Integer.Properties.html +++ b/Data.Integer.Properties.html @@ -15,2379 +15,2383 @@ import Algebra.Construct.NaturalChoice.MinMaxOp as MinMaxOp import Algebra.Lattice.Construct.NaturalChoice.MinMaxOp as LatticeMinMaxOp import Algebra.Properties.AbelianGroup -open import Data.Bool.Base using (T; true; false) -open import Data.Integer.Base renaming (suc to sucℤ) -open import Data.Nat as ℕ - using (ℕ; suc; zero; _∸_; s≤s; z≤n; s<s; z<s) - hiding (module ℕ) -import Data.Nat.Properties as ℕ -open import Data.Nat.Solver -open import Data.Product using (proj₁; proj₂; _,_) -open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂; [_,_]′) -open import Data.Sign as Sign using (Sign) renaming (_*_ to _𝕊*_) -import Data.Sign.Properties as 𝕊ₚ -open import Data.Product using (_×_) -open import Function.Base using (_∘_; _$_; id) -open import Level using (0ℓ) -open import Relation.Binary -open import Relation.Binary.PropositionalEquality -open import Relation.Nullary using (yes; no; ¬_) -import Relation.Nullary.Reflects as Reflects -open import Relation.Nullary.Negation using (contradiction) -import Relation.Nullary.Decidable as Dec - -open import Algebra.Definitions {A = ℤ} _≡_ -open import Algebra.Consequences.Propositional -open import Algebra.Structures {A = ℤ} _≡_ -module ℤtoℕ = Morphism.Definitions ℤ ℕ _≡_ -module ℕtoℤ = Morphism.Definitions ℕ ℤ _≡_ -open +-*-Solver - -private - variable - m n o : ℕ - i j k : ℤ - s t : Sign - ------------------------------------------------------------------------- --- Equality ------------------------------------------------------------------------- - -+-injective : + m ≡ + n → m ≡ n -+-injective refl = refl - --[1+-injective : -[1+ m ] ≡ -[1+ n ] → m ≡ n --[1+-injective refl = refl - -+[1+-injective : +[1+ m ] ≡ +[1+ n ] → m ≡ n -+[1+-injective refl = refl - -infix 4 _≟_ -_≟_ : DecidableEquality ℤ -+ m ≟ + n = Dec.map′ (cong (+_)) +-injective (m ℕ.≟ n) -+ m ≟ -[1+ n ] = no λ() --[1+ m ] ≟ + n = no λ() --[1+ m ] ≟ -[1+ n ] = Dec.map′ (cong -[1+_]) -[1+-injective (m ℕ.≟ n) - -≡-setoid : Setoid 0ℓ 0ℓ -≡-setoid = setoid ℤ - -≡-decSetoid : DecSetoid 0ℓ 0ℓ -≡-decSetoid = decSetoid _≟_ - ------------------------------------------------------------------------- --- Properties of _≤_ ------------------------------------------------------------------------- - -drop‿+≤+ : + m ≤ + n → m ℕ.≤ n -drop‿+≤+ (+≤+ m≤n) = m≤n - -drop‿-≤- : -[1+ m ] ≤ -[1+ n ] → n ℕ.≤ m -drop‿-≤- (-≤- n≤m) = n≤m - ------------------------------------------------------------------------- --- Relational properties - -≤-reflexive : _≡_ ⇒ _≤_ -≤-reflexive { -[1+ n ]} refl = -≤- ℕ.≤-refl -≤-reflexive {+ n} refl = +≤+ ℕ.≤-refl - -≤-refl : Reflexive _≤_ -≤-refl = ≤-reflexive refl - -≤-trans : Transitive _≤_ -≤-trans -≤+ (+≤+ n≤m) = -≤+ -≤-trans (-≤- n≤m) -≤+ = -≤+ -≤-trans (-≤- n≤m) (-≤- k≤n) = -≤- (ℕ.≤-trans k≤n n≤m) -≤-trans (+≤+ m≤n) (+≤+ n≤k) = +≤+ (ℕ.≤-trans m≤n n≤k) - -≤-antisym : Antisymmetric _≡_ _≤_ -≤-antisym (-≤- n≤m) (-≤- m≤n) = cong -[1+_] $ ℕ.≤-antisym m≤n n≤m -≤-antisym (+≤+ m≤n) (+≤+ n≤m) = cong (+_) $ ℕ.≤-antisym m≤n n≤m - -≤-total : Total _≤_ -≤-total (-[1+ m ]) (-[1+ n ]) = Sum.map -≤- -≤- (ℕ.≤-total n m) -≤-total (-[1+ m ]) (+ n ) = inj₁ -≤+ -≤-total (+ m ) (-[1+ n ]) = inj₂ -≤+ -≤-total (+ m ) (+ n ) = Sum.map +≤+ +≤+ (ℕ.≤-total m n) - -infix 4 _≤?_ -_≤?_ : Decidable _≤_ --[1+ m ] ≤? -[1+ n ] = Dec.map′ -≤- drop‿-≤- (n ℕ.≤? m) --[1+ m ] ≤? + n = yes -≤+ -+ m ≤? -[1+ n ] = no λ () -+ m ≤? + n = Dec.map′ +≤+ drop‿+≤+ (m ℕ.≤? n) - -≤-irrelevant : Irrelevant _≤_ -≤-irrelevant -≤+ -≤+ = refl -≤-irrelevant (-≤- n≤m₁) (-≤- n≤m₂) = cong -≤- (ℕ.≤-irrelevant n≤m₁ n≤m₂) -≤-irrelevant (+≤+ n≤m₁) (+≤+ n≤m₂) = cong +≤+ (ℕ.≤-irrelevant n≤m₁ n≤m₂) - ------------------------------------------------------------------------- --- Structures - -≤-isPreorder : IsPreorder _≡_ _≤_ -≤-isPreorder = record - { isEquivalence = isEquivalence - ; reflexive = ≤-reflexive - ; trans = ≤-trans - } - -≤-isTotalPreorder : IsTotalPreorder _≡_ _≤_ -≤-isTotalPreorder = record - { isPreorder = ≤-isPreorder - ; total = ≤-total - } - -≤-isPartialOrder : IsPartialOrder _≡_ _≤_ -≤-isPartialOrder = record - { isPreorder = ≤-isPreorder - ; antisym = ≤-antisym - } - -≤-isTotalOrder : IsTotalOrder _≡_ _≤_ -≤-isTotalOrder = record - { isPartialOrder = ≤-isPartialOrder - ; total = ≤-total - } - -≤-isDecTotalOrder : IsDecTotalOrder _≡_ _≤_ -≤-isDecTotalOrder = record - { isTotalOrder = ≤-isTotalOrder - ; _≟_ = _≟_ - ; _≤?_ = _≤?_ - } - ------------------------------------------------------------------------- --- Bundles - -≤-preorder : Preorder 0ℓ 0ℓ 0ℓ -≤-preorder = record - { isPreorder = ≤-isPreorder - } - -≤-totalPreorder : TotalPreorder 0ℓ 0ℓ 0ℓ -≤-totalPreorder = record - { isTotalPreorder = ≤-isTotalPreorder - } - -≤-poset : Poset 0ℓ 0ℓ 0ℓ -≤-poset = record - { isPartialOrder = ≤-isPartialOrder - } - -≤-totalOrder : TotalOrder 0ℓ 0ℓ 0ℓ -≤-totalOrder = record - { isTotalOrder = ≤-isTotalOrder - } - -≤-decTotalOrder : DecTotalOrder 0ℓ 0ℓ 0ℓ -≤-decTotalOrder = record - { isDecTotalOrder = ≤-isDecTotalOrder - } - ------------------------------------------------------------------------- --- Properties of _≤ᵇ_ ------------------------------------------------------------------------- - -≤ᵇ⇒≤ : T (i ≤ᵇ j) → i ≤ j -≤ᵇ⇒≤ {+ _} {+ _} i≤j = +≤+ (ℕ.≤ᵇ⇒≤ _ _ i≤j) -≤ᵇ⇒≤ { -[1+ _ ]} {+ _} i≤j = -≤+ -≤ᵇ⇒≤ { -[1+ _ ]} { -[1+ _ ]} i≤j = -≤- (ℕ.≤ᵇ⇒≤ _ _ i≤j) - -≤⇒≤ᵇ : i ≤ j → T (i ≤ᵇ j) -≤⇒≤ᵇ (-≤- n≤m) = ℕ.≤⇒≤ᵇ n≤m -≤⇒≤ᵇ -≤+ = _ -≤⇒≤ᵇ (+≤+ m≤n) = ℕ.≤⇒≤ᵇ m≤n - ------------------------------------------------------------------------- --- Properties _<_ ------------------------------------------------------------------------- - -drop‿+<+ : + m < + n → m ℕ.< n -drop‿+<+ (+<+ m<n) = m<n - -drop‿-<- : -[1+ m ] < -[1+ n ] → n ℕ.< m -drop‿-<- (-<- n<m) = n<m - -+≮0 : + n ≮ +0 -+≮0 (+<+ ()) - -+≮- : + m ≮ -[1+ n ] -+≮- () - ------------------------------------------------------------------------- --- Relationship between other operators - -<⇒≤ : _<_ ⇒ _≤_ -<⇒≤ (-<- i<j) = -≤- (ℕ.<⇒≤ i<j) -<⇒≤ -<+ = -≤+ -<⇒≤ (+<+ i<j) = +≤+ (ℕ.<⇒≤ i<j) - -<⇒≢ : _<_ ⇒ _≢_ -<⇒≢ (-<- n<m) refl = ℕ.<⇒≢ n<m refl -<⇒≢ (+<+ m<n) refl = ℕ.<⇒≢ m<n refl - -<⇒≱ : _<_ ⇒ _≱_ -<⇒≱ (-<- n<m) = ℕ.<⇒≱ n<m ∘ drop‿-≤- -<⇒≱ (+<+ m<n) = ℕ.<⇒≱ m<n ∘ drop‿+≤+ - -≤⇒≯ : _≤_ ⇒ _≯_ -≤⇒≯ (-≤- n≤m) (-<- n<m) = ℕ.≤⇒≯ n≤m n<m -≤⇒≯ -≤+ = +≮- -≤⇒≯ (+≤+ m≤n) (+<+ m<n) = ℕ.≤⇒≯ m≤n m<n - -≰⇒> : _≰_ ⇒ _>_ -≰⇒> {+ n} {+_ n₁} i≰j = +<+ (ℕ.≰⇒> (i≰j ∘ +≤+)) -≰⇒> {+ n} { -[1+_] n₁} i≰j = -<+ -≰⇒> { -[1+_] n} {+_ n₁} i≰j = contradiction -≤+ i≰j -≰⇒> { -[1+_] n} { -[1+_] n₁} i≰j = -<- (ℕ.≰⇒> (i≰j ∘ -≤-)) - -≮⇒≥ : _≮_ ⇒ _≥_ -≮⇒≥ {+ i} {+ j} i≮j = +≤+ (ℕ.≮⇒≥ (i≮j ∘ +<+)) -≮⇒≥ {+ i} { -[1+_] j} i≮j = -≤+ -≮⇒≥ { -[1+_] i} {+ j} i≮j = contradiction -<+ i≮j -≮⇒≥ { -[1+_] i} { -[1+_] j} i≮j = -≤- (ℕ.≮⇒≥ (i≮j ∘ -<-)) - ->⇒≰ : _>_ ⇒ _≰_ ->⇒≰ = <⇒≱ - -≤∧≢⇒< : i ≤ j → i ≢ j → i < j -≤∧≢⇒< (-≤- m≤n) i≢j = -<- (ℕ.≤∧≢⇒< m≤n (i≢j ∘ cong -[1+_] ∘ sym)) -≤∧≢⇒< -≤+ i≢j = -<+ -≤∧≢⇒< (+≤+ n≤m) i≢j = +<+ (ℕ.≤∧≢⇒< n≤m (i≢j ∘ cong (+_))) - -≤∧≮⇒≡ : i ≤ j → i ≮ j → i ≡ j -≤∧≮⇒≡ i≤j i≮j = ≤-antisym i≤j (≮⇒≥ i≮j) - ------------------------------------------------------------------------- --- Relational properties - -<-irrefl : Irreflexive _≡_ _<_ -<-irrefl { -[1+ n ]} refl = ℕ.<-irrefl refl ∘ drop‿-<- -<-irrefl { +0} refl (+<+ ()) -<-irrefl { +[1+ n ]} refl = ℕ.<-irrefl refl ∘ drop‿+<+ - -<-asym : Asymmetric _<_ -<-asym (-<- n<m) = ℕ.<-asym n<m ∘ drop‿-<- -<-asym (+<+ m<n) = ℕ.<-asym m<n ∘ drop‿+<+ - -≤-<-trans : Trans _≤_ _<_ _<_ -≤-<-trans (-≤- n≤m) (-<- o<n) = -<- (ℕ.<-transˡ o<n n≤m) -≤-<-trans (-≤- n≤m) -<+ = -<+ -≤-<-trans -≤+ (+<+ m<o) = -<+ -≤-<-trans (+≤+ m≤n) (+<+ n<o) = +<+ (ℕ.<-transʳ m≤n n<o) - -<-≤-trans : Trans _<_ _≤_ _<_ -<-≤-trans (-<- n<m) (-≤- o≤n) = -<- (ℕ.<-transʳ o≤n n<m) -<-≤-trans (-<- n<m) -≤+ = -<+ -<-≤-trans -<+ (+≤+ m≤n) = -<+ -<-≤-trans (+<+ m<n) (+≤+ n≤o) = +<+ (ℕ.<-transˡ m<n n≤o) - -<-trans : Transitive _<_ -<-trans m<n n<p = ≤-<-trans (<⇒≤ m<n) n<p - -<-cmp : Trichotomous _≡_ _<_ -<-cmp +0 +0 = tri≈ +≮0 refl +≮0 -<-cmp +0 +[1+ n ] = tri< (+<+ z<s) (λ()) +≮0 -<-cmp +[1+ n ] +0 = tri> +≮0 (λ()) (+<+ z<s) -<-cmp (+ m) -[1+ n ] = tri> +≮- (λ()) -<+ -<-cmp -[1+ m ] (+ n) = tri< -<+ (λ()) +≮- -<-cmp -[1+ m ] -[1+ n ] with ℕ.<-cmp m n -... | tri< m<n m≢n n≯m = tri> (n≯m ∘ drop‿-<-) (m≢n ∘ -[1+-injective) (-<- m<n) -... | tri≈ m≮n m≡n n≯m = tri≈ (n≯m ∘ drop‿-<-) (cong -[1+_] m≡n) (m≮n ∘ drop‿-<-) -... | tri> m≮n m≢n n>m = tri< (-<- n>m) (m≢n ∘ -[1+-injective) (m≮n ∘ drop‿-<-) -<-cmp +[1+ m ] +[1+ n ] with ℕ.<-cmp m n -... | tri< m<n m≢n n≯m = tri< (+<+ (s<s m<n)) (m≢n ∘ +[1+-injective) (n≯m ∘ ℕ.≤-pred ∘ drop‿+<+) -... | tri≈ m≮n m≡n n≯m = tri≈ (m≮n ∘ ℕ.≤-pred ∘ drop‿+<+) (cong (+_ ∘ suc) m≡n) (n≯m ∘ ℕ.≤-pred ∘ drop‿+<+) -... | tri> m≮n m≢n n>m = tri> (m≮n ∘ ℕ.≤-pred ∘ drop‿+<+) (m≢n ∘ +[1+-injective) (+<+ (s<s n>m)) - -infix 4 _<?_ -_<?_ : Decidable _<_ --[1+ m ] <? -[1+ n ] = Dec.map′ -<- drop‿-<- (n ℕ.<? m) --[1+ m ] <? + n = yes -<+ -+ m <? -[1+ n ] = no λ() -+ m <? + n = Dec.map′ +<+ drop‿+<+ (m ℕ.<? n) - -<-irrelevant : Irrelevant _<_ -<-irrelevant (-<- n<m₁) (-<- n<m₂) = cong -<- (ℕ.<-irrelevant n<m₁ n<m₂) -<-irrelevant -<+ -<+ = refl -<-irrelevant (+<+ m<n₁) (+<+ m<n₂) = cong +<+ (ℕ.<-irrelevant m<n₁ m<n₂) - ------------------------------------------------------------------------- --- Structures - -<-isStrictPartialOrder : IsStrictPartialOrder _≡_ _<_ -<-isStrictPartialOrder = record - { isEquivalence = isEquivalence - ; irrefl = <-irrefl - ; trans = <-trans - ; <-resp-≈ = subst (_ <_) , subst (_< _) - } - -<-isStrictTotalOrder : IsStrictTotalOrder _≡_ _<_ -<-isStrictTotalOrder = record - { isEquivalence = isEquivalence - ; trans = <-trans - ; compare = <-cmp - } - ------------------------------------------------------------------------- --- Bundles - -<-strictPartialOrder : StrictPartialOrder 0ℓ 0ℓ 0ℓ -<-strictPartialOrder = record - { isStrictPartialOrder = <-isStrictPartialOrder - } - -<-strictTotalOrder : StrictTotalOrder 0ℓ 0ℓ 0ℓ -<-strictTotalOrder = record - { isStrictTotalOrder = <-isStrictTotalOrder - } - ------------------------------------------------------------------------- --- Other properties of _<_ - -i≮i : i ≮ i -i≮i = <-irrefl refl - ->-irrefl : Irreflexive _≡_ _>_ ->-irrefl = <-irrefl ∘ sym - ------------------------------------------------------------------------- --- A specialised module for reasoning about the _≤_ and _<_ relations ------------------------------------------------------------------------- - -module ≤-Reasoning where - open import Relation.Binary.Reasoning.Base.Triple - ≤-isPreorder - <-trans - (resp₂ _<_) - <⇒≤ - <-≤-trans - ≤-<-trans - public - hiding (step-≈; step-≈˘) - ------------------------------------------------------------------------- --- Properties of Positive/NonPositive/Negative/NonNegative and _≤_/_<_ - -positive⁻¹ : ∀ i → .{{Positive i}} → i > 0ℤ -positive⁻¹ +[1+ n ] = +<+ z<s - -negative⁻¹ : ∀ i → .{{Negative i}} → i < 0ℤ -negative⁻¹ -[1+ n ] = -<+ - -nonPositive⁻¹ : ∀ i → .{{NonPositive i}} → i ≤ 0ℤ -nonPositive⁻¹ +0 = +≤+ z≤n -nonPositive⁻¹ -[1+ n ] = -≤+ - -nonNegative⁻¹ : ∀ i → .{{NonNegative i}} → i ≥ 0ℤ -nonNegative⁻¹ (+ n) = +≤+ z≤n - -negative<positive : ∀ i j → .{{Negative i}} → .{{Positive j}} → i < j -negative<positive i j = <-trans (negative⁻¹ i) (positive⁻¹ j) - ------------------------------------------------------------------------- --- Properties of -_ ------------------------------------------------------------------------- - -neg-involutive : ∀ i → - - i ≡ i -neg-involutive -[1+ n ] = refl -neg-involutive +0 = refl -neg-involutive +[1+ n ] = refl - -neg-injective : - i ≡ - j → i ≡ j -neg-injective {i} {j} -i≡-j = begin - i ≡˘⟨ neg-involutive i ⟩ - - - i ≡⟨ cong -_ -i≡-j ⟩ - - - j ≡⟨ neg-involutive j ⟩ - j ∎ where open ≡-Reasoning - -neg-≤-pos : ∀ {m n} → - (+ m) ≤ + n -neg-≤-pos {zero} = +≤+ z≤n -neg-≤-pos {suc m} = -≤+ - -neg-mono-≤ : -_ Preserves _≤_ ⟶ _≥_ -neg-mono-≤ -≤+ = neg-≤-pos -neg-mono-≤ (-≤- n≤m) = +≤+ (s≤s n≤m) -neg-mono-≤ (+≤+ z≤n) = neg-≤-pos -neg-mono-≤ (+≤+ (s≤s m≤n)) = -≤- m≤n - -neg-cancel-≤ : - i ≤ - j → i ≥ j -neg-cancel-≤ { +[1+ m ]} { +[1+ n ]} (-≤- n≤m) = +≤+ (s≤s n≤m) -neg-cancel-≤ { +[1+ m ]} { +0} -≤+ = +≤+ z≤n -neg-cancel-≤ { +[1+ m ]} { -[1+ n ]} -≤+ = -≤+ -neg-cancel-≤ { +0} { +0} _ = +≤+ z≤n -neg-cancel-≤ { +0} { -[1+ n ]} _ = -≤+ -neg-cancel-≤ { -[1+ m ]} { +0} (+≤+ ()) -neg-cancel-≤ { -[1+ m ]} { -[1+ n ]} (+≤+ (s≤s m≤n)) = -≤- m≤n - -neg-mono-< : -_ Preserves _<_ ⟶ _>_ -neg-mono-< { -[1+ _ ]} { -[1+ _ ]} (-<- n<m) = +<+ (s<s n<m) -neg-mono-< { -[1+ _ ]} { +0} -<+ = +<+ z<s -neg-mono-< { -[1+ _ ]} { +[1+ n ]} -<+ = -<+ -neg-mono-< { +0} { +[1+ n ]} (+<+ _) = -<+ -neg-mono-< { +[1+ m ]} { +[1+ n ]} (+<+ m<n) = -<- (ℕ.≤-pred m<n) - -neg-cancel-< : - i < - j → i > j -neg-cancel-< { +[1+ m ]} { +[1+ n ]} (-<- n<m) = +<+ (s<s n<m) -neg-cancel-< { +[1+ m ]} { +0} -<+ = +<+ z<s -neg-cancel-< { +[1+ m ]} { -[1+ n ]} -<+ = -<+ -neg-cancel-< { +0} { +0} (+<+ ()) -neg-cancel-< { +0} { -[1+ n ]} _ = -<+ -neg-cancel-< { -[1+ m ]} { +0} (+<+ ()) -neg-cancel-< { -[1+ m ]} { -[1+ n ]} (+<+ (s<s m<n)) = -<- m<n - ------------------------------------------------------------------------- --- Properties of ∣_∣ ------------------------------------------------------------------------- - -∣i∣≡0⇒i≡0 : ∣ i ∣ ≡ 0 → i ≡ + 0 -∣i∣≡0⇒i≡0 {+0} refl = refl - -∣-i∣≡∣i∣ : ∀ i → ∣ - i ∣ ≡ ∣ i ∣ -∣-i∣≡∣i∣ -[1+ n ] = refl -∣-i∣≡∣i∣ +0 = refl -∣-i∣≡∣i∣ +[1+ n ] = refl - -0≤i⇒+∣i∣≡i : 0ℤ ≤ i → + ∣ i ∣ ≡ i -0≤i⇒+∣i∣≡i (+≤+ _) = refl - -+∣i∣≡i⇒0≤i : + ∣ i ∣ ≡ i → 0ℤ ≤ i -+∣i∣≡i⇒0≤i {+ n} _ = +≤+ z≤n - -+∣i∣≡i⊎+∣i∣≡-i : ∀ i → + ∣ i ∣ ≡ i ⊎ + ∣ i ∣ ≡ - i -+∣i∣≡i⊎+∣i∣≡-i (+ n) = inj₁ refl -+∣i∣≡i⊎+∣i∣≡-i (-[1+ n ]) = inj₂ refl - -∣m⊝n∣≤m⊔n : ∀ m n → ∣ m ⊖ n ∣ ℕ.≤ m ℕ.⊔ n -∣m⊝n∣≤m⊔n m n with m ℕ.<ᵇ n -... | true = begin - ∣ - + (n ℕ.∸ m) ∣ ≡⟨ ∣-i∣≡∣i∣ (+ (n ℕ.∸ m)) ⟩ - ∣ + (n ℕ.∸ m) ∣ ≡⟨⟩ - n ℕ.∸ m ≤⟨ ℕ.m∸n≤m n m ⟩ - n ≤⟨ ℕ.m≤n⊔m m n ⟩ - m ℕ.⊔ n ∎ - where open ℕ.≤-Reasoning -... | false = begin - ∣ + (m ℕ.∸ n) ∣ ≡⟨⟩ - m ℕ.∸ n ≤⟨ ℕ.m∸n≤m m n ⟩ - m ≤⟨ ℕ.m≤m⊔n m n ⟩ - m ℕ.⊔ n ∎ - where open ℕ.≤-Reasoning - -∣i+j∣≤∣i∣+∣j∣ : ∀ i j → ∣ i + j ∣ ℕ.≤ ∣ i ∣ ℕ.+ ∣ j ∣ -∣i+j∣≤∣i∣+∣j∣ +[1+ m ] (+ n) = ℕ.≤-refl -∣i+j∣≤∣i∣+∣j∣ +0 (+ n) = ℕ.≤-refl -∣i+j∣≤∣i∣+∣j∣ +0 -[1+ n ] = ℕ.≤-refl -∣i+j∣≤∣i∣+∣j∣ -[1+ m ] -[1+ n ] rewrite ℕ.+-suc (suc m) n = ℕ.≤-refl -∣i+j∣≤∣i∣+∣j∣ +[1+ m ] -[1+ n ] = begin - ∣ suc m ⊖ suc n ∣ ≤⟨ ∣m⊝n∣≤m⊔n (suc m) (suc n) ⟩ - suc m ℕ.⊔ suc n ≤⟨ ℕ.m⊔n≤m+n (suc m) (suc n) ⟩ - suc m ℕ.+ suc n ∎ - where open ℕ.≤-Reasoning -∣i+j∣≤∣i∣+∣j∣ -[1+ m ] (+ n) = begin - ∣ n ⊖ suc m ∣ ≤⟨ ∣m⊝n∣≤m⊔n n (suc m) ⟩ - n ℕ.⊔ suc m ≤⟨ ℕ.m⊔n≤m+n n (suc m) ⟩ - n ℕ.+ suc m ≡⟨ ℕ.+-comm n (suc m) ⟩ - suc m ℕ.+ n ∎ - where open ℕ.≤-Reasoning - -∣i-j∣≤∣i∣+∣j∣ : ∀ i j → ∣ i - j ∣ ℕ.≤ ∣ i ∣ ℕ.+ ∣ j ∣ -∣i-j∣≤∣i∣+∣j∣ i j = begin - ∣ i - j ∣ ≤⟨ ∣i+j∣≤∣i∣+∣j∣ i (- j) ⟩ - ∣ i ∣ ℕ.+ ∣ - j ∣ ≡⟨ cong (∣ i ∣ ℕ.+_) (∣-i∣≡∣i∣ j) ⟩ - ∣ i ∣ ℕ.+ ∣ j ∣ ∎ - where open ℕ.≤-Reasoning - ------------------------------------------------------------------------- --- Properties of sign and _◃_ - -◃-inverse : ∀ i → sign i ◃ ∣ i ∣ ≡ i -◃-inverse -[1+ n ] = refl -◃-inverse +0 = refl -◃-inverse +[1+ n ] = refl - -◃-cong : sign i ≡ sign j → ∣ i ∣ ≡ ∣ j ∣ → i ≡ j -◃-cong {+ m} {+ n } ≡-sign refl = refl -◃-cong { -[1+ m ]} { -[1+ n ]} ≡-sign refl = refl - -+◃n≡+n : ∀ n → Sign.+ ◃ n ≡ + n -+◃n≡+n zero = refl -+◃n≡+n (suc _) = refl - --◃n≡-n : ∀ n → Sign.- ◃ n ≡ - + n --◃n≡-n zero = refl --◃n≡-n (suc _) = refl - -sign-◃ : ∀ s n .{{_ : ℕ.NonZero n}} → sign (s ◃ n) ≡ s -sign-◃ Sign.- (suc _) = refl -sign-◃ Sign.+ (suc _) = refl - -abs-◃ : ∀ s n → ∣ s ◃ n ∣ ≡ n -abs-◃ _ zero = refl -abs-◃ Sign.- (suc n) = refl -abs-◃ Sign.+ (suc n) = refl - -signᵢ◃∣i∣≡i : ∀ i → sign i ◃ ∣ i ∣ ≡ i -signᵢ◃∣i∣≡i (+ n) = +◃n≡+n n -signᵢ◃∣i∣≡i -[1+ n ] = refl - -sign-cong : .{{_ : ℕ.NonZero m}} .{{_ : ℕ.NonZero n}} → - s ◃ m ≡ t ◃ n → s ≡ t -sign-cong {n@(suc _)} {m@(suc _)} {s} {t} eq = begin - s ≡˘⟨ sign-◃ s n ⟩ - sign (s ◃ n) ≡⟨ cong sign eq ⟩ - sign (t ◃ m) ≡⟨ sign-◃ t m ⟩ - t ∎ where open ≡-Reasoning - -sign-cong′ : s ◃ m ≡ t ◃ n → s ≡ t ⊎ (m ≡ 0 × n ≡ 0) -sign-cong′ {s} {zero} {t} {zero} eq = inj₂ (refl , refl) -sign-cong′ {s} {zero} {Sign.- } {suc n} () -sign-cong′ {s} {zero} {Sign.+ } {suc n} () -sign-cong′ {Sign.- } {suc m} {t} {zero} () -sign-cong′ {Sign.+ } {suc m} {t} {zero} () -sign-cong′ {s} {suc m} {t} {suc n} eq = inj₁ (sign-cong eq) - -abs-cong : s ◃ m ≡ t ◃ n → m ≡ n -abs-cong {s} {m} {t} {n} eq = begin - m ≡˘⟨ abs-◃ s m ⟩ - ∣ s ◃ m ∣ ≡⟨ cong ∣_∣ eq ⟩ - ∣ t ◃ n ∣ ≡⟨ abs-◃ t n ⟩ - n ∎ where open ≡-Reasoning - -∣s◃m∣*∣t◃n∣≡m*n : ∀ s t m n → ∣ s ◃ m ∣ ℕ.* ∣ t ◃ n ∣ ≡ m ℕ.* n -∣s◃m∣*∣t◃n∣≡m*n s t m n = cong₂ ℕ._*_ (abs-◃ s m) (abs-◃ t n) - -+◃-mono-< : m ℕ.< n → Sign.+ ◃ m < Sign.+ ◃ n -+◃-mono-< {zero} {suc n} m<n = +<+ m<n -+◃-mono-< {suc m} {suc n} m<n = +<+ m<n - -+◃-cancel-< : Sign.+ ◃ m < Sign.+ ◃ n → m ℕ.< n -+◃-cancel-< {zero} {zero} (+<+ ()) -+◃-cancel-< {suc m} {zero} (+<+ ()) -+◃-cancel-< {zero} {suc n} (+<+ m<n) = m<n -+◃-cancel-< {suc m} {suc n} (+<+ m<n) = m<n - -neg◃-cancel-< : Sign.- ◃ m < Sign.- ◃ n → n ℕ.< m -neg◃-cancel-< {zero} {zero} (+<+ ()) -neg◃-cancel-< {suc m} {zero} -<+ = z<s -neg◃-cancel-< {suc m} {suc n} (-<- n<m) = s<s n<m - --◃<+◃ : ∀ m n .{{_ : ℕ.NonZero m}} → Sign.- ◃ m < Sign.+ ◃ n --◃<+◃ (suc _) zero = -<+ --◃<+◃ (suc _) (suc _) = -<+ - -+◃≮-◃ : Sign.+ ◃ m ≮ Sign.- ◃ n -+◃≮-◃ {zero} {zero} (+<+ ()) -+◃≮-◃ {suc m} {zero} (+<+ ()) - ------------------------------------------------------------------------- --- Properties of _⊖_ ------------------------------------------------------------------------- - -n⊖n≡0 : ∀ n → n ⊖ n ≡ 0ℤ -n⊖n≡0 n with n ℕ.<ᵇ n in leq -... | true = cong (-_ ∘ +_) (ℕ.n∸n≡0 n) -- this is actually impossible! -... | false = cong +_ (ℕ.n∸n≡0 n) - -[1+m]⊖[1+n]≡m⊖n : ∀ m n → suc m ⊖ suc n ≡ m ⊖ n -[1+m]⊖[1+n]≡m⊖n m n with m ℕ.<ᵇ n -... | true = refl -... | false = refl - -⊖-swap : ∀ m n → m ⊖ n ≡ - (n ⊖ m) -⊖-swap zero zero = refl -⊖-swap zero (suc m) = refl -⊖-swap (suc m) zero = refl -⊖-swap (suc m) (suc n) = begin - suc m ⊖ suc n ≡⟨ [1+m]⊖[1+n]≡m⊖n m n ⟩ - m ⊖ n ≡⟨ ⊖-swap m n ⟩ - - (n ⊖ m) ≡˘⟨ cong -_ ([1+m]⊖[1+n]≡m⊖n n m) ⟩ - - (suc n ⊖ suc m) ∎ where open ≡-Reasoning - -⊖-≥ : m ℕ.≥ n → m ⊖ n ≡ + (m ∸ n) -⊖-≥ {m} {n} p with m ℕ.<ᵇ n | Reflects.invert (ℕ.<ᵇ-reflects-< m n) -... | true | q = contradiction (ℕ.<-transʳ p q) (ℕ.<-irrefl refl) -... | false | q = refl - -≤-⊖ : m ℕ.≤ n → n ⊖ m ≡ + (n ∸ m) -≤-⊖ (z≤n {n}) = refl -≤-⊖ (s≤s {m} {n} p) = begin - suc n ⊖ suc m ≡⟨ [1+m]⊖[1+n]≡m⊖n n m ⟩ - n ⊖ m ≡⟨ ≤-⊖ p ⟩ - + (n ∸ m) ≡⟨⟩ - + (suc n ∸ suc m) ∎ where open ≡-Reasoning - -⊖-≤ : m ℕ.≤ n → m ⊖ n ≡ - + (n ∸ m) -⊖-≤ {m} {n} p with m ℕ.<ᵇ n | Reflects.invert (ℕ.<ᵇ-reflects-< m n) -... | true | q = refl -... | false | q rewrite ℕ.≤-antisym p (ℕ.≮⇒≥ q) | ℕ.n∸n≡0 n = refl - -⊖-< : m ℕ.< n → m ⊖ n ≡ - + (n ∸ m) -⊖-< = ⊖-≤ ∘ ℕ.<⇒≤ - -⊖-≰ : n ℕ.≰ m → m ⊖ n ≡ - + (n ∸ m) -⊖-≰ = ⊖-< ∘ ℕ.≰⇒> - -∣⊖∣-≤ : m ℕ.≤ n → ∣ m ⊖ n ∣ ≡ n ∸ m -∣⊖∣-≤ {m} {n} p = begin - ∣ m ⊖ n ∣ ≡⟨ cong ∣_∣ (⊖-≤ p) ⟩ - ∣ - (+ (n ∸ m)) ∣ ≡⟨ ∣-i∣≡∣i∣ (+ (n ∸ m)) ⟩ - ∣ + (n ∸ m) ∣ ≡⟨⟩ - n ∸ m ∎ where open ≡-Reasoning - -∣⊖∣-< : m ℕ.< n → ∣ m ⊖ n ∣ ≡ n ∸ m -∣⊖∣-< {m} {n} p = begin - ∣ m ⊖ n ∣ ≡⟨ cong ∣_∣ (⊖-< p) ⟩ - ∣ - (+ (n ∸ m)) ∣ ≡⟨ ∣-i∣≡∣i∣ (+ (n ∸ m)) ⟩ - ∣ + (n ∸ m) ∣ ≡⟨⟩ - n ∸ m ∎ where open ≡-Reasoning - -∣⊖∣-≰ : n ℕ.≰ m → ∣ m ⊖ n ∣ ≡ n ∸ m -∣⊖∣-≰ = ∣⊖∣-< ∘ ℕ.≰⇒> - --m+n≡n⊖m : ∀ m n → - (+ m) + + n ≡ n ⊖ m --m+n≡n⊖m zero n = refl --m+n≡n⊖m (suc m) n = refl - -m-n≡m⊖n : ∀ m n → + m + (- + n) ≡ m ⊖ n -m-n≡m⊖n zero zero = refl -m-n≡m⊖n zero (suc n) = refl -m-n≡m⊖n (suc m) zero = cong +[1+_] (ℕ.+-identityʳ m) -m-n≡m⊖n (suc m) (suc n) = refl - --[n⊖m]≡-m+n : ∀ m n → - (m ⊖ n) ≡ (- (+ m)) + (+ n) --[n⊖m]≡-m+n m n with m ℕ.<ᵇ n | Reflects.invert (ℕ.<ᵇ-reflects-< m n) -... | true | p = begin - - (- (+ (n ∸ m))) ≡⟨ neg-involutive (+ (n ∸ m)) ⟩ - + (n ∸ m) ≡˘⟨ ⊖-≥ (ℕ.≤-trans (ℕ.m≤n+m m 1) p) ⟩ - n ⊖ m ≡˘⟨ -m+n≡n⊖m m n ⟩ - - (+ m) + + n ∎ where open ≡-Reasoning -... | false | p = begin - - (+ (m ∸ n)) ≡˘⟨ ⊖-≤ (ℕ.≮⇒≥ p) ⟩ - n ⊖ m ≡˘⟨ -m+n≡n⊖m m n ⟩ - - (+ m) + + n ∎ where open ≡-Reasoning - -∣m⊖n∣≡∣n⊖m∣ : ∀ m n → ∣ m ⊖ n ∣ ≡ ∣ n ⊖ m ∣ -∣m⊖n∣≡∣n⊖m∣ m n = begin - ∣ m ⊖ n ∣ ≡⟨ cong ∣_∣ (⊖-swap m n) ⟩ - ∣ - (n ⊖ m) ∣ ≡⟨ ∣-i∣≡∣i∣ (n ⊖ m) ⟩ - ∣ n ⊖ m ∣ ∎ where open ≡-Reasoning - -+-cancelˡ-⊖ : ∀ m n o → (m ℕ.+ n) ⊖ (m ℕ.+ o) ≡ n ⊖ o -+-cancelˡ-⊖ zero n o = refl -+-cancelˡ-⊖ (suc m) n o = begin - suc (m ℕ.+ n) ⊖ suc (m ℕ.+ o) ≡⟨ [1+m]⊖[1+n]≡m⊖n (m ℕ.+ n) (m ℕ.+ o) ⟩ - m ℕ.+ n ⊖ (m ℕ.+ o) ≡⟨ +-cancelˡ-⊖ m n o ⟩ - n ⊖ o ∎ where open ≡-Reasoning - -m⊖n≤m : ∀ m n → m ⊖ n ≤ + m -m⊖n≤m m zero = ≤-refl -m⊖n≤m zero (suc n) = -≤+ -m⊖n≤m (suc m) (suc n) = begin - suc m ⊖ suc n ≡⟨ [1+m]⊖[1+n]≡m⊖n m n ⟩ - m ⊖ n ≤⟨ m⊖n≤m m n ⟩ - + m ≤⟨ +≤+ (ℕ.n≤1+n m) ⟩ - +[1+ m ] ∎ where open ≤-Reasoning - -m⊖n<1+m : ∀ m n → m ⊖ n < +[1+ m ] -m⊖n<1+m m n = ≤-<-trans (m⊖n≤m m n) (+<+ (ℕ.m<n+m m z<s)) - -m⊖1+n<m : ∀ m n .{{_ : ℕ.NonZero n}} → m ⊖ n < + m -m⊖1+n<m zero (suc n) = -<+ -m⊖1+n<m (suc m) (suc n) = begin-strict - suc m ⊖ suc n ≡⟨ [1+m]⊖[1+n]≡m⊖n m n ⟩ - m ⊖ n <⟨ m⊖n<1+m m n ⟩ - +[1+ m ] ∎ where open ≤-Reasoning - --1+m<n⊖m : ∀ m n → -[1+ m ] < n ⊖ m --1+m<n⊖m zero n = -<+ --1+m<n⊖m (suc m) zero = -<- ℕ.≤-refl --1+m<n⊖m (suc m) (suc n) = begin-strict - -[1+ suc m ] <⟨ -<- ℕ.≤-refl ⟩ - -[1+ m ] <⟨ -1+m<n⊖m m n ⟩ - n ⊖ m ≡˘⟨ [1+m]⊖[1+n]≡m⊖n n m ⟩ - suc n ⊖ suc m ∎ where open ≤-Reasoning - --[1+m]≤n⊖m+1 : ∀ m n → -[1+ m ] ≤ n ⊖ suc m --[1+m]≤n⊖m+1 m zero = ≤-refl --[1+m]≤n⊖m+1 m (suc n) = begin - -[1+ m ] ≤⟨ <⇒≤ (-1+m<n⊖m m n) ⟩ - n ⊖ m ≡˘⟨ [1+m]⊖[1+n]≡m⊖n n m ⟩ - suc n ⊖ suc m ∎ where open ≤-Reasoning - --1+m≤n⊖m : ∀ m n → -[1+ m ] ≤ n ⊖ m --1+m≤n⊖m m n = <⇒≤ (-1+m<n⊖m m n) - -0⊖m≤+ : ∀ m {n} → 0 ⊖ m ≤ + n -0⊖m≤+ zero = +≤+ z≤n -0⊖m≤+ (suc m) = -≤+ - -sign-⊖-< : m ℕ.< n → sign (m ⊖ n) ≡ Sign.- -sign-⊖-< {zero} (ℕ.z<s) = refl -sign-⊖-< {suc m} {suc n} (ℕ.s<s m<n) = begin - sign (suc m ⊖ suc n) ≡⟨ cong sign ([1+m]⊖[1+n]≡m⊖n m n) ⟩ - sign (m ⊖ n) ≡⟨ sign-⊖-< m<n ⟩ - Sign.- ∎ where open ≡-Reasoning - -sign-⊖-≰ : n ℕ.≰ m → sign (m ⊖ n) ≡ Sign.- -sign-⊖-≰ = sign-⊖-< ∘ ℕ.≰⇒> - -⊖-monoʳ-≥-≤ : ∀ n → (n ⊖_) Preserves ℕ._≥_ ⟶ _≤_ -⊖-monoʳ-≥-≤ zero {m} z≤n = 0⊖m≤+ m -⊖-monoʳ-≥-≤ zero {_} (s≤s m≤n) = -≤- m≤n -⊖-monoʳ-≥-≤ (suc n) {zero} z≤n = ≤-refl -⊖-monoʳ-≥-≤ (suc n) {suc m} z≤n = begin - suc n ⊖ suc m ≡⟨ [1+m]⊖[1+n]≡m⊖n n m ⟩ - n ⊖ m <⟨ m⊖n<1+m n m ⟩ - +[1+ n ] ∎ where open ≤-Reasoning -⊖-monoʳ-≥-≤ (suc n) {suc m} {suc o} (s≤s m≤o) = begin - suc n ⊖ suc m ≡⟨ [1+m]⊖[1+n]≡m⊖n n m ⟩ - n ⊖ m ≤⟨ ⊖-monoʳ-≥-≤ n m≤o ⟩ - n ⊖ o ≡˘⟨ [1+m]⊖[1+n]≡m⊖n n o ⟩ - suc n ⊖ suc o ∎ where open ≤-Reasoning - -⊖-monoˡ-≤ : ∀ n → (_⊖ n) Preserves ℕ._≤_ ⟶ _≤_ -⊖-monoˡ-≤ zero {_} {_} m≤o = +≤+ m≤o -⊖-monoˡ-≤ (suc n) {_} {0} z≤n = ≤-refl -⊖-monoˡ-≤ (suc n) {_} {suc o} z≤n = begin - zero ⊖ suc n ≤⟨ ⊖-monoʳ-≥-≤ 0 (ℕ.n≤1+n n) ⟩ - zero ⊖ n ≤⟨ ⊖-monoˡ-≤ n z≤n ⟩ - o ⊖ n ≡˘⟨ [1+m]⊖[1+n]≡m⊖n o n ⟩ - suc o ⊖ suc n ∎ where open ≤-Reasoning -⊖-monoˡ-≤ (suc n) {suc m} {suc o} (s≤s m≤o) = begin - suc m ⊖ suc n ≡⟨ [1+m]⊖[1+n]≡m⊖n m n ⟩ - m ⊖ n ≤⟨ ⊖-monoˡ-≤ n m≤o ⟩ - o ⊖ n ≡˘⟨ [1+m]⊖[1+n]≡m⊖n o n ⟩ - suc o ⊖ suc n ∎ where open ≤-Reasoning - -⊖-monoʳ->-< : ∀ p → (p ⊖_) Preserves ℕ._>_ ⟶ _<_ -⊖-monoʳ->-< zero {_} z<s = -<+ -⊖-monoʳ->-< zero {_} (s<s m<n@(s≤s _)) = -<- m<n -⊖-monoʳ->-< (suc p) {suc m} z<s = begin-strict - suc p ⊖ suc m ≡⟨ [1+m]⊖[1+n]≡m⊖n p m ⟩ - p ⊖ m <⟨ m⊖n<1+m p m ⟩ - +[1+ p ] ∎ where open ≤-Reasoning -⊖-monoʳ->-< (suc p) {suc m} {suc n} (s<s m<n@(s≤s _)) = begin-strict - suc p ⊖ suc m ≡⟨ [1+m]⊖[1+n]≡m⊖n p m ⟩ - p ⊖ m <⟨ ⊖-monoʳ->-< p m<n ⟩ - p ⊖ n ≡˘⟨ [1+m]⊖[1+n]≡m⊖n p n ⟩ - suc p ⊖ suc n ∎ where open ≤-Reasoning - -⊖-monoˡ-< : ∀ n → (_⊖ n) Preserves ℕ._<_ ⟶ _<_ -⊖-monoˡ-< zero m<o = +<+ m<o -⊖-monoˡ-< (suc n) {_} {suc o} z<s = begin-strict - -[1+ n ] <⟨ -1+m<n⊖m n _ ⟩ - o ⊖ n ≡˘⟨ [1+m]⊖[1+n]≡m⊖n o n ⟩ - suc o ⊖ suc n ∎ where open ≤-Reasoning -⊖-monoˡ-< (suc n) {suc m} {suc (suc o)} (s<s m<o@(s≤s _)) = begin-strict - suc m ⊖ suc n ≡⟨ [1+m]⊖[1+n]≡m⊖n m n ⟩ - m ⊖ n <⟨ ⊖-monoˡ-< n m<o ⟩ - suc o ⊖ n ≡˘⟨ [1+m]⊖[1+n]≡m⊖n (suc o) n ⟩ - suc (suc o) ⊖ suc n ∎ where open ≤-Reasoning - ------------------------------------------------------------------------- --- Properties of _+_ ------------------------------------------------------------------------- - ------------------------------------------------------------------------- --- Algebraic properties of _+_ - -+-comm : Commutative _+_ -+-comm -[1+ m ] -[1+ n ] = cong (-[1+_] ∘ suc) (ℕ.+-comm m n) -+-comm (+ m) (+ n) = cong +_ (ℕ.+-comm m n) -+-comm -[1+ _ ] (+ _) = refl -+-comm (+ _) -[1+ _ ] = refl - -+-identityˡ : LeftIdentity +0 _+_ -+-identityˡ -[1+ _ ] = refl -+-identityˡ (+ _) = refl - -+-identityʳ : RightIdentity +0 _+_ -+-identityʳ = comm+idˡ⇒idʳ +-comm +-identityˡ - -+-identity : Identity +0 _+_ -+-identity = +-identityˡ , +-identityʳ - -distribˡ-⊖-+-pos : ∀ m n o → n ⊖ o + + m ≡ n ℕ.+ m ⊖ o -distribˡ-⊖-+-pos _ zero zero = refl -distribˡ-⊖-+-pos _ zero (suc _) = refl -distribˡ-⊖-+-pos _ (suc _) zero = refl -distribˡ-⊖-+-pos m (suc n) (suc o) = begin - suc n ⊖ suc o + + m ≡⟨ cong (_+ + m) ([1+m]⊖[1+n]≡m⊖n n o) ⟩ - n ⊖ o + + m ≡⟨ distribˡ-⊖-+-pos m n o ⟩ - n ℕ.+ m ⊖ o ≡˘⟨ [1+m]⊖[1+n]≡m⊖n (n ℕ.+ m) o ⟩ - suc (n ℕ.+ m) ⊖ suc o ∎ where open ≡-Reasoning - -distribˡ-⊖-+-neg : ∀ m n o → n ⊖ o + -[1+ m ] ≡ n ⊖ (suc o ℕ.+ m) -distribˡ-⊖-+-neg _ zero zero = refl -distribˡ-⊖-+-neg _ zero (suc _) = refl -distribˡ-⊖-+-neg _ (suc _) zero = refl -distribˡ-⊖-+-neg m (suc n) (suc o) = begin - suc n ⊖ suc o + -[1+ m ] ≡⟨ cong (_+ -[1+ m ]) ([1+m]⊖[1+n]≡m⊖n n o) ⟩ - n ⊖ o + -[1+ m ] ≡⟨ distribˡ-⊖-+-neg m n o ⟩ - n ⊖ (suc o ℕ.+ m) ≡˘⟨ [1+m]⊖[1+n]≡m⊖n n (suc o ℕ.+ m) ⟩ - suc n ⊖ (suc (suc o) ℕ.+ m) ∎ where open ≡-Reasoning - -distribʳ-⊖-+-pos : ∀ m n o → + m + (n ⊖ o) ≡ m ℕ.+ n ⊖ o -distribʳ-⊖-+-pos m n o = begin - + m + (n ⊖ o) ≡⟨ +-comm (+ m) (n ⊖ o) ⟩ - (n ⊖ o) + + m ≡⟨ distribˡ-⊖-+-pos m n o ⟩ - n ℕ.+ m ⊖ o ≡⟨ cong (_⊖ o) (ℕ.+-comm n m) ⟩ - m ℕ.+ n ⊖ o ∎ where open ≡-Reasoning - -distribʳ-⊖-+-neg : ∀ m n o → -[1+ m ] + (n ⊖ o) ≡ n ⊖ (suc m ℕ.+ o) -distribʳ-⊖-+-neg m n o = begin - -[1+ m ] + (n ⊖ o) ≡⟨ +-comm -[1+ m ] (n ⊖ o) ⟩ - (n ⊖ o) + -[1+ m ] ≡⟨ distribˡ-⊖-+-neg m n o ⟩ - n ⊖ suc (o ℕ.+ m) ≡⟨ cong (λ x → n ⊖ suc x) (ℕ.+-comm o m) ⟩ - n ⊖ suc (m ℕ.+ o) ∎ where open ≡-Reasoning - -+-assoc : Associative _+_ -+-assoc +0 j k rewrite +-identityˡ j | +-identityˡ (j + k) = refl -+-assoc i +0 k rewrite +-identityʳ i | +-identityˡ k = refl -+-assoc i j +0 rewrite +-identityʳ (i + j) | +-identityʳ j = refl -+-assoc -[1+ m ] -[1+ n ] +[1+ o ] = begin - suc o ⊖ suc (suc (m ℕ.+ n)) ≡⟨ [1+m]⊖[1+n]≡m⊖n o (suc m ℕ.+ n) ⟩ - o ⊖ (suc m ℕ.+ n) ≡˘⟨ distribʳ-⊖-+-neg m o n ⟩ - -[1+ m ] + (o ⊖ n) ≡˘⟨ cong (λ z → -[1+ m ] + z) ([1+m]⊖[1+n]≡m⊖n o n) ⟩ - -[1+ m ] + (suc o ⊖ suc n) ∎ where open ≡-Reasoning -+-assoc -[1+ m ] +[1+ n ] +[1+ o ] = begin - suc n ⊖ suc m + +[1+ o ] ≡⟨ cong (_+ +[1+ o ]) ([1+m]⊖[1+n]≡m⊖n n m) ⟩ - (n ⊖ m) + +[1+ o ] ≡⟨ distribˡ-⊖-+-pos (suc o) n m ⟩ - n ℕ.+ suc o ⊖ m ≡˘⟨ [1+m]⊖[1+n]≡m⊖n (n ℕ.+ suc o) m ⟩ - suc (n ℕ.+ suc o) ⊖ suc m ∎ where open ≡-Reasoning -+-assoc +[1+ m ] -[1+ n ] -[1+ o ] = begin - (suc m ⊖ suc n) + -[1+ o ] ≡⟨ cong (_+ -[1+ o ]) ([1+m]⊖[1+n]≡m⊖n m n) ⟩ - (m ⊖ n) + -[1+ o ] ≡⟨ distribˡ-⊖-+-neg o m n ⟩ - m ⊖ suc (n ℕ.+ o) ≡˘⟨ [1+m]⊖[1+n]≡m⊖n m (suc n ℕ.+ o) ⟩ - suc m ⊖ suc (suc (n ℕ.+ o)) ∎ where open ≡-Reasoning -+-assoc +[1+ m ] -[1+ n ] +[1+ o ] - rewrite [1+m]⊖[1+n]≡m⊖n m n - | [1+m]⊖[1+n]≡m⊖n o n - | distribˡ-⊖-+-pos (suc o) m n - | distribʳ-⊖-+-pos (suc m) o n - | sym (ℕ.+-assoc m 1 o) - | ℕ.+-comm m 1 - = refl -+-assoc +[1+ m ] +[1+ n ] -[1+ o ] - rewrite [1+m]⊖[1+n]≡m⊖n n o - | [1+m]⊖[1+n]≡m⊖n (m ℕ.+ suc n) o - | distribʳ-⊖-+-pos (suc m) n o - | sym (ℕ.+-assoc m 1 n) - | ℕ.+-comm m 1 - = refl -+-assoc -[1+ m ] -[1+ n ] -[1+ o ] - rewrite sym (ℕ.+-assoc m 1 (n ℕ.+ o)) - | ℕ.+-comm m 1 - | ℕ.+-assoc m n o - = refl -+-assoc -[1+ m ] +[1+ n ] -[1+ o ] - rewrite [1+m]⊖[1+n]≡m⊖n n m - | [1+m]⊖[1+n]≡m⊖n n o - | distribʳ-⊖-+-neg m n o - | distribˡ-⊖-+-neg o n m - = refl -+-assoc +[1+ m ] +[1+ n ] +[1+ o ] - rewrite ℕ.+-assoc (suc m) (suc n) (suc o) - = refl - -+-inverseˡ : LeftInverse +0 -_ _+_ -+-inverseˡ -[1+ n ] = n⊖n≡0 (suc n) -+-inverseˡ +0 = refl -+-inverseˡ +[1+ n ] = n⊖n≡0 (suc n) - -+-inverseʳ : RightInverse +0 -_ _+_ -+-inverseʳ = comm+invˡ⇒invʳ +-comm +-inverseˡ - -+-inverse : Inverse +0 -_ _+_ -+-inverse = +-inverseˡ , +-inverseʳ - ------------------------------------------------------------------------- --- Structures - -+-isMagma : IsMagma _+_ -+-isMagma = record - { isEquivalence = isEquivalence - ; ∙-cong = cong₂ _+_ - } - -+-isSemigroup : IsSemigroup _+_ -+-isSemigroup = record - { isMagma = +-isMagma - ; assoc = +-assoc - } - -+-isCommutativeSemigroup : IsCommutativeSemigroup _+_ -+-isCommutativeSemigroup = record - { isSemigroup = +-isSemigroup - ; comm = +-comm - } - -+-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 - } - ------------------------------------------------------------------------- --- Bundles - -+-magma : Magma 0ℓ 0ℓ -+-magma = record - { isMagma = +-isMagma - } - -+-semigroup : Semigroup 0ℓ 0ℓ -+-semigroup = record - { isSemigroup = +-isSemigroup - } - -+-commutativeSemigroup : CommutativeSemigroup 0ℓ 0ℓ -+-commutativeSemigroup = record - { isCommutativeSemigroup = +-isCommutativeSemigroup - } - -+-0-monoid : Monoid 0ℓ 0ℓ -+-0-monoid = record - { isMonoid = +-0-isMonoid - } - -+-0-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ -+-0-commutativeMonoid = record - { isCommutativeMonoid = +-0-isCommutativeMonoid - } - -+-0-abelianGroup : AbelianGroup 0ℓ 0ℓ -+-0-abelianGroup = record - { isAbelianGroup = +-0-isAbelianGroup - } - ------------------------------------------------------------------------- --- Properties of _+_ and +_/-_. - -pos-+ : ℕtoℤ.Homomorphic₂ +_ ℕ._+_ _+_ -pos-+ zero n = refl -pos-+ (suc m) n = cong sucℤ (pos-+ m n) - -neg-distrib-+ : ∀ i j → - (i + j) ≡ (- i) + (- j) -neg-distrib-+ +0 +0 = refl -neg-distrib-+ +0 +[1+ n ] = refl -neg-distrib-+ +[1+ m ] +0 = cong -[1+_] (ℕ.+-identityʳ m) -neg-distrib-+ +[1+ m ] +[1+ n ] = cong -[1+_] (ℕ.+-suc m n) -neg-distrib-+ -[1+ m ] -[1+ n ] = cong +[1+_] (sym (ℕ.+-suc m n)) -neg-distrib-+ (+ m) -[1+ n ] = -[n⊖m]≡-m+n m (suc n) -neg-distrib-+ -[1+ m ] (+ n) = - trans (-[n⊖m]≡-m+n n (suc m)) (+-comm (- + n) (+ suc m)) - -◃-distrib-+ : ∀ s m n → s ◃ (m ℕ.+ n) ≡ (s ◃ m) + (s ◃ n) -◃-distrib-+ Sign.- m n = begin - Sign.- ◃ (m ℕ.+ n) ≡⟨ -◃n≡-n (m ℕ.+ n) ⟩ - - (+ (m ℕ.+ n)) ≡⟨⟩ - - ((+ m) + (+ n)) ≡⟨ neg-distrib-+ (+ m) (+ n) ⟩ - (- (+ m)) + (- (+ n)) ≡⟨ sym (cong₂ _+_ (-◃n≡-n m) (-◃n≡-n n)) ⟩ - (Sign.- ◃ m) + (Sign.- ◃ n) ∎ where open ≡-Reasoning -◃-distrib-+ Sign.+ m n = begin - Sign.+ ◃ (m ℕ.+ n) ≡⟨ +◃n≡+n (m ℕ.+ n) ⟩ - + (m ℕ.+ n) ≡⟨⟩ - (+ m) + (+ n) ≡⟨ sym (cong₂ _+_ (+◃n≡+n m) (+◃n≡+n n)) ⟩ - (Sign.+ ◃ m) + (Sign.+ ◃ n) ∎ where open ≡-Reasoning - ------------------------------------------------------------------------- --- Properties of _+_ and _≤_ - -+-monoʳ-≤ : ∀ n → (_+_ n) Preserves _≤_ ⟶ _≤_ -+-monoʳ-≤ (+ n) {_} (-≤- o≤m) = ⊖-monoʳ-≥-≤ n (s≤s o≤m) -+-monoʳ-≤ (+ n) { -[1+ m ]} -≤+ = ≤-trans (m⊖n≤m n (suc m)) (+≤+ (ℕ.m≤m+n n _)) -+-monoʳ-≤ (+ n) {_} (+≤+ m≤o) = +≤+ (ℕ.+-monoʳ-≤ n m≤o) -+-monoʳ-≤ -[1+ n ] {_} {_} (-≤- n≤m) = -≤- (ℕ.+-monoʳ-≤ (suc n) n≤m) -+-monoʳ-≤ -[1+ n ] {_} {+ m} -≤+ = ≤-trans (-≤- (ℕ.m≤m+n (suc n) _)) (-1+m≤n⊖m (suc n) m) -+-monoʳ-≤ -[1+ n ] {_} {_} (+≤+ m≤n) = ⊖-monoˡ-≤ (suc n) m≤n - -+-monoˡ-≤ : ∀ n → (_+ n) Preserves _≤_ ⟶ _≤_ -+-monoˡ-≤ n {i} {j} rewrite +-comm i n | +-comm j n = +-monoʳ-≤ n - -+-mono-≤ : _+_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ -+-mono-≤ {m} {n} {i} {j} m≤n i≤j = begin - m + i ≤⟨ +-monoˡ-≤ i m≤n ⟩ - n + i ≤⟨ +-monoʳ-≤ n i≤j ⟩ - n + j ∎ - where open ≤-Reasoning - -i≤j⇒i≤k+j : ∀ k .{{_ : NonNegative k}} → i ≤ j → i ≤ k + j -i≤j⇒i≤k+j (+ n) i≤j = subst (_≤ _) (+-identityˡ _) (+-mono-≤ (+≤+ z≤n) i≤j) - -i≤j+i : ∀ i j .{{_ : NonNegative j}} → i ≤ j + i -i≤j+i i j = i≤j⇒i≤k+j j ≤-refl - -i≤i+j : ∀ i j .{{_ : NonNegative j}} → i ≤ i + j -i≤i+j i j rewrite +-comm i j = i≤j+i i j - ------------------------------------------------------------------------- --- Properties of _+_ and _<_ - -+-monoʳ-< : ∀ i → (_+_ i) Preserves _<_ ⟶ _<_ -+-monoʳ-< (+ n) {_} {_} (-<- o<m) = ⊖-monoʳ->-< n (s<s o<m) -+-monoʳ-< (+ n) {_} {_} -<+ = <-≤-trans (m⊖1+n<m n _) (+≤+ (ℕ.m≤m+n n _)) -+-monoʳ-< (+ n) {_} {_} (+<+ m<o) = +<+ (ℕ.+-monoʳ-< n m<o) -+-monoʳ-< -[1+ n ] {_} {_} (-<- o<m) = -<- (ℕ.+-monoʳ-< (suc n) o<m) -+-monoʳ-< -[1+ n ] {_} {+ o} -<+ = <-≤-trans (-<- (ℕ.m≤m+n (suc n) _)) (-[1+m]≤n⊖m+1 n o) -+-monoʳ-< -[1+ n ] {_} {_} (+<+ m<o) = ⊖-monoˡ-< (suc n) m<o - -+-monoˡ-< : ∀ i → (_+ i) Preserves _<_ ⟶ _<_ -+-monoˡ-< i {j} {k} rewrite +-comm j i | +-comm k i = +-monoʳ-< i - -+-mono-< : _+_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_ -+-mono-< {i} {j} {k} {l} i<j k<l = begin-strict - i + k <⟨ +-monoˡ-< k i<j ⟩ - j + k <⟨ +-monoʳ-< j k<l ⟩ - j + l ∎ - where open ≤-Reasoning - -+-mono-≤-< : _+_ Preserves₂ _≤_ ⟶ _<_ ⟶ _<_ -+-mono-≤-< {i} {j} {k} i≤j j<k = ≤-<-trans (+-monoˡ-≤ k i≤j) (+-monoʳ-< j j<k) - -+-mono-<-≤ : _+_ Preserves₂ _<_ ⟶ _≤_ ⟶ _<_ -+-mono-<-≤ {i} {j} {k} i<j j≤k = <-≤-trans (+-monoˡ-< k i<j) (+-monoʳ-≤ j j≤k) - ------------------------------------------------------------------------- --- Properties of _-_ ------------------------------------------------------------------------- - -neg-minus-pos : ∀ m n → -[1+ m ] - (+ n) ≡ -[1+ (n ℕ.+ m) ] -neg-minus-pos m zero = refl -neg-minus-pos zero (suc n) = cong (-[1+_] ∘ suc) (sym (ℕ.+-identityʳ n)) -neg-minus-pos (suc m) (suc n) = cong (-[1+_] ∘ suc) (ℕ.+-comm (suc m) n) - -+-minus-telescope : ∀ i j k → (i - j) + (j - k) ≡ i - k -+-minus-telescope i j k = begin - (i - j) + (j - k) ≡⟨ +-assoc i (- j) (j - k) ⟩ - i + (- j + (j - k)) ≡˘⟨ cong (λ v → i + v) (+-assoc (- j) j _) ⟩ - i + ((- j + j) - k) ≡˘⟨ +-assoc i (- j + j) (- k) ⟩ - i + (- j + j) - k ≡⟨ cong (λ a → i + a - k) (+-inverseˡ j) ⟩ - i + 0ℤ - k ≡⟨ cong (_- k) (+-identityʳ i) ⟩ - i - k ∎ where open ≡-Reasoning - -[+m]-[+n]≡m⊖n : ∀ m n → (+ m) - (+ n) ≡ m ⊖ n -[+m]-[+n]≡m⊖n zero zero = refl -[+m]-[+n]≡m⊖n zero (suc n) = refl -[+m]-[+n]≡m⊖n (suc m) zero = cong +[1+_] (ℕ.+-identityʳ m) -[+m]-[+n]≡m⊖n (suc m) (suc n) = refl - -∣i-j∣≡∣j-i∣ : ∀ i j → ∣ i - j ∣ ≡ ∣ j - i ∣ -∣i-j∣≡∣j-i∣ -[1+ m ] -[1+ n ] = ∣m⊖n∣≡∣n⊖m∣ (suc n) (suc m) -∣i-j∣≡∣j-i∣ -[1+ m ] (+ n) = begin - ∣ -[1+ m ] - (+ n) ∣ ≡⟨ cong ∣_∣ (neg-minus-pos m n) ⟩ - suc (n ℕ.+ m) ≡˘⟨ ℕ.+-suc n m ⟩ - n ℕ.+ suc m ∎ where open ≡-Reasoning -∣i-j∣≡∣j-i∣ (+ m) -[1+ n ] = begin - m ℕ.+ suc n ≡⟨ ℕ.+-suc m n ⟩ - suc (m ℕ.+ n) ≡˘⟨ cong ∣_∣ (neg-minus-pos n m) ⟩ - ∣ -[1+ n ] + - + m ∣ ∎ where open ≡-Reasoning -∣i-j∣≡∣j-i∣ (+ m) (+ n) = begin - ∣ + m - + n ∣ ≡⟨ cong ∣_∣ ([+m]-[+n]≡m⊖n m n) ⟩ - ∣ m ⊖ n ∣ ≡⟨ ∣m⊖n∣≡∣n⊖m∣ m n ⟩ - ∣ n ⊖ m ∣ ≡˘⟨ cong ∣_∣ ([+m]-[+n]≡m⊖n n m) ⟩ - ∣ + n - + m ∣ ∎ where open ≡-Reasoning - -∣-∣-≤ : i ≤ j → + ∣ i - j ∣ ≡ j - i -∣-∣-≤ (-≤- {m} {n} n≤m) = begin - + ∣ -[1+ m ] + +[1+ n ] ∣ ≡⟨ cong (λ j → + ∣ j ∣) ([1+m]⊖[1+n]≡m⊖n n m) ⟩ - + ∣ n ⊖ m ∣ ≡⟨ cong +_ (∣⊖∣-≤ n≤m) ⟩ - + ( m ∸ n ) ≡⟨ sym (≤-⊖ n≤m) ⟩ - m ⊖ n ≡⟨ sym ([1+m]⊖[1+n]≡m⊖n m n) ⟩ - suc m ⊖ suc n ∎ where open ≡-Reasoning -∣-∣-≤ (-≤+ {m} {zero}) = refl -∣-∣-≤ (-≤+ {m} {suc n}) = begin - + ∣ -[1+ m ] - + suc n ∣ ≡⟨⟩ - + suc (suc m ℕ.+ n) ≡⟨ cong (λ n → + suc n) (ℕ.+-comm (suc m) n) ⟩ - + (suc n ℕ.+ suc m) ≡⟨⟩ - + suc n - -[1+ m ] ∎ where open ≡-Reasoning -∣-∣-≤ (+≤+ {m} {n} m≤n) = begin - + ∣ + m - + n ∣ ≡⟨ cong (λ j → + ∣ j ∣) (m-n≡m⊖n m n) ⟩ - + ∣ m ⊖ n ∣ ≡⟨ cong +_ ( ∣⊖∣-≤ m≤n ) ⟩ - + (n ∸ m) ≡⟨ sym (≤-⊖ m≤n) ⟩ - n ⊖ m ≡⟨ sym (m-n≡m⊖n n m) ⟩ - + n - + m ∎ where open ≡-Reasoning - -i≡j⇒i-j≡0 : i ≡ j → i - j ≡ 0ℤ -i≡j⇒i-j≡0 {i} refl = +-inverseʳ i - -i-j≡0⇒i≡j : ∀ i j → i - j ≡ 0ℤ → i ≡ j -i-j≡0⇒i≡j i j i-j≡0 = begin - i ≡˘⟨ +-identityʳ i ⟩ - i + 0ℤ ≡˘⟨ cong (_+_ i) (+-inverseˡ j) ⟩ - i + (- j + j) ≡˘⟨ +-assoc i (- j) j ⟩ - (i - j) + j ≡⟨ cong (_+ j) i-j≡0 ⟩ - 0ℤ + j ≡⟨ +-identityˡ j ⟩ - j ∎ where open ≡-Reasoning - -i≤j⇒i-k≤j : ∀ k .{{_ : NonNegative k}} → i ≤ j → i - k ≤ j -i≤j⇒i-k≤j {i} +0 i≤j rewrite +-identityʳ i = i≤j -i≤j⇒i-k≤j {+ m} +[1+ n ] i≤j = ≤-trans (m⊖n≤m m (suc n)) i≤j -i≤j⇒i-k≤j { -[1+ m ]} +[1+ n ] i≤j = ≤-trans (-≤- (ℕ.≤-trans (ℕ.m≤m+n m n) (ℕ.n≤1+n _))) i≤j - -i-j≤i : ∀ i j .{{_ : NonNegative j}} → i - j ≤ i -i-j≤i i j = i≤j⇒i-k≤j j ≤-refl - -i≤j⇒i-j≤0 : i ≤ j → i - j ≤ 0ℤ -i≤j⇒i-j≤0 {_} {j} -≤+ = i≤j⇒i-k≤j j -≤+ -i≤j⇒i-j≤0 { -[1+ m ]} { -[1+ n ]} (-≤- n≤m) = begin - suc n ⊖ suc m ≡⟨ [1+m]⊖[1+n]≡m⊖n n m ⟩ - n ⊖ m ≤⟨ ⊖-monoʳ-≥-≤ n n≤m ⟩ - n ⊖ n ≡⟨ n⊖n≡0 n ⟩ - 0ℤ ∎ where open ≤-Reasoning -i≤j⇒i-j≤0 {_} {+0} (+≤+ z≤n) = +≤+ z≤n -i≤j⇒i-j≤0 {_} {+[1+ n ]} (+≤+ z≤n) = -≤+ -i≤j⇒i-j≤0 {+[1+ m ]} {+[1+ n ]} (+≤+ (s≤s m≤n)) = begin - suc m ⊖ suc n ≡⟨ [1+m]⊖[1+n]≡m⊖n m n ⟩ - m ⊖ n ≤⟨ ⊖-monoʳ-≥-≤ m m≤n ⟩ - m ⊖ m ≡⟨ n⊖n≡0 m ⟩ - 0ℤ ∎ where open ≤-Reasoning - -i-j≤0⇒i≤j : i - j ≤ 0ℤ → i ≤ j -i-j≤0⇒i≤j {i} {j} i-j≤0 = begin - i ≡˘⟨ +-identityʳ i ⟩ - i + 0ℤ ≡˘⟨ cong (_+_ i) (+-inverseˡ j) ⟩ - i + (- j + j) ≡˘⟨ +-assoc i (- j) j ⟩ - (i - j) + j ≤⟨ +-monoˡ-≤ j i-j≤0 ⟩ - 0ℤ + j ≡⟨ +-identityˡ j ⟩ - j ∎ - where open ≤-Reasoning - -i≤j⇒0≤j-i : i ≤ j → 0ℤ ≤ j - i -i≤j⇒0≤j-i {i} {j} i≤j = begin - 0ℤ ≡˘⟨ +-inverseʳ i ⟩ - i - i ≤⟨ +-monoˡ-≤ (- i) i≤j ⟩ - j - i ∎ - where open ≤-Reasoning - -0≤i-j⇒j≤i : 0ℤ ≤ i - j → j ≤ i -0≤i-j⇒j≤i {i} {j} 0≤i-j = begin - j ≡˘⟨ +-identityˡ j ⟩ - 0ℤ + j ≤⟨ +-monoˡ-≤ j 0≤i-j ⟩ - i - j + j ≡⟨ +-assoc i (- j) j ⟩ - i + (- j + j) ≡⟨ cong (_+_ i) (+-inverseˡ j) ⟩ - i + 0ℤ ≡⟨ +-identityʳ i ⟩ - i ∎ - where open ≤-Reasoning - ------------------------------------------------------------------------- --- Properties of suc ------------------------------------------------------------------------- - -i≤j⇒i≤1+j : i ≤ j → i ≤ sucℤ j -i≤j⇒i≤1+j = i≤j⇒i≤k+j (+ 1) - -i≤suc[i] : ∀ i → i ≤ sucℤ i -i≤suc[i] i = i≤j+i i (+ 1) - -suc-+ : ∀ m n → +[1+ m ] + n ≡ sucℤ (+ m + n) -suc-+ m (+ n) = refl -suc-+ m (-[1+ n ]) = sym (distribʳ-⊖-+-pos 1 m (suc n)) - -i≢suc[i] : i ≢ sucℤ i -i≢suc[i] {+ _} () -i≢suc[i] { -[1+ 0 ]} () -i≢suc[i] { -[1+ suc n ]} () - -1-[1+n]≡-n : ∀ n → sucℤ -[1+ n ] ≡ - (+ n) -1-[1+n]≡-n zero = refl -1-[1+n]≡-n (suc n) = refl - -suc-mono : sucℤ Preserves _≤_ ⟶ _≤_ -suc-mono (-≤+ {m} {n}) = begin - 1 ⊖ suc m ≡⟨ [1+m]⊖[1+n]≡m⊖n 0 m ⟩ - 0 ⊖ m ≤⟨ 0⊖m≤+ m ⟩ - sucℤ (+ n) ∎ where open ≤-Reasoning -suc-mono (-≤- n≤m) = ⊖-monoʳ-≥-≤ 1 (s≤s n≤m) -suc-mono (+≤+ m≤n) = +≤+ (s≤s m≤n) - -suc[i]≤j⇒i<j : sucℤ i ≤ j → i < j -suc[i]≤j⇒i<j {+ i} {+ _} (+≤+ i≤j) = +<+ i≤j -suc[i]≤j⇒i<j { -[1+ 0 ]} {+ j} p = -<+ -suc[i]≤j⇒i<j { -[1+ suc i ]} {+ j} -≤+ = -<+ -suc[i]≤j⇒i<j { -[1+ suc i ]} { -[1+ j ]} (-≤- j≤i) = -<- (ℕ.s≤s j≤i) - -i<j⇒suc[i]≤j : i < j → sucℤ i ≤ j -i<j⇒suc[i]≤j {+ _} {+ _} (+<+ i<j) = +≤+ i<j -i<j⇒suc[i]≤j { -[1+ 0 ]} {+ _} -<+ = +≤+ z≤n -i<j⇒suc[i]≤j { -[1+ suc i ]} { -[1+ _ ]} (-<- j<i) = -≤- (ℕ.≤-pred j<i) -i<j⇒suc[i]≤j { -[1+ suc i ]} {+ _} -<+ = -≤+ - ------------------------------------------------------------------------- --- Properties of pred ------------------------------------------------------------------------- - -suc-pred : ∀ i → sucℤ (pred i) ≡ i -suc-pred i = begin - sucℤ (pred i) ≡˘⟨ +-assoc 1ℤ -1ℤ i ⟩ - 0ℤ + i ≡⟨ +-identityˡ i ⟩ - i ∎ where open ≡-Reasoning - -pred-suc : ∀ i → pred (sucℤ i) ≡ i -pred-suc i = begin - pred (sucℤ i) ≡˘⟨ +-assoc -1ℤ 1ℤ i ⟩ - 0ℤ + i ≡⟨ +-identityˡ i ⟩ - i ∎ where open ≡-Reasoning - -+-pred : ∀ i j → i + pred j ≡ pred (i + j) -+-pred i j = begin - i + (-1ℤ + j) ≡˘⟨ +-assoc i -1ℤ j ⟩ - i + -1ℤ + j ≡⟨ cong (_+ j) (+-comm i -1ℤ) ⟩ - -1ℤ + i + j ≡⟨ +-assoc -1ℤ i j ⟩ - -1ℤ + (i + j) ∎ where open ≡-Reasoning - -pred-+ : ∀ i j → pred i + j ≡ pred (i + j) -pred-+ i j = begin - pred i + j ≡⟨ +-comm (pred i) j ⟩ - j + pred i ≡⟨ +-pred j i ⟩ - pred (j + i) ≡⟨ cong pred (+-comm j i) ⟩ - pred (i + j) ∎ where open ≡-Reasoning - -neg-suc : ∀ m → -[1+ m ] ≡ pred (- + m) -neg-suc zero = refl -neg-suc (suc m) = refl - -minus-suc : ∀ m n → m - +[1+ n ] ≡ pred (m - + n) -minus-suc m n = begin - m + - +[1+ n ] ≡⟨ cong (_+_ m) (neg-suc n) ⟩ - m + pred (- (+ n)) ≡⟨ +-pred m (- + n) ⟩ - pred (m - + n) ∎ where open ≡-Reasoning - -i≤pred[j]⇒i<j : i ≤ pred j → i < j -i≤pred[j]⇒i<j {_} { + n} leq = ≤-<-trans leq (m⊖1+n<m n 1) -i≤pred[j]⇒i<j {_} { -[1+ n ]} leq = ≤-<-trans leq (-<- ℕ.≤-refl) - -i<j⇒i≤pred[j] : i < j → i ≤ pred j -i<j⇒i≤pred[j] {_} { +0} -<+ = -≤- z≤n -i<j⇒i≤pred[j] {_} { +[1+ n ]} -<+ = -≤+ -i<j⇒i≤pred[j] {_} { +[1+ n ]} (+<+ m<n) = +≤+ (ℕ.≤-pred m<n) -i<j⇒i≤pred[j] {_} { -[1+ n ]} (-<- n<m) = -≤- n<m - -i≤j⇒pred[i]≤j : i ≤ j → pred i ≤ j -i≤j⇒pred[i]≤j -≤+ = -≤+ -i≤j⇒pred[i]≤j (-≤- n≤m) = -≤- (ℕ.m≤n⇒m≤1+n n≤m) -i≤j⇒pred[i]≤j (+≤+ z≤n) = -≤+ -i≤j⇒pred[i]≤j (+≤+ (s≤s m≤n)) = +≤+ (ℕ.m≤n⇒m≤1+n m≤n) - -pred-mono : pred Preserves _≤_ ⟶ _≤_ -pred-mono (-≤+ {n = 0}) = -≤- z≤n -pred-mono (-≤+ {n = suc n}) = -≤+ -pred-mono (-≤- n≤m) = -≤- (s≤s n≤m) -pred-mono (+≤+ m≤n) = ⊖-monoˡ-≤ 1 m≤n - ------------------------------------------------------------------------- --- Properties of _*_ ------------------------------------------------------------------------- --- Algebraic properties - -*-comm : Commutative _*_ -*-comm -[1+ m ] -[1+ n ] rewrite ℕ.*-comm (suc m) (suc n) = refl -*-comm -[1+ m ] (+ n) rewrite ℕ.*-comm (suc m) n = refl -*-comm (+ m) -[1+ n ] rewrite ℕ.*-comm m (suc n) = refl -*-comm (+ m) (+ n) rewrite ℕ.*-comm m n = refl - -*-identityˡ : LeftIdentity 1ℤ _*_ -*-identityˡ -[1+ n ] rewrite ℕ.+-identityʳ n = refl -*-identityˡ +0 = refl -*-identityˡ +[1+ n ] rewrite ℕ.+-identityʳ n = refl - -*-identityʳ : RightIdentity 1ℤ _*_ -*-identityʳ = comm+idˡ⇒idʳ *-comm *-identityˡ - -*-identity : Identity 1ℤ _*_ -*-identity = *-identityˡ , *-identityʳ - -*-zeroˡ : LeftZero 0ℤ _*_ -*-zeroˡ _ = refl - -*-zeroʳ : RightZero 0ℤ _*_ -*-zeroʳ = comm+zeˡ⇒zeʳ *-comm *-zeroˡ - -*-zero : Zero 0ℤ _*_ -*-zero = *-zeroˡ , *-zeroʳ - -private - lemma : ∀ m n o → o ℕ.+ (n ℕ.+ m ℕ.* suc n) ℕ.* suc o - ≡ o ℕ.+ n ℕ.* suc o ℕ.+ m ℕ.* suc (o ℕ.+ n ℕ.* suc o) - lemma = - solve 3 (λ m n o → o :+ (n :+ m :* (con 1 :+ n)) :* (con 1 :+ o) - := o :+ n :* (con 1 :+ o) :+ - m :* (con 1 :+ (o :+ n :* (con 1 :+ o)))) - refl - -*-assoc : Associative _*_ -*-assoc +0 _ _ = refl -*-assoc i +0 _ rewrite ℕ.*-zeroʳ ∣ i ∣ = refl -*-assoc i j +0 rewrite - ℕ.*-zeroʳ ∣ j ∣ - | ℕ.*-zeroʳ ∣ i ∣ - | ℕ.*-zeroʳ ∣ sign i 𝕊* sign j ◃ ∣ i ∣ ℕ.* ∣ j ∣ ∣ - = refl -*-assoc -[1+ m ] -[1+ n ] +[1+ o ] = cong (+_ ∘ suc) (lemma m n o) -*-assoc -[1+ m ] +[1+ n ] -[1+ o ] = cong (+_ ∘ suc) (lemma m n o) -*-assoc +[1+ m ] +[1+ n ] +[1+ o ] = cong (+_ ∘ suc) (lemma m n o) -*-assoc +[1+ m ] -[1+ n ] -[1+ o ] = cong (+_ ∘ suc) (lemma m n o) -*-assoc -[1+ m ] -[1+ n ] -[1+ o ] = cong -[1+_] (lemma m n o) -*-assoc -[1+ m ] +[1+ n ] +[1+ o ] = cong -[1+_] (lemma m n o) -*-assoc +[1+ m ] -[1+ n ] +[1+ o ] = cong -[1+_] (lemma m n o) -*-assoc +[1+ m ] +[1+ n ] -[1+ o ] = cong -[1+_] (lemma m n o) - -private - - -- lemma used to prove distributivity. - distrib-lemma : ∀ m n o → (o ⊖ n) * -[1+ m ] ≡ m ℕ.+ n ℕ.* suc m ⊖ (m ℕ.+ o ℕ.* suc m) - distrib-lemma m n o - rewrite +-cancelˡ-⊖ m (n ℕ.* suc m) (o ℕ.* suc m) - | ⊖-swap (n ℕ.* suc m) (o ℕ.* suc m) - with n ℕ.≤? o - ... | yes n≤o - rewrite ⊖-≥ n≤o - | ⊖-≥ (ℕ.*-mono-≤ n≤o (ℕ.≤-refl {x = suc m})) - | -◃n≡-n ((o ∸ n) ℕ.* suc m) - | ℕ.*-distribʳ-∸ (suc m) o n - = refl - ... | no n≰o - rewrite sign-⊖-≰ n≰o - | ∣⊖∣-≰ n≰o - | +◃n≡+n ((n ∸ o) ℕ.* suc m) - | ⊖-≰ (n≰o ∘ ℕ.*-cancelʳ-≤ n o (suc m)) - | neg-involutive (+ (n ℕ.* suc m ∸ o ℕ.* suc m)) - | ℕ.*-distribʳ-∸ (suc m) n o - = refl - -*-distribʳ-+ : _*_ DistributesOverʳ _+_ -*-distribʳ-+ +0 y z - rewrite ℕ.*-zeroʳ ∣ y ∣ - | ℕ.*-zeroʳ ∣ z ∣ - | ℕ.*-zeroʳ ∣ y + z ∣ - = refl -*-distribʳ-+ x +0 z - rewrite +-identityˡ z - | +-identityˡ (sign z 𝕊* sign x ◃ ∣ z ∣ ℕ.* ∣ x ∣) - = refl -*-distribʳ-+ x y +0 - rewrite +-identityʳ y - | +-identityʳ (sign y 𝕊* sign x ◃ ∣ y ∣ ℕ.* ∣ x ∣) - = refl -*-distribʳ-+ -[1+ m ] -[1+ n ] -[1+ o ] = cong (+_) $ - solve 3 (λ m n o → (con 2 :+ n :+ o) :* (con 1 :+ m) - := (con 1 :+ n) :* (con 1 :+ m) :+ - (con 1 :+ o) :* (con 1 :+ m)) - refl m n o -*-distribʳ-+ +[1+ m ] +[1+ n ] +[1+ o ] = cong (+_) $ - solve 3 (λ m n o → (con 1 :+ n :+ (con 1 :+ o)) :* (con 1 :+ m) - := (con 1 :+ n) :* (con 1 :+ m) :+ - (con 1 :+ o) :* (con 1 :+ m)) - refl m n o -*-distribʳ-+ -[1+ m ] +[1+ n ] +[1+ o ] = cong -[1+_] $ - solve 3 (λ m n o → m :+ (n :+ (con 1 :+ o)) :* (con 1 :+ m) - := (con 1 :+ n) :* (con 1 :+ m) :+ - (m :+ o :* (con 1 :+ m))) - refl m n o -*-distribʳ-+ +[1+ m ] -[1+ n ] -[1+ o ] = cong -[1+_] $ - solve 3 (λ m n o → m :+ (con 1 :+ m :+ (n :+ o) :* (con 1 :+ m)) - := (con 1 :+ n) :* (con 1 :+ m) :+ - (m :+ o :* (con 1 :+ m))) - refl m n o -*-distribʳ-+ -[1+ m ] -[1+ n ] +[1+ o ] = begin - (suc o ⊖ suc n) * -[1+ m ] ≡⟨ cong (_* -[1+ m ]) ([1+m]⊖[1+n]≡m⊖n o n) ⟩ - (o ⊖ n) * -[1+ m ] ≡⟨ distrib-lemma m n o ⟩ - m ℕ.+ n ℕ.* suc m ⊖ (m ℕ.+ o ℕ.* suc m) ≡˘⟨ [1+m]⊖[1+n]≡m⊖n (m ℕ.+ n ℕ.* suc m) (m ℕ.+ o ℕ.* suc m) ⟩ - -[1+ n ] * -[1+ m ] + +[1+ o ] * -[1+ m ] ∎ where open ≡-Reasoning -*-distribʳ-+ -[1+ m ] +[1+ n ] -[1+ o ] = begin - (+[1+ n ] + -[1+ o ]) * -[1+ m ] ≡⟨ cong (_* -[1+ m ]) ([1+m]⊖[1+n]≡m⊖n n o) ⟩ - (n ⊖ o) * -[1+ m ] ≡⟨ distrib-lemma m o n ⟩ - m ℕ.+ o ℕ.* suc m ⊖ (m ℕ.+ n ℕ.* suc m) ≡˘⟨ [1+m]⊖[1+n]≡m⊖n (m ℕ.+ o ℕ.* suc m) (m ℕ.+ n ℕ.* suc m) ⟩ - +[1+ n ] * -[1+ m ] + -[1+ o ] * -[1+ m ] ∎ where open ≡-Reasoning -*-distribʳ-+ +[1+ m ] -[1+ n ] +[1+ o ] with n ℕ.≤? o -... | yes n≤o - rewrite [1+m]⊖[1+n]≡m⊖n o n - | [1+m]⊖[1+n]≡m⊖n (m ℕ.+ o ℕ.* suc m) (m ℕ.+ n ℕ.* suc m) - | +-cancelˡ-⊖ m (o ℕ.* suc m) (n ℕ.* suc m) - | ⊖-≥ n≤o - | +-comm (- (+ (m ℕ.+ n ℕ.* suc m))) (+ (m ℕ.+ o ℕ.* suc m)) - | ⊖-≥ (ℕ.*-mono-≤ n≤o (ℕ.≤-refl {x = suc m})) - | ℕ.*-distribʳ-∸ (suc m) o n - | +◃n≡+n (o ℕ.* suc m ∸ n ℕ.* suc m) - = refl -... | no n≰o - rewrite [1+m]⊖[1+n]≡m⊖n o n - | [1+m]⊖[1+n]≡m⊖n (m ℕ.+ o ℕ.* suc m) (m ℕ.+ n ℕ.* suc m) - | +-cancelˡ-⊖ m (o ℕ.* suc m) (n ℕ.* suc m) - | sign-⊖-≰ n≰o - | ∣⊖∣-≰ n≰o - | -◃n≡-n ((n ∸ o) ℕ.* suc m) - | ⊖-≰ (n≰o ∘ ℕ.*-cancelʳ-≤ n o (suc m)) - | ℕ.*-distribʳ-∸ (suc m) n o - = refl -*-distribʳ-+ +[1+ o ] +[1+ m ] -[1+ n ] with n ℕ.≤? m -... | yes n≤m - rewrite [1+m]⊖[1+n]≡m⊖n m n - | [1+m]⊖[1+n]≡m⊖n (o ℕ.+ m ℕ.* suc o) (o ℕ.+ n ℕ.* suc o) - | +-cancelˡ-⊖ o (m ℕ.* suc o) (n ℕ.* suc o) - | ⊖-≥ n≤m - | ⊖-≥ (ℕ.*-mono-≤ n≤m (ℕ.≤-refl {x = suc o})) - | +◃n≡+n ((m ∸ n) ℕ.* suc o) - | ℕ.*-distribʳ-∸ (suc o) m n - = refl -... | no n≰m - rewrite [1+m]⊖[1+n]≡m⊖n m n - | [1+m]⊖[1+n]≡m⊖n (o ℕ.+ m ℕ.* suc o) (o ℕ.+ n ℕ.* suc o) - | +-cancelˡ-⊖ o (m ℕ.* suc o) (n ℕ.* suc o) - | sign-⊖-≰ n≰m - | ∣⊖∣-≰ n≰m - | ⊖-≰ (n≰m ∘ ℕ.*-cancelʳ-≤ n m (suc o)) - | -◃n≡-n ((n ∸ m) ℕ.* suc o) - | ℕ.*-distribʳ-∸ (suc o) n m - = refl - -*-distribˡ-+ : _*_ DistributesOverˡ _+_ -*-distribˡ-+ = comm+distrʳ⇒distrˡ *-comm *-distribʳ-+ - -*-distrib-+ : _*_ DistributesOver _+_ -*-distrib-+ = *-distribˡ-+ , *-distribʳ-+ - ------------------------------------------------------------------------- --- Structures - -*-isMagma : IsMagma _*_ -*-isMagma = record - { isEquivalence = isEquivalence - ; ∙-cong = cong₂ _*_ - } - -*-isSemigroup : IsSemigroup _*_ -*-isSemigroup = record - { isMagma = *-isMagma - ; assoc = *-assoc - } - -*-isCommutativeSemigroup : IsCommutativeSemigroup _*_ -*-isCommutativeSemigroup = record - { isSemigroup = *-isSemigroup - ; comm = *-comm - } - -*-1-isMonoid : IsMonoid _*_ 1ℤ -*-1-isMonoid = record - { isSemigroup = *-isSemigroup - ; identity = *-identity - } - -*-1-isCommutativeMonoid : IsCommutativeMonoid _*_ 1ℤ -*-1-isCommutativeMonoid = record - { isMonoid = *-1-isMonoid - ; comm = *-comm - } - -+-*-isSemiring : IsSemiring _+_ _*_ 0ℤ 1ℤ -+-*-isSemiring = record - { isSemiringWithoutAnnihilatingZero = record - { +-isCommutativeMonoid = +-0-isCommutativeMonoid - ; *-cong = cong₂ _*_ - ; *-assoc = *-assoc - ; *-identity = *-identity - ; distrib = *-distrib-+ - } - ; zero = *-zero - } - -+-*-isCommutativeSemiring : IsCommutativeSemiring _+_ _*_ 0ℤ 1ℤ -+-*-isCommutativeSemiring = record - { isSemiring = +-*-isSemiring - ; *-comm = *-comm - } - -+-*-isRing : IsRing _+_ _*_ -_ 0ℤ 1ℤ -+-*-isRing = record - { +-isAbelianGroup = +-0-isAbelianGroup - ; *-cong = cong₂ _*_ - ; *-assoc = *-assoc - ; *-identity = *-identity - ; distrib = *-distrib-+ - ; zero = *-zero - } - -+-*-isCommutativeRing : IsCommutativeRing _+_ _*_ -_ 0ℤ 1ℤ -+-*-isCommutativeRing = record - { isRing = +-*-isRing - ; *-comm = *-comm - } - ------------------------------------------------------------------------- --- Bundles - -*-magma : Magma 0ℓ 0ℓ -*-magma = record - { isMagma = *-isMagma - } - -*-semigroup : Semigroup 0ℓ 0ℓ -*-semigroup = record - { isSemigroup = *-isSemigroup - } - -*-commutativeSemigroup : CommutativeSemigroup 0ℓ 0ℓ -*-commutativeSemigroup = record - { isCommutativeSemigroup = *-isCommutativeSemigroup - } - -*-1-monoid : Monoid 0ℓ 0ℓ -*-1-monoid = record - { isMonoid = *-1-isMonoid - } - -*-1-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ -*-1-commutativeMonoid = record - { isCommutativeMonoid = *-1-isCommutativeMonoid - } - -+-*-semiring : Semiring 0ℓ 0ℓ -+-*-semiring = record - { isSemiring = +-*-isSemiring - } - -+-*-commutativeSemiring : CommutativeSemiring 0ℓ 0ℓ -+-*-commutativeSemiring = record - { isCommutativeSemiring = +-*-isCommutativeSemiring - } - -+-*-ring : Ring 0ℓ 0ℓ -+-*-ring = record - { isRing = +-*-isRing - } - -+-*-commutativeRing : CommutativeRing 0ℓ 0ℓ -+-*-commutativeRing = record - { isCommutativeRing = +-*-isCommutativeRing - } - ------------------------------------------------------------------------- --- Other properties of _*_ and _≡_ - -abs-* : ℤtoℕ.Homomorphic₂ ∣_∣ _*_ ℕ._*_ -abs-* i j = abs-◃ _ _ - -*-cancelʳ-≡ : ∀ i j k .{{_ : NonZero k}} → i * k ≡ j * k → i ≡ j -*-cancelʳ-≡ i j k eq with sign-cong′ eq -... | inj₁ s[ik]≡s[jk] = ◃-cong - (𝕊ₚ.*-cancelʳ-≡ (sign k) (sign i) (sign j) s[ik]≡s[jk]) - (ℕ.*-cancelʳ-≡ ∣ i ∣ ∣ j ∣ _ (abs-cong eq)) -... | inj₂ (∣ik∣≡0 , ∣jk∣≡0) = trans - (∣i∣≡0⇒i≡0 (ℕ.m*n≡0⇒m≡0 _ _ ∣ik∣≡0)) - (sym (∣i∣≡0⇒i≡0 (ℕ.m*n≡0⇒m≡0 _ _ ∣jk∣≡0))) - -*-cancelˡ-≡ : ∀ i j k .{{_ : NonZero i}} → i * j ≡ i * k → j ≡ k -*-cancelˡ-≡ i j k rewrite *-comm i j | *-comm i k = *-cancelʳ-≡ j k i - -suc-* : ∀ i j → sucℤ i * j ≡ j + i * j -suc-* i j = begin - sucℤ i * j ≡⟨ *-distribʳ-+ j (+ 1) i ⟩ - + 1 * j + i * j ≡⟨ cong (_+ i * j) (*-identityˡ j) ⟩ - j + i * j ∎ - where open ≡-Reasoning - -*-suc : ∀ i j → i * sucℤ j ≡ i + i * j -*-suc i j = begin - i * sucℤ j ≡⟨ *-comm i _ ⟩ - sucℤ j * i ≡⟨ suc-* j i ⟩ - i + j * i ≡⟨ cong (λ v → i + v) (*-comm j i) ⟩ - i + i * j ∎ - where open ≡-Reasoning - --1*i≡-i : ∀ i → -1ℤ * i ≡ - i --1*i≡-i -[1+ n ] = cong +[1+_] (ℕ.+-identityʳ n) --1*i≡-i +0 = refl --1*i≡-i +[1+ n ] = cong -[1+_] (ℕ.+-identityʳ n) - -i*j≡0⇒i≡0∨j≡0 : ∀ i {j} → i * j ≡ 0ℤ → i ≡ 0ℤ ⊎ j ≡ 0ℤ -i*j≡0⇒i≡0∨j≡0 i p with ℕ.m*n≡0⇒m≡0∨n≡0 ∣ i ∣ (abs-cong {t = Sign.+} p) -... | inj₁ ∣i∣≡0 = inj₁ (∣i∣≡0⇒i≡0 ∣i∣≡0) -... | inj₂ ∣j∣≡0 = inj₂ (∣i∣≡0⇒i≡0 ∣j∣≡0) - ------------------------------------------------------------------------- --- Properties of _^_ ------------------------------------------------------------------------- - -^-identityʳ : ∀ i → i ^ 1 ≡ i -^-identityʳ = *-identityʳ - -^-zeroˡ : ∀ n → 1ℤ ^ n ≡ 1ℤ -^-zeroˡ zero = refl -^-zeroˡ (suc n) = begin - 1ℤ ^ suc n ≡⟨⟩ - 1ℤ * (1ℤ ^ n) ≡⟨ *-identityˡ (1ℤ ^ n) ⟩ - 1ℤ ^ n ≡⟨ ^-zeroˡ n ⟩ - 1ℤ ∎ - where open ≡-Reasoning - -^-distribˡ-+-* : ∀ i m n → i ^ (m ℕ.+ n) ≡ i ^ m * i ^ n -^-distribˡ-+-* i zero n = sym (*-identityˡ (i ^ n)) -^-distribˡ-+-* i (suc m) n = begin - i * (i ^ (m ℕ.+ n)) ≡⟨ cong (i *_) (^-distribˡ-+-* i m n) ⟩ - i * ((i ^ m) * (i ^ n)) ≡⟨ sym (*-assoc i _ _) ⟩ - (i * (i ^ m)) * (i ^ n) ∎ - where open ≡-Reasoning - -^-isMagmaHomomorphism : ∀ i → Morphism.IsMagmaHomomorphism ℕ.+-rawMagma *-rawMagma (i ^_) -^-isMagmaHomomorphism i = record - { isRelHomomorphism = record { cong = cong (i ^_) } - ; homo = ^-distribˡ-+-* i - } - -^-isMonoidHomomorphism : ∀ i → Morphism.IsMonoidHomomorphism ℕ.+-0-rawMonoid *-1-rawMonoid (i ^_) -^-isMonoidHomomorphism i = record - { isMagmaHomomorphism = ^-isMagmaHomomorphism i - ; ε-homo = refl - } - -^-*-assoc : ∀ i m n → (i ^ m) ^ n ≡ i ^ (m ℕ.* n) -^-*-assoc i m zero = cong (i ^_) (sym $ ℕ.*-zeroʳ m) -^-*-assoc i m (suc n) = begin - (i ^ m) * ((i ^ m) ^ n) ≡⟨ cong ((i ^ m) *_) (^-*-assoc i m n) ⟩ - (i ^ m) * (i ^ (m ℕ.* n)) ≡⟨ sym (^-distribˡ-+-* i m (m ℕ.* n)) ⟩ - i ^ (m ℕ.+ m ℕ.* n) ≡⟨ cong (i ^_) (sym (ℕ.*-suc m n)) ⟩ - i ^ (m ℕ.* suc n) ∎ - where open ≡-Reasoning - -i^n≡0⇒i≡0 : ∀ i n → i ^ n ≡ 0ℤ → i ≡ 0ℤ -i^n≡0⇒i≡0 i (suc n) eq = [ id , i^n≡0⇒i≡0 i n ]′ (i*j≡0⇒i≡0∨j≡0 i eq) - ------------------------------------------------------------------------- --- Properties of _*_ and +_/-_ - -pos-* : ℕtoℤ.Homomorphic₂ +_ ℕ._*_ _*_ -pos-* zero n = refl -pos-* (suc m) zero = pos-* m zero -pos-* (suc m) (suc n) = refl - -neg-distribˡ-* : ∀ i j → - (i * j) ≡ (- i) * j -neg-distribˡ-* i j = begin - - (i * j) ≡˘⟨ -1*i≡-i (i * j) ⟩ - -1ℤ * (i * j) ≡˘⟨ *-assoc -1ℤ i j ⟩ - -1ℤ * i * j ≡⟨ cong (_* j) (-1*i≡-i i) ⟩ - - i * j ∎ where open ≡-Reasoning - -neg-distribʳ-* : ∀ i j → - (i * j) ≡ i * (- j) -neg-distribʳ-* i j = begin - - (i * j) ≡⟨ cong -_ (*-comm i j) ⟩ - - (j * i) ≡⟨ neg-distribˡ-* j i ⟩ - - j * i ≡⟨ *-comm (- j) i ⟩ - i * (- j) ∎ where open ≡-Reasoning - ------------------------------------------------------------------------- --- Properties of _*_ and _◃_ - -◃-distrib-* : ∀ s t m n → (s 𝕊* t) ◃ (m ℕ.* n) ≡ (s ◃ m) * (t ◃ n) -◃-distrib-* s t zero zero = refl -◃-distrib-* s t zero (suc n) = refl -◃-distrib-* s t (suc m) zero = - trans - (cong₂ _◃_ (𝕊ₚ.*-comm s t) (ℕ.*-comm m 0)) - (*-comm (t ◃ zero) (s ◃ suc m)) -◃-distrib-* s t (suc m) (suc n) = - sym (cong₂ _◃_ - (cong₂ _𝕊*_ (sign-◃ s (suc m)) (sign-◃ t (suc n))) - (∣s◃m∣*∣t◃n∣≡m*n s t (suc m) (suc n))) +open import Data.Bool.Base using (T; true; false) +open import Data.Integer.Base renaming (suc to sucℤ) +open import Data.Nat.Base as ℕ + using (ℕ; suc; zero; _∸_; s≤s; z≤n; s<s; z<s; s≤s⁻¹; s<s⁻¹) + hiding (module ℕ) +import Data.Nat.Properties as ℕ +open import Data.Nat.Solver +open import Data.Product.Base using (proj₁; proj₂; _,_; _×_) +open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂; [_,_]′) +open import Data.Sign as Sign using (Sign) renaming (_*_ to _𝕊*_) +import Data.Sign.Properties as 𝕊ₚ +open import Function.Base using (_∘_; _$_; id) +open import Level using (0ℓ) +open import Relation.Binary.Core using (_⇒_; _Preserves_⟶_; _Preserves₂_⟶_⟶_) +open import Relation.Binary.Bundles using + (Setoid; DecSetoid; Preorder; TotalPreorder; Poset; TotalOrder; DecTotalOrder; StrictPartialOrder; StrictTotalOrder) +open import Relation.Binary.Structures + using (IsPreorder; IsTotalPreorder; IsPartialOrder; IsTotalOrder; IsDecTotalOrder; IsStrictPartialOrder; IsStrictTotalOrder) +open import Relation.Binary.Definitions + using (DecidableEquality; Reflexive; Transitive; Antisymmetric; Total; Decidable; Irrelevant; Irreflexive; Asymmetric; LeftTrans; RightTrans; Trichotomous; tri≈; tri<; tri>) +open import Relation.Binary.PropositionalEquality +open import Relation.Nullary using (yes; no; ¬_) +import Relation.Nullary.Reflects as Reflects +open import Relation.Nullary.Negation using (contradiction) +import Relation.Nullary.Decidable as Dec + +open import Algebra.Definitions {A = ℤ} _≡_ +open import Algebra.Consequences.Propositional +open import Algebra.Structures {A = ℤ} _≡_ +module ℤtoℕ = Morphism.Definitions ℤ ℕ _≡_ +module ℕtoℤ = Morphism.Definitions ℕ ℤ _≡_ +open +-*-Solver + +private + variable + m n o : ℕ + i j k : ℤ + s t : Sign + +------------------------------------------------------------------------ +-- Equality +------------------------------------------------------------------------ + ++-injective : + m ≡ + n → m ≡ n ++-injective refl = refl + +-[1+-injective : -[1+ m ] ≡ -[1+ n ] → m ≡ n +-[1+-injective refl = refl + ++[1+-injective : +[1+ m ] ≡ +[1+ n ] → m ≡ n ++[1+-injective refl = refl + +infix 4 _≟_ +_≟_ : DecidableEquality ℤ ++ m ≟ + n = Dec.map′ (cong (+_)) +-injective (m ℕ.≟ n) ++ m ≟ -[1+ n ] = no λ() +-[1+ m ] ≟ + n = no λ() +-[1+ m ] ≟ -[1+ n ] = Dec.map′ (cong -[1+_]) -[1+-injective (m ℕ.≟ n) + +≡-setoid : Setoid 0ℓ 0ℓ +≡-setoid = setoid ℤ + +≡-decSetoid : DecSetoid 0ℓ 0ℓ +≡-decSetoid = decSetoid _≟_ + +------------------------------------------------------------------------ +-- Properties of _≤_ +------------------------------------------------------------------------ + +drop‿+≤+ : + m ≤ + n → m ℕ.≤ n +drop‿+≤+ (+≤+ m≤n) = m≤n + +drop‿-≤- : -[1+ m ] ≤ -[1+ n ] → n ℕ.≤ m +drop‿-≤- (-≤- n≤m) = n≤m + +------------------------------------------------------------------------ +-- Relational properties + +≤-reflexive : _≡_ ⇒ _≤_ +≤-reflexive { -[1+ n ]} refl = -≤- ℕ.≤-refl +≤-reflexive {+ n} refl = +≤+ ℕ.≤-refl + +≤-refl : Reflexive _≤_ +≤-refl = ≤-reflexive refl + +≤-trans : Transitive _≤_ +≤-trans -≤+ (+≤+ n≤m) = -≤+ +≤-trans (-≤- n≤m) -≤+ = -≤+ +≤-trans (-≤- n≤m) (-≤- k≤n) = -≤- (ℕ.≤-trans k≤n n≤m) +≤-trans (+≤+ m≤n) (+≤+ n≤k) = +≤+ (ℕ.≤-trans m≤n n≤k) + +≤-antisym : Antisymmetric _≡_ _≤_ +≤-antisym (-≤- n≤m) (-≤- m≤n) = cong -[1+_] $ ℕ.≤-antisym m≤n n≤m +≤-antisym (+≤+ m≤n) (+≤+ n≤m) = cong (+_) $ ℕ.≤-antisym m≤n n≤m + +≤-total : Total _≤_ +≤-total (-[1+ m ]) (-[1+ n ]) = Sum.map -≤- -≤- (ℕ.≤-total n m) +≤-total (-[1+ m ]) (+ n ) = inj₁ -≤+ +≤-total (+ m ) (-[1+ n ]) = inj₂ -≤+ +≤-total (+ m ) (+ n ) = Sum.map +≤+ +≤+ (ℕ.≤-total m n) + +infix 4 _≤?_ +_≤?_ : Decidable _≤_ +-[1+ m ] ≤? -[1+ n ] = Dec.map′ -≤- drop‿-≤- (n ℕ.≤? m) +-[1+ m ] ≤? + n = yes -≤+ ++ m ≤? -[1+ n ] = no λ () ++ m ≤? + n = Dec.map′ +≤+ drop‿+≤+ (m ℕ.≤? n) + +≤-irrelevant : Irrelevant _≤_ +≤-irrelevant -≤+ -≤+ = refl +≤-irrelevant (-≤- n≤m₁) (-≤- n≤m₂) = cong -≤- (ℕ.≤-irrelevant n≤m₁ n≤m₂) +≤-irrelevant (+≤+ n≤m₁) (+≤+ n≤m₂) = cong +≤+ (ℕ.≤-irrelevant n≤m₁ n≤m₂) + +------------------------------------------------------------------------ +-- Structures + +≤-isPreorder : IsPreorder _≡_ _≤_ +≤-isPreorder = record + { isEquivalence = isEquivalence + ; reflexive = ≤-reflexive + ; trans = ≤-trans + } + +≤-isTotalPreorder : IsTotalPreorder _≡_ _≤_ +≤-isTotalPreorder = record + { isPreorder = ≤-isPreorder + ; total = ≤-total + } + +≤-isPartialOrder : IsPartialOrder _≡_ _≤_ +≤-isPartialOrder = record + { isPreorder = ≤-isPreorder + ; antisym = ≤-antisym + } + +≤-isTotalOrder : IsTotalOrder _≡_ _≤_ +≤-isTotalOrder = record + { isPartialOrder = ≤-isPartialOrder + ; total = ≤-total + } + +≤-isDecTotalOrder : IsDecTotalOrder _≡_ _≤_ +≤-isDecTotalOrder = record + { isTotalOrder = ≤-isTotalOrder + ; _≟_ = _≟_ + ; _≤?_ = _≤?_ + } + +------------------------------------------------------------------------ +-- Bundles + +≤-preorder : Preorder 0ℓ 0ℓ 0ℓ +≤-preorder = record + { isPreorder = ≤-isPreorder + } + +≤-totalPreorder : TotalPreorder 0ℓ 0ℓ 0ℓ +≤-totalPreorder = record + { isTotalPreorder = ≤-isTotalPreorder + } + +≤-poset : Poset 0ℓ 0ℓ 0ℓ +≤-poset = record + { isPartialOrder = ≤-isPartialOrder + } + +≤-totalOrder : TotalOrder 0ℓ 0ℓ 0ℓ +≤-totalOrder = record + { isTotalOrder = ≤-isTotalOrder + } + +≤-decTotalOrder : DecTotalOrder 0ℓ 0ℓ 0ℓ +≤-decTotalOrder = record + { isDecTotalOrder = ≤-isDecTotalOrder + } + +------------------------------------------------------------------------ +-- Properties of _≤ᵇ_ +------------------------------------------------------------------------ + +≤ᵇ⇒≤ : T (i ≤ᵇ j) → i ≤ j +≤ᵇ⇒≤ {+ _} {+ _} i≤j = +≤+ (ℕ.≤ᵇ⇒≤ _ _ i≤j) +≤ᵇ⇒≤ { -[1+ _ ]} {+ _} i≤j = -≤+ +≤ᵇ⇒≤ { -[1+ _ ]} { -[1+ _ ]} i≤j = -≤- (ℕ.≤ᵇ⇒≤ _ _ i≤j) + +≤⇒≤ᵇ : i ≤ j → T (i ≤ᵇ j) +≤⇒≤ᵇ (-≤- n≤m) = ℕ.≤⇒≤ᵇ n≤m +≤⇒≤ᵇ -≤+ = _ +≤⇒≤ᵇ (+≤+ m≤n) = ℕ.≤⇒≤ᵇ m≤n + +------------------------------------------------------------------------ +-- Properties _<_ +------------------------------------------------------------------------ + +drop‿+<+ : + m < + n → m ℕ.< n +drop‿+<+ (+<+ m<n) = m<n + +drop‿-<- : -[1+ m ] < -[1+ n ] → n ℕ.< m +drop‿-<- (-<- n<m) = n<m + ++≮0 : + n ≮ +0 ++≮0 (+<+ ()) + ++≮- : + m ≮ -[1+ n ] ++≮- () + +------------------------------------------------------------------------ +-- Relationship between other operators + +<⇒≤ : _<_ ⇒ _≤_ +<⇒≤ (-<- i<j) = -≤- (ℕ.<⇒≤ i<j) +<⇒≤ -<+ = -≤+ +<⇒≤ (+<+ i<j) = +≤+ (ℕ.<⇒≤ i<j) + +<⇒≢ : _<_ ⇒ _≢_ +<⇒≢ (-<- n<m) refl = ℕ.<⇒≢ n<m refl +<⇒≢ (+<+ m<n) refl = ℕ.<⇒≢ m<n refl + +<⇒≱ : _<_ ⇒ _≱_ +<⇒≱ (-<- n<m) = ℕ.<⇒≱ n<m ∘ drop‿-≤- +<⇒≱ (+<+ m<n) = ℕ.<⇒≱ m<n ∘ drop‿+≤+ + +≤⇒≯ : _≤_ ⇒ _≯_ +≤⇒≯ (-≤- n≤m) (-<- n<m) = ℕ.≤⇒≯ n≤m n<m +≤⇒≯ -≤+ = +≮- +≤⇒≯ (+≤+ m≤n) (+<+ m<n) = ℕ.≤⇒≯ m≤n m<n + +≰⇒> : _≰_ ⇒ _>_ +≰⇒> {+ n} {+_ n₁} i≰j = +<+ (ℕ.≰⇒> (i≰j ∘ +≤+)) +≰⇒> {+ n} { -[1+_] n₁} i≰j = -<+ +≰⇒> { -[1+_] n} {+_ n₁} i≰j = contradiction -≤+ i≰j +≰⇒> { -[1+_] n} { -[1+_] n₁} i≰j = -<- (ℕ.≰⇒> (i≰j ∘ -≤-)) + +≮⇒≥ : _≮_ ⇒ _≥_ +≮⇒≥ {+ i} {+ j} i≮j = +≤+ (ℕ.≮⇒≥ (i≮j ∘ +<+)) +≮⇒≥ {+ i} { -[1+_] j} i≮j = -≤+ +≮⇒≥ { -[1+_] i} {+ j} i≮j = contradiction -<+ i≮j +≮⇒≥ { -[1+_] i} { -[1+_] j} i≮j = -≤- (ℕ.≮⇒≥ (i≮j ∘ -<-)) + +>⇒≰ : _>_ ⇒ _≰_ +>⇒≰ = <⇒≱ + +≤∧≢⇒< : i ≤ j → i ≢ j → i < j +≤∧≢⇒< (-≤- m≤n) i≢j = -<- (ℕ.≤∧≢⇒< m≤n (i≢j ∘ cong -[1+_] ∘ sym)) +≤∧≢⇒< -≤+ i≢j = -<+ +≤∧≢⇒< (+≤+ n≤m) i≢j = +<+ (ℕ.≤∧≢⇒< n≤m (i≢j ∘ cong (+_))) + +≤∧≮⇒≡ : i ≤ j → i ≮ j → i ≡ j +≤∧≮⇒≡ i≤j i≮j = ≤-antisym i≤j (≮⇒≥ i≮j) + +------------------------------------------------------------------------ +-- Relational properties + +<-irrefl : Irreflexive _≡_ _<_ +<-irrefl { -[1+ n ]} refl = ℕ.<-irrefl refl ∘ drop‿-<- +<-irrefl { +0} refl (+<+ ()) +<-irrefl { +[1+ n ]} refl = ℕ.<-irrefl refl ∘ drop‿+<+ + +<-asym : Asymmetric _<_ +<-asym (-<- n<m) = ℕ.<-asym n<m ∘ drop‿-<- +<-asym (+<+ m<n) = ℕ.<-asym m<n ∘ drop‿+<+ + +≤-<-trans : LeftTrans _≤_ _<_ +≤-<-trans (-≤- n≤m) (-<- o<n) = -<- (ℕ.<-≤-trans o<n n≤m) +≤-<-trans (-≤- n≤m) -<+ = -<+ +≤-<-trans -≤+ (+<+ m<o) = -<+ +≤-<-trans (+≤+ m≤n) (+<+ n<o) = +<+ (ℕ.≤-<-trans m≤n n<o) + +<-≤-trans : RightTrans _<_ _≤_ +<-≤-trans (-<- n<m) (-≤- o≤n) = -<- (ℕ.≤-<-trans o≤n n<m) +<-≤-trans (-<- n<m) -≤+ = -<+ +<-≤-trans -<+ (+≤+ m≤n) = -<+ +<-≤-trans (+<+ m<n) (+≤+ n≤o) = +<+ (ℕ.<-≤-trans m<n n≤o) + +<-trans : Transitive _<_ +<-trans m<n n<p = ≤-<-trans (<⇒≤ m<n) n<p + +<-cmp : Trichotomous _≡_ _<_ +<-cmp +0 +0 = tri≈ +≮0 refl +≮0 +<-cmp +0 +[1+ n ] = tri< (+<+ z<s) (λ()) +≮0 +<-cmp +[1+ n ] +0 = tri> +≮0 (λ()) (+<+ z<s) +<-cmp (+ m) -[1+ n ] = tri> +≮- (λ()) -<+ +<-cmp -[1+ m ] (+ n) = tri< -<+ (λ()) +≮- +<-cmp -[1+ m ] -[1+ n ] with ℕ.<-cmp m n +... | tri< m<n m≢n n≯m = tri> (n≯m ∘ drop‿-<-) (m≢n ∘ -[1+-injective) (-<- m<n) +... | tri≈ m≮n m≡n n≯m = tri≈ (n≯m ∘ drop‿-<-) (cong -[1+_] m≡n) (m≮n ∘ drop‿-<-) +... | tri> m≮n m≢n n>m = tri< (-<- n>m) (m≢n ∘ -[1+-injective) (m≮n ∘ drop‿-<-) +<-cmp +[1+ m ] +[1+ n ] with ℕ.<-cmp m n +... | tri< m<n m≢n n≯m = tri< (+<+ (s<s m<n)) (m≢n ∘ +[1+-injective) (n≯m ∘ s<s⁻¹ ∘ drop‿+<+) +... | tri≈ m≮n m≡n n≯m = tri≈ (m≮n ∘ s<s⁻¹ ∘ drop‿+<+) (cong (+_ ∘ suc) m≡n) (n≯m ∘ s<s⁻¹ ∘ drop‿+<+) +... | tri> m≮n m≢n n>m = tri> (m≮n ∘ s<s⁻¹ ∘ drop‿+<+) (m≢n ∘ +[1+-injective) (+<+ (s<s n>m)) + +infix 4 _<?_ +_<?_ : Decidable _<_ +-[1+ m ] <? -[1+ n ] = Dec.map′ -<- drop‿-<- (n ℕ.<? m) +-[1+ m ] <? + n = yes -<+ ++ m <? -[1+ n ] = no λ() ++ m <? + n = Dec.map′ +<+ drop‿+<+ (m ℕ.<? n) + +<-irrelevant : Irrelevant _<_ +<-irrelevant (-<- n<m₁) (-<- n<m₂) = cong -<- (ℕ.<-irrelevant n<m₁ n<m₂) +<-irrelevant -<+ -<+ = refl +<-irrelevant (+<+ m<n₁) (+<+ m<n₂) = cong +<+ (ℕ.<-irrelevant m<n₁ m<n₂) + +------------------------------------------------------------------------ +-- Structures + +<-isStrictPartialOrder : IsStrictPartialOrder _≡_ _<_ +<-isStrictPartialOrder = record + { isEquivalence = isEquivalence + ; irrefl = <-irrefl + ; trans = <-trans + ; <-resp-≈ = subst (_ <_) , subst (_< _) + } + +<-isStrictTotalOrder : IsStrictTotalOrder _≡_ _<_ +<-isStrictTotalOrder = record + { isStrictPartialOrder = <-isStrictPartialOrder + ; compare = <-cmp + } + +------------------------------------------------------------------------ +-- Bundles + +<-strictPartialOrder : StrictPartialOrder 0ℓ 0ℓ 0ℓ +<-strictPartialOrder = record + { isStrictPartialOrder = <-isStrictPartialOrder + } + +<-strictTotalOrder : StrictTotalOrder 0ℓ 0ℓ 0ℓ +<-strictTotalOrder = record + { isStrictTotalOrder = <-isStrictTotalOrder + } + +------------------------------------------------------------------------ +-- Other properties of _<_ + +i≮i : i ≮ i +i≮i = <-irrefl refl + +>-irrefl : Irreflexive _≡_ _>_ +>-irrefl = <-irrefl ∘ sym + +------------------------------------------------------------------------ +-- A specialised module for reasoning about the _≤_ and _<_ relations +------------------------------------------------------------------------ + +module ≤-Reasoning where + open import Relation.Binary.Reasoning.Base.Triple + ≤-isPreorder + <-asym + <-trans + (resp₂ _<_) + <⇒≤ + <-≤-trans + ≤-<-trans + public + hiding (step-≈; step-≈˘; step-≈-⟩; step-≈-⟨) + +------------------------------------------------------------------------ +-- Properties of Positive/NonPositive/Negative/NonNegative and _≤_/_<_ + +positive⁻¹ : ∀ i → .{{Positive i}} → i > 0ℤ +positive⁻¹ +[1+ n ] = +<+ z<s + +negative⁻¹ : ∀ i → .{{Negative i}} → i < 0ℤ +negative⁻¹ -[1+ n ] = -<+ + +nonPositive⁻¹ : ∀ i → .{{NonPositive i}} → i ≤ 0ℤ +nonPositive⁻¹ +0 = +≤+ z≤n +nonPositive⁻¹ -[1+ n ] = -≤+ + +nonNegative⁻¹ : ∀ i → .{{NonNegative i}} → i ≥ 0ℤ +nonNegative⁻¹ (+ n) = +≤+ z≤n + +negative<positive : ∀ i j → .{{Negative i}} → .{{Positive j}} → i < j +negative<positive i j = <-trans (negative⁻¹ i) (positive⁻¹ j) + +------------------------------------------------------------------------ +-- Properties of -_ +------------------------------------------------------------------------ + +neg-involutive : ∀ i → - - i ≡ i +neg-involutive -[1+ n ] = refl +neg-involutive +0 = refl +neg-involutive +[1+ n ] = refl + +neg-injective : - i ≡ - j → i ≡ j +neg-injective {i} {j} -i≡-j = begin + i ≡⟨ neg-involutive i ⟨ + - - i ≡⟨ cong -_ -i≡-j ⟩ + - - j ≡⟨ neg-involutive j ⟩ + j ∎ where open ≡-Reasoning + +neg-≤-pos : ∀ {m n} → - (+ m) ≤ + n +neg-≤-pos {zero} = +≤+ z≤n +neg-≤-pos {suc m} = -≤+ + +neg-mono-≤ : -_ Preserves _≤_ ⟶ _≥_ +neg-mono-≤ -≤+ = neg-≤-pos +neg-mono-≤ (-≤- n≤m) = +≤+ (s≤s n≤m) +neg-mono-≤ (+≤+ z≤n) = neg-≤-pos +neg-mono-≤ (+≤+ (s≤s m≤n)) = -≤- m≤n + +neg-cancel-≤ : - i ≤ - j → i ≥ j +neg-cancel-≤ { +[1+ m ]} { +[1+ n ]} (-≤- n≤m) = +≤+ (s≤s n≤m) +neg-cancel-≤ { +[1+ m ]} { +0} -≤+ = +≤+ z≤n +neg-cancel-≤ { +[1+ m ]} { -[1+ n ]} -≤+ = -≤+ +neg-cancel-≤ { +0} { +0} _ = +≤+ z≤n +neg-cancel-≤ { +0} { -[1+ n ]} _ = -≤+ +neg-cancel-≤ { -[1+ m ]} { +0} (+≤+ ()) +neg-cancel-≤ { -[1+ m ]} { -[1+ n ]} (+≤+ (s≤s m≤n)) = -≤- m≤n + +neg-mono-< : -_ Preserves _<_ ⟶ _>_ +neg-mono-< { -[1+ _ ]} { -[1+ _ ]} (-<- n<m) = +<+ (s<s n<m) +neg-mono-< { -[1+ _ ]} { +0} -<+ = +<+ z<s +neg-mono-< { -[1+ _ ]} { +[1+ n ]} -<+ = -<+ +neg-mono-< { +0} { +[1+ n ]} (+<+ _) = -<+ +neg-mono-< { +[1+ m ]} { +[1+ n ]} (+<+ m<n) = -<- (s<s⁻¹ m<n) + +neg-cancel-< : - i < - j → i > j +neg-cancel-< { +[1+ m ]} { +[1+ n ]} (-<- n<m) = +<+ (s<s n<m) +neg-cancel-< { +[1+ m ]} { +0} -<+ = +<+ z<s +neg-cancel-< { +[1+ m ]} { -[1+ n ]} -<+ = -<+ +neg-cancel-< { +0} { +0} (+<+ ()) +neg-cancel-< { +0} { -[1+ n ]} _ = -<+ +neg-cancel-< { -[1+ m ]} { +0} (+<+ ()) +neg-cancel-< { -[1+ m ]} { -[1+ n ]} (+<+ m<n) = -<- (s<s⁻¹ m<n) + +------------------------------------------------------------------------ +-- Properties of ∣_∣ +------------------------------------------------------------------------ + +∣i∣≡0⇒i≡0 : ∣ i ∣ ≡ 0 → i ≡ + 0 +∣i∣≡0⇒i≡0 {+0} refl = refl + +∣-i∣≡∣i∣ : ∀ i → ∣ - i ∣ ≡ ∣ i ∣ +∣-i∣≡∣i∣ -[1+ n ] = refl +∣-i∣≡∣i∣ +0 = refl +∣-i∣≡∣i∣ +[1+ n ] = refl + +0≤i⇒+∣i∣≡i : 0ℤ ≤ i → + ∣ i ∣ ≡ i +0≤i⇒+∣i∣≡i (+≤+ _) = refl + ++∣i∣≡i⇒0≤i : + ∣ i ∣ ≡ i → 0ℤ ≤ i ++∣i∣≡i⇒0≤i {+ n} _ = +≤+ z≤n + ++∣i∣≡i⊎+∣i∣≡-i : ∀ i → + ∣ i ∣ ≡ i ⊎ + ∣ i ∣ ≡ - i ++∣i∣≡i⊎+∣i∣≡-i (+ n) = inj₁ refl ++∣i∣≡i⊎+∣i∣≡-i (-[1+ n ]) = inj₂ refl + +∣m⊝n∣≤m⊔n : ∀ m n → ∣ m ⊖ n ∣ ℕ.≤ m ℕ.⊔ n +∣m⊝n∣≤m⊔n m n with m ℕ.<ᵇ n +... | true = begin + ∣ - + (n ℕ.∸ m) ∣ ≡⟨ ∣-i∣≡∣i∣ (+ (n ℕ.∸ m)) ⟩ + ∣ + (n ℕ.∸ m) ∣ ≡⟨⟩ + n ℕ.∸ m ≤⟨ ℕ.m∸n≤m n m ⟩ + n ≤⟨ ℕ.m≤n⊔m m n ⟩ + m ℕ.⊔ n ∎ + where open ℕ.≤-Reasoning +... | false = begin + ∣ + (m ℕ.∸ n) ∣ ≡⟨⟩ + m ℕ.∸ n ≤⟨ ℕ.m∸n≤m m n ⟩ + m ≤⟨ ℕ.m≤m⊔n m n ⟩ + m ℕ.⊔ n ∎ + where open ℕ.≤-Reasoning + +∣i+j∣≤∣i∣+∣j∣ : ∀ i j → ∣ i + j ∣ ℕ.≤ ∣ i ∣ ℕ.+ ∣ j ∣ +∣i+j∣≤∣i∣+∣j∣ +[1+ m ] (+ n) = ℕ.≤-refl +∣i+j∣≤∣i∣+∣j∣ +0 (+ n) = ℕ.≤-refl +∣i+j∣≤∣i∣+∣j∣ +0 -[1+ n ] = ℕ.≤-refl +∣i+j∣≤∣i∣+∣j∣ -[1+ m ] -[1+ n ] rewrite ℕ.+-suc (suc m) n = ℕ.≤-refl +∣i+j∣≤∣i∣+∣j∣ +[1+ m ] -[1+ n ] = begin + ∣ suc m ⊖ suc n ∣ ≤⟨ ∣m⊝n∣≤m⊔n (suc m) (suc n) ⟩ + suc m ℕ.⊔ suc n ≤⟨ ℕ.m⊔n≤m+n (suc m) (suc n) ⟩ + suc m ℕ.+ suc n ∎ + where open ℕ.≤-Reasoning +∣i+j∣≤∣i∣+∣j∣ -[1+ m ] (+ n) = begin + ∣ n ⊖ suc m ∣ ≤⟨ ∣m⊝n∣≤m⊔n n (suc m) ⟩ + n ℕ.⊔ suc m ≤⟨ ℕ.m⊔n≤m+n n (suc m) ⟩ + n ℕ.+ suc m ≡⟨ ℕ.+-comm n (suc m) ⟩ + suc m ℕ.+ n ∎ + where open ℕ.≤-Reasoning + +∣i-j∣≤∣i∣+∣j∣ : ∀ i j → ∣ i - j ∣ ℕ.≤ ∣ i ∣ ℕ.+ ∣ j ∣ +∣i-j∣≤∣i∣+∣j∣ i j = begin + ∣ i - j ∣ ≤⟨ ∣i+j∣≤∣i∣+∣j∣ i (- j) ⟩ + ∣ i ∣ ℕ.+ ∣ - j ∣ ≡⟨ cong (∣ i ∣ ℕ.+_) (∣-i∣≡∣i∣ j) ⟩ + ∣ i ∣ ℕ.+ ∣ j ∣ ∎ + where open ℕ.≤-Reasoning + +------------------------------------------------------------------------ +-- Properties of sign and _◃_ + +◃-inverse : ∀ i → sign i ◃ ∣ i ∣ ≡ i +◃-inverse -[1+ n ] = refl +◃-inverse +0 = refl +◃-inverse +[1+ n ] = refl + +◃-cong : sign i ≡ sign j → ∣ i ∣ ≡ ∣ j ∣ → i ≡ j +◃-cong {+ m} {+ n } ≡-sign refl = refl +◃-cong { -[1+ m ]} { -[1+ n ]} ≡-sign refl = refl + ++◃n≡+n : ∀ n → Sign.+ ◃ n ≡ + n ++◃n≡+n zero = refl ++◃n≡+n (suc _) = refl + +-◃n≡-n : ∀ n → Sign.- ◃ n ≡ - + n +-◃n≡-n zero = refl +-◃n≡-n (suc _) = refl + +sign-◃ : ∀ s n .{{_ : ℕ.NonZero n}} → sign (s ◃ n) ≡ s +sign-◃ Sign.- (suc _) = refl +sign-◃ Sign.+ (suc _) = refl + +abs-◃ : ∀ s n → ∣ s ◃ n ∣ ≡ n +abs-◃ _ zero = refl +abs-◃ Sign.- (suc n) = refl +abs-◃ Sign.+ (suc n) = refl + +signᵢ◃∣i∣≡i : ∀ i → sign i ◃ ∣ i ∣ ≡ i +signᵢ◃∣i∣≡i (+ n) = +◃n≡+n n +signᵢ◃∣i∣≡i -[1+ n ] = refl + +sign-cong : .{{_ : ℕ.NonZero m}} .{{_ : ℕ.NonZero n}} → + s ◃ m ≡ t ◃ n → s ≡ t +sign-cong {n@(suc _)} {m@(suc _)} {s} {t} eq = begin + s ≡⟨ sign-◃ s n ⟨ + sign (s ◃ n) ≡⟨ cong sign eq ⟩ + sign (t ◃ m) ≡⟨ sign-◃ t m ⟩ + t ∎ where open ≡-Reasoning + +sign-cong′ : s ◃ m ≡ t ◃ n → s ≡ t ⊎ (m ≡ 0 × n ≡ 0) +sign-cong′ {s} {zero} {t} {zero} eq = inj₂ (refl , refl) +sign-cong′ {s} {zero} {Sign.- } {suc n} () +sign-cong′ {s} {zero} {Sign.+ } {suc n} () +sign-cong′ {Sign.- } {suc m} {t} {zero} () +sign-cong′ {Sign.+ } {suc m} {t} {zero} () +sign-cong′ {s} {suc m} {t} {suc n} eq = inj₁ (sign-cong eq) + +abs-cong : s ◃ m ≡ t ◃ n → m ≡ n +abs-cong {s} {m} {t} {n} eq = begin + m ≡⟨ abs-◃ s m ⟨ + ∣ s ◃ m ∣ ≡⟨ cong ∣_∣ eq ⟩ + ∣ t ◃ n ∣ ≡⟨ abs-◃ t n ⟩ + n ∎ where open ≡-Reasoning + +∣s◃m∣*∣t◃n∣≡m*n : ∀ s t m n → ∣ s ◃ m ∣ ℕ.* ∣ t ◃ n ∣ ≡ m ℕ.* n +∣s◃m∣*∣t◃n∣≡m*n s t m n = cong₂ ℕ._*_ (abs-◃ s m) (abs-◃ t n) + ++◃-mono-< : m ℕ.< n → Sign.+ ◃ m < Sign.+ ◃ n ++◃-mono-< {zero} {suc n} m<n = +<+ m<n ++◃-mono-< {suc m} {suc n} m<n = +<+ m<n + ++◃-cancel-< : Sign.+ ◃ m < Sign.+ ◃ n → m ℕ.< n ++◃-cancel-< {zero} {zero} (+<+ ()) ++◃-cancel-< {suc m} {zero} (+<+ ()) ++◃-cancel-< {zero} {suc n} (+<+ m<n) = m<n ++◃-cancel-< {suc m} {suc n} (+<+ m<n) = m<n + +neg◃-cancel-< : Sign.- ◃ m < Sign.- ◃ n → n ℕ.< m +neg◃-cancel-< {zero} {zero} (+<+ ()) +neg◃-cancel-< {suc m} {zero} -<+ = z<s +neg◃-cancel-< {suc m} {suc n} (-<- n<m) = s<s n<m + +-◃<+◃ : ∀ m n .{{_ : ℕ.NonZero m}} → Sign.- ◃ m < Sign.+ ◃ n +-◃<+◃ (suc _) zero = -<+ +-◃<+◃ (suc _) (suc _) = -<+ + ++◃≮-◃ : Sign.+ ◃ m ≮ Sign.- ◃ n ++◃≮-◃ {zero} {zero} (+<+ ()) ++◃≮-◃ {suc m} {zero} (+<+ ()) + +------------------------------------------------------------------------ +-- Properties of _⊖_ +------------------------------------------------------------------------ + +n⊖n≡0 : ∀ n → n ⊖ n ≡ 0ℤ +n⊖n≡0 n with n ℕ.<ᵇ n in leq +... | true = cong (-_ ∘ +_) (ℕ.n∸n≡0 n) -- this is actually impossible! +... | false = cong +_ (ℕ.n∸n≡0 n) + +[1+m]⊖[1+n]≡m⊖n : ∀ m n → suc m ⊖ suc n ≡ m ⊖ n +[1+m]⊖[1+n]≡m⊖n m n with m ℕ.<ᵇ n +... | true = refl +... | false = refl + +⊖-swap : ∀ m n → m ⊖ n ≡ - (n ⊖ m) +⊖-swap zero zero = refl +⊖-swap zero (suc m) = refl +⊖-swap (suc m) zero = refl +⊖-swap (suc m) (suc n) = begin + suc m ⊖ suc n ≡⟨ [1+m]⊖[1+n]≡m⊖n m n ⟩ + m ⊖ n ≡⟨ ⊖-swap m n ⟩ + - (n ⊖ m) ≡⟨ cong -_ ([1+m]⊖[1+n]≡m⊖n n m) ⟨ + - (suc n ⊖ suc m) ∎ where open ≡-Reasoning + +⊖-≥ : m ℕ.≥ n → m ⊖ n ≡ + (m ∸ n) +⊖-≥ {m} {n} p with m ℕ.<ᵇ n | Reflects.invert (ℕ.<ᵇ-reflects-< m n) +... | true | q = contradiction (ℕ.≤-<-trans p q) (ℕ.<-irrefl refl) +... | false | q = refl + +≤-⊖ : m ℕ.≤ n → n ⊖ m ≡ + (n ∸ m) +≤-⊖ (z≤n {n}) = refl +≤-⊖ (s≤s {m} {n} p) = begin + suc n ⊖ suc m ≡⟨ [1+m]⊖[1+n]≡m⊖n n m ⟩ + n ⊖ m ≡⟨ ≤-⊖ p ⟩ + + (n ∸ m) ≡⟨⟩ + + (suc n ∸ suc m) ∎ where open ≡-Reasoning + +⊖-≤ : m ℕ.≤ n → m ⊖ n ≡ - + (n ∸ m) +⊖-≤ {m} {n} p with m ℕ.<ᵇ n | Reflects.invert (ℕ.<ᵇ-reflects-< m n) +... | true | q = refl +... | false | q rewrite ℕ.≤-antisym p (ℕ.≮⇒≥ q) | ℕ.n∸n≡0 n = refl + +⊖-< : m ℕ.< n → m ⊖ n ≡ - + (n ∸ m) +⊖-< = ⊖-≤ ∘ ℕ.<⇒≤ + +⊖-≰ : n ℕ.≰ m → m ⊖ n ≡ - + (n ∸ m) +⊖-≰ = ⊖-< ∘ ℕ.≰⇒> + +∣⊖∣-≤ : m ℕ.≤ n → ∣ m ⊖ n ∣ ≡ n ∸ m +∣⊖∣-≤ {m} {n} p = begin + ∣ m ⊖ n ∣ ≡⟨ cong ∣_∣ (⊖-≤ p) ⟩ + ∣ - (+ (n ∸ m)) ∣ ≡⟨ ∣-i∣≡∣i∣ (+ (n ∸ m)) ⟩ + ∣ + (n ∸ m) ∣ ≡⟨⟩ + n ∸ m ∎ where open ≡-Reasoning + +∣⊖∣-< : m ℕ.< n → ∣ m ⊖ n ∣ ≡ n ∸ m +∣⊖∣-< {m} {n} p = begin + ∣ m ⊖ n ∣ ≡⟨ cong ∣_∣ (⊖-< p) ⟩ + ∣ - (+ (n ∸ m)) ∣ ≡⟨ ∣-i∣≡∣i∣ (+ (n ∸ m)) ⟩ + ∣ + (n ∸ m) ∣ ≡⟨⟩ + n ∸ m ∎ where open ≡-Reasoning + +∣⊖∣-≰ : n ℕ.≰ m → ∣ m ⊖ n ∣ ≡ n ∸ m +∣⊖∣-≰ = ∣⊖∣-< ∘ ℕ.≰⇒> + +-m+n≡n⊖m : ∀ m n → - (+ m) + + n ≡ n ⊖ m +-m+n≡n⊖m zero n = refl +-m+n≡n⊖m (suc m) n = refl + +m-n≡m⊖n : ∀ m n → + m + (- + n) ≡ m ⊖ n +m-n≡m⊖n zero zero = refl +m-n≡m⊖n zero (suc n) = refl +m-n≡m⊖n (suc m) zero = cong +[1+_] (ℕ.+-identityʳ m) +m-n≡m⊖n (suc m) (suc n) = refl + +-[n⊖m]≡-m+n : ∀ m n → - (m ⊖ n) ≡ (- (+ m)) + (+ n) +-[n⊖m]≡-m+n m n with m ℕ.<ᵇ n | Reflects.invert (ℕ.<ᵇ-reflects-< m n) +... | true | p = begin + - (- (+ (n ∸ m))) ≡⟨ neg-involutive (+ (n ∸ m)) ⟩ + + (n ∸ m) ≡⟨ ⊖-≥ (ℕ.≤-trans (ℕ.m≤n+m m 1) p) ⟨ + n ⊖ m ≡⟨ -m+n≡n⊖m m n ⟨ + - (+ m) + + n ∎ where open ≡-Reasoning +... | false | p = begin + - (+ (m ∸ n)) ≡⟨ ⊖-≤ (ℕ.≮⇒≥ p) ⟨ + n ⊖ m ≡⟨ -m+n≡n⊖m m n ⟨ + - (+ m) + + n ∎ where open ≡-Reasoning + +∣m⊖n∣≡∣n⊖m∣ : ∀ m n → ∣ m ⊖ n ∣ ≡ ∣ n ⊖ m ∣ +∣m⊖n∣≡∣n⊖m∣ m n = begin + ∣ m ⊖ n ∣ ≡⟨ cong ∣_∣ (⊖-swap m n) ⟩ + ∣ - (n ⊖ m) ∣ ≡⟨ ∣-i∣≡∣i∣ (n ⊖ m) ⟩ + ∣ n ⊖ m ∣ ∎ where open ≡-Reasoning + ++-cancelˡ-⊖ : ∀ m n o → (m ℕ.+ n) ⊖ (m ℕ.+ o) ≡ n ⊖ o ++-cancelˡ-⊖ zero n o = refl ++-cancelˡ-⊖ (suc m) n o = begin + suc (m ℕ.+ n) ⊖ suc (m ℕ.+ o) ≡⟨ [1+m]⊖[1+n]≡m⊖n (m ℕ.+ n) (m ℕ.+ o) ⟩ + m ℕ.+ n ⊖ (m ℕ.+ o) ≡⟨ +-cancelˡ-⊖ m n o ⟩ + n ⊖ o ∎ where open ≡-Reasoning + +m⊖n≤m : ∀ m n → m ⊖ n ≤ + m +m⊖n≤m m zero = ≤-refl +m⊖n≤m zero (suc n) = -≤+ +m⊖n≤m (suc m) (suc n) = begin + suc m ⊖ suc n ≡⟨ [1+m]⊖[1+n]≡m⊖n m n ⟩ + m ⊖ n ≤⟨ m⊖n≤m m n ⟩ + + m ≤⟨ +≤+ (ℕ.n≤1+n m) ⟩ + +[1+ m ] ∎ where open ≤-Reasoning + +m⊖n<1+m : ∀ m n → m ⊖ n < +[1+ m ] +m⊖n<1+m m n = ≤-<-trans (m⊖n≤m m n) (+<+ (ℕ.m<n+m m z<s)) + +m⊖1+n<m : ∀ m n .{{_ : ℕ.NonZero n}} → m ⊖ n < + m +m⊖1+n<m zero (suc n) = -<+ +m⊖1+n<m (suc m) (suc n) = begin-strict + suc m ⊖ suc n ≡⟨ [1+m]⊖[1+n]≡m⊖n m n ⟩ + m ⊖ n <⟨ m⊖n<1+m m n ⟩ + +[1+ m ] ∎ where open ≤-Reasoning + +-1+m<n⊖m : ∀ m n → -[1+ m ] < n ⊖ m +-1+m<n⊖m zero n = -<+ +-1+m<n⊖m (suc m) zero = -<- ℕ.≤-refl +-1+m<n⊖m (suc m) (suc n) = begin-strict + -[1+ suc m ] <⟨ -<- ℕ.≤-refl ⟩ + -[1+ m ] <⟨ -1+m<n⊖m m n ⟩ + n ⊖ m ≡⟨ [1+m]⊖[1+n]≡m⊖n n m ⟨ + suc n ⊖ suc m ∎ where open ≤-Reasoning + +-[1+m]≤n⊖m+1 : ∀ m n → -[1+ m ] ≤ n ⊖ suc m +-[1+m]≤n⊖m+1 m zero = ≤-refl +-[1+m]≤n⊖m+1 m (suc n) = begin + -[1+ m ] ≤⟨ <⇒≤ (-1+m<n⊖m m n) ⟩ + n ⊖ m ≡⟨ [1+m]⊖[1+n]≡m⊖n n m ⟨ + suc n ⊖ suc m ∎ where open ≤-Reasoning + +-1+m≤n⊖m : ∀ m n → -[1+ m ] ≤ n ⊖ m +-1+m≤n⊖m m n = <⇒≤ (-1+m<n⊖m m n) + +0⊖m≤+ : ∀ m {n} → 0 ⊖ m ≤ + n +0⊖m≤+ zero = +≤+ z≤n +0⊖m≤+ (suc m) = -≤+ + +sign-⊖-< : m ℕ.< n → sign (m ⊖ n) ≡ Sign.- +sign-⊖-< {zero} (ℕ.z<s) = refl +sign-⊖-< {suc m} {suc n} (ℕ.s<s m<n) = begin + sign (suc m ⊖ suc n) ≡⟨ cong sign ([1+m]⊖[1+n]≡m⊖n m n) ⟩ + sign (m ⊖ n) ≡⟨ sign-⊖-< m<n ⟩ + Sign.- ∎ where open ≡-Reasoning + +sign-⊖-≰ : n ℕ.≰ m → sign (m ⊖ n) ≡ Sign.- +sign-⊖-≰ = sign-⊖-< ∘ ℕ.≰⇒> + +⊖-monoʳ-≥-≤ : ∀ n → (n ⊖_) Preserves ℕ._≥_ ⟶ _≤_ +⊖-monoʳ-≥-≤ zero {m} z≤n = 0⊖m≤+ m +⊖-monoʳ-≥-≤ zero {_} (s≤s m≤n) = -≤- m≤n +⊖-monoʳ-≥-≤ (suc n) {zero} z≤n = ≤-refl +⊖-monoʳ-≥-≤ (suc n) {suc m} z≤n = begin + suc n ⊖ suc m ≡⟨ [1+m]⊖[1+n]≡m⊖n n m ⟩ + n ⊖ m <⟨ m⊖n<1+m n m ⟩ + +[1+ n ] ∎ where open ≤-Reasoning +⊖-monoʳ-≥-≤ (suc n) {suc m} {suc o} (s≤s m≤o) = begin + suc n ⊖ suc m ≡⟨ [1+m]⊖[1+n]≡m⊖n n m ⟩ + n ⊖ m ≤⟨ ⊖-monoʳ-≥-≤ n m≤o ⟩ + n ⊖ o ≡⟨ [1+m]⊖[1+n]≡m⊖n n o ⟨ + suc n ⊖ suc o ∎ where open ≤-Reasoning + +⊖-monoˡ-≤ : ∀ n → (_⊖ n) Preserves ℕ._≤_ ⟶ _≤_ +⊖-monoˡ-≤ zero {_} {_} m≤o = +≤+ m≤o +⊖-monoˡ-≤ (suc n) {_} {0} z≤n = ≤-refl +⊖-monoˡ-≤ (suc n) {_} {suc o} z≤n = begin + zero ⊖ suc n ≤⟨ ⊖-monoʳ-≥-≤ 0 (ℕ.n≤1+n n) ⟩ + zero ⊖ n ≤⟨ ⊖-monoˡ-≤ n z≤n ⟩ + o ⊖ n ≡⟨ [1+m]⊖[1+n]≡m⊖n o n ⟨ + suc o ⊖ suc n ∎ where open ≤-Reasoning +⊖-monoˡ-≤ (suc n) {suc m} {suc o} (s≤s m≤o) = begin + suc m ⊖ suc n ≡⟨ [1+m]⊖[1+n]≡m⊖n m n ⟩ + m ⊖ n ≤⟨ ⊖-monoˡ-≤ n m≤o ⟩ + o ⊖ n ≡⟨ [1+m]⊖[1+n]≡m⊖n o n ⟨ + suc o ⊖ suc n ∎ where open ≤-Reasoning + +⊖-monoʳ->-< : ∀ p → (p ⊖_) Preserves ℕ._>_ ⟶ _<_ +⊖-monoʳ->-< zero {_} z<s = -<+ +⊖-monoʳ->-< zero {_} (s<s m<n@(s≤s _)) = -<- m<n +⊖-monoʳ->-< (suc p) {suc m} z<s = begin-strict + suc p ⊖ suc m ≡⟨ [1+m]⊖[1+n]≡m⊖n p m ⟩ + p ⊖ m <⟨ m⊖n<1+m p m ⟩ + +[1+ p ] ∎ where open ≤-Reasoning +⊖-monoʳ->-< (suc p) {suc m} {suc n} (s<s m<n@(s≤s _)) = begin-strict + suc p ⊖ suc m ≡⟨ [1+m]⊖[1+n]≡m⊖n p m ⟩ + p ⊖ m <⟨ ⊖-monoʳ->-< p m<n ⟩ + p ⊖ n ≡⟨ [1+m]⊖[1+n]≡m⊖n p n ⟨ + suc p ⊖ suc n ∎ where open ≤-Reasoning + +⊖-monoˡ-< : ∀ n → (_⊖ n) Preserves ℕ._<_ ⟶ _<_ +⊖-monoˡ-< zero m<o = +<+ m<o +⊖-monoˡ-< (suc n) {_} {suc o} z<s = begin-strict + -[1+ n ] <⟨ -1+m<n⊖m n _ ⟩ + o ⊖ n ≡⟨ [1+m]⊖[1+n]≡m⊖n o n ⟨ + suc o ⊖ suc n ∎ where open ≤-Reasoning +⊖-monoˡ-< (suc n) {suc m} {suc (suc o)} (s<s m<o@(s≤s _)) = begin-strict + suc m ⊖ suc n ≡⟨ [1+m]⊖[1+n]≡m⊖n m n ⟩ + m ⊖ n <⟨ ⊖-monoˡ-< n m<o ⟩ + suc o ⊖ n ≡⟨ [1+m]⊖[1+n]≡m⊖n (suc o) n ⟨ + suc (suc o) ⊖ suc n ∎ where open ≤-Reasoning + +------------------------------------------------------------------------ +-- Properties of _+_ +------------------------------------------------------------------------ + +------------------------------------------------------------------------ +-- Algebraic properties of _+_ + ++-comm : Commutative _+_ ++-comm -[1+ m ] -[1+ n ] = cong (-[1+_] ∘ suc) (ℕ.+-comm m n) ++-comm (+ m) (+ n) = cong +_ (ℕ.+-comm m n) ++-comm -[1+ _ ] (+ _) = refl ++-comm (+ _) -[1+ _ ] = refl + ++-identityˡ : LeftIdentity +0 _+_ ++-identityˡ -[1+ _ ] = refl ++-identityˡ (+ _) = refl + ++-identityʳ : RightIdentity +0 _+_ ++-identityʳ = comm∧idˡ⇒idʳ +-comm +-identityˡ + ++-identity : Identity +0 _+_ ++-identity = +-identityˡ , +-identityʳ + +distribˡ-⊖-+-pos : ∀ m n o → n ⊖ o + + m ≡ n ℕ.+ m ⊖ o +distribˡ-⊖-+-pos _ zero zero = refl +distribˡ-⊖-+-pos _ zero (suc _) = refl +distribˡ-⊖-+-pos _ (suc _) zero = refl +distribˡ-⊖-+-pos m (suc n) (suc o) = begin + suc n ⊖ suc o + + m ≡⟨ cong (_+ + m) ([1+m]⊖[1+n]≡m⊖n n o) ⟩ + n ⊖ o + + m ≡⟨ distribˡ-⊖-+-pos m n o ⟩ + n ℕ.+ m ⊖ o ≡⟨ [1+m]⊖[1+n]≡m⊖n (n ℕ.+ m) o ⟨ + suc (n ℕ.+ m) ⊖ suc o ∎ where open ≡-Reasoning + +distribˡ-⊖-+-neg : ∀ m n o → n ⊖ o + -[1+ m ] ≡ n ⊖ (suc o ℕ.+ m) +distribˡ-⊖-+-neg _ zero zero = refl +distribˡ-⊖-+-neg _ zero (suc _) = refl +distribˡ-⊖-+-neg _ (suc _) zero = refl +distribˡ-⊖-+-neg m (suc n) (suc o) = begin + suc n ⊖ suc o + -[1+ m ] ≡⟨ cong (_+ -[1+ m ]) ([1+m]⊖[1+n]≡m⊖n n o) ⟩ + n ⊖ o + -[1+ m ] ≡⟨ distribˡ-⊖-+-neg m n o ⟩ + n ⊖ (suc o ℕ.+ m) ≡⟨ [1+m]⊖[1+n]≡m⊖n n (suc o ℕ.+ m) ⟨ + suc n ⊖ (suc (suc o) ℕ.+ m) ∎ where open ≡-Reasoning + +distribʳ-⊖-+-pos : ∀ m n o → + m + (n ⊖ o) ≡ m ℕ.+ n ⊖ o +distribʳ-⊖-+-pos m n o = begin + + m + (n ⊖ o) ≡⟨ +-comm (+ m) (n ⊖ o) ⟩ + (n ⊖ o) + + m ≡⟨ distribˡ-⊖-+-pos m n o ⟩ + n ℕ.+ m ⊖ o ≡⟨ cong (_⊖ o) (ℕ.+-comm n m) ⟩ + m ℕ.+ n ⊖ o ∎ where open ≡-Reasoning + +distribʳ-⊖-+-neg : ∀ m n o → -[1+ m ] + (n ⊖ o) ≡ n ⊖ (suc m ℕ.+ o) +distribʳ-⊖-+-neg m n o = begin + -[1+ m ] + (n ⊖ o) ≡⟨ +-comm -[1+ m ] (n ⊖ o) ⟩ + (n ⊖ o) + -[1+ m ] ≡⟨ distribˡ-⊖-+-neg m n o ⟩ + n ⊖ suc (o ℕ.+ m) ≡⟨ cong (λ x → n ⊖ suc x) (ℕ.+-comm o m) ⟩ + n ⊖ suc (m ℕ.+ o) ∎ where open ≡-Reasoning + ++-assoc : Associative _+_ ++-assoc +0 j k rewrite +-identityˡ j | +-identityˡ (j + k) = refl ++-assoc i +0 k rewrite +-identityʳ i | +-identityˡ k = refl ++-assoc i j +0 rewrite +-identityʳ (i + j) | +-identityʳ j = refl ++-assoc -[1+ m ] -[1+ n ] +[1+ o ] = begin + suc o ⊖ suc (suc (m ℕ.+ n)) ≡⟨ [1+m]⊖[1+n]≡m⊖n o (suc m ℕ.+ n) ⟩ + o ⊖ (suc m ℕ.+ n) ≡⟨ distribʳ-⊖-+-neg m o n ⟨ + -[1+ m ] + (o ⊖ n) ≡⟨ cong (λ z → -[1+ m ] + z) ([1+m]⊖[1+n]≡m⊖n o n) ⟨ + -[1+ m ] + (suc o ⊖ suc n) ∎ where open ≡-Reasoning ++-assoc -[1+ m ] +[1+ n ] +[1+ o ] = begin + suc n ⊖ suc m + +[1+ o ] ≡⟨ cong (_+ +[1+ o ]) ([1+m]⊖[1+n]≡m⊖n n m) ⟩ + (n ⊖ m) + +[1+ o ] ≡⟨ distribˡ-⊖-+-pos (suc o) n m ⟩ + n ℕ.+ suc o ⊖ m ≡⟨ [1+m]⊖[1+n]≡m⊖n (n ℕ.+ suc o) m ⟨ + suc (n ℕ.+ suc o) ⊖ suc m ∎ where open ≡-Reasoning ++-assoc +[1+ m ] -[1+ n ] -[1+ o ] = begin + (suc m ⊖ suc n) + -[1+ o ] ≡⟨ cong (_+ -[1+ o ]) ([1+m]⊖[1+n]≡m⊖n m n) ⟩ + (m ⊖ n) + -[1+ o ] ≡⟨ distribˡ-⊖-+-neg o m n ⟩ + m ⊖ suc (n ℕ.+ o) ≡⟨ [1+m]⊖[1+n]≡m⊖n m (suc n ℕ.+ o) ⟨ + suc m ⊖ suc (suc (n ℕ.+ o)) ∎ where open ≡-Reasoning ++-assoc +[1+ m ] -[1+ n ] +[1+ o ] + rewrite [1+m]⊖[1+n]≡m⊖n m n + | [1+m]⊖[1+n]≡m⊖n o n + | distribˡ-⊖-+-pos (suc o) m n + | distribʳ-⊖-+-pos (suc m) o n + | sym (ℕ.+-assoc m 1 o) + | ℕ.+-comm m 1 + = refl ++-assoc +[1+ m ] +[1+ n ] -[1+ o ] + rewrite [1+m]⊖[1+n]≡m⊖n n o + | [1+m]⊖[1+n]≡m⊖n (m ℕ.+ suc n) o + | distribʳ-⊖-+-pos (suc m) n o + | sym (ℕ.+-assoc m 1 n) + | ℕ.+-comm m 1 + = refl ++-assoc -[1+ m ] -[1+ n ] -[1+ o ] + rewrite sym (ℕ.+-assoc m 1 (n ℕ.+ o)) + | ℕ.+-comm m 1 + | ℕ.+-assoc m n o + = refl ++-assoc -[1+ m ] +[1+ n ] -[1+ o ] + rewrite [1+m]⊖[1+n]≡m⊖n n m + | [1+m]⊖[1+n]≡m⊖n n o + | distribʳ-⊖-+-neg m n o + | distribˡ-⊖-+-neg o n m + = refl ++-assoc +[1+ m ] +[1+ n ] +[1+ o ] + rewrite ℕ.+-assoc (suc m) (suc n) (suc o) + = refl + ++-inverseˡ : LeftInverse +0 -_ _+_ ++-inverseˡ -[1+ n ] = n⊖n≡0 (suc n) ++-inverseˡ +0 = refl ++-inverseˡ +[1+ n ] = n⊖n≡0 (suc n) + ++-inverseʳ : RightInverse +0 -_ _+_ ++-inverseʳ = comm∧invˡ⇒invʳ +-comm +-inverseˡ + ++-inverse : Inverse +0 -_ _+_ ++-inverse = +-inverseˡ , +-inverseʳ + +------------------------------------------------------------------------ +-- Structures + ++-isMagma : IsMagma _+_ ++-isMagma = record + { isEquivalence = isEquivalence + ; ∙-cong = cong₂ _+_ + } + ++-isSemigroup : IsSemigroup _+_ ++-isSemigroup = record + { isMagma = +-isMagma + ; assoc = +-assoc + } + ++-isCommutativeSemigroup : IsCommutativeSemigroup _+_ ++-isCommutativeSemigroup = record + { isSemigroup = +-isSemigroup + ; comm = +-comm + } + ++-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 + } + +------------------------------------------------------------------------ +-- Bundles + ++-magma : Magma 0ℓ 0ℓ ++-magma = record + { isMagma = +-isMagma + } + ++-semigroup : Semigroup 0ℓ 0ℓ ++-semigroup = record + { isSemigroup = +-isSemigroup + } + ++-commutativeSemigroup : CommutativeSemigroup 0ℓ 0ℓ ++-commutativeSemigroup = record + { isCommutativeSemigroup = +-isCommutativeSemigroup + } + ++-0-monoid : Monoid 0ℓ 0ℓ ++-0-monoid = record + { isMonoid = +-0-isMonoid + } + ++-0-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ ++-0-commutativeMonoid = record + { isCommutativeMonoid = +-0-isCommutativeMonoid + } + ++-0-abelianGroup : AbelianGroup 0ℓ 0ℓ ++-0-abelianGroup = record + { isAbelianGroup = +-0-isAbelianGroup + } + +------------------------------------------------------------------------ +-- Properties of _+_ and +_/-_. + +pos-+ : ℕtoℤ.Homomorphic₂ +_ ℕ._+_ _+_ +pos-+ zero n = refl +pos-+ (suc m) n = cong sucℤ (pos-+ m n) + +neg-distrib-+ : ∀ i j → - (i + j) ≡ (- i) + (- j) +neg-distrib-+ +0 +0 = refl +neg-distrib-+ +0 +[1+ n ] = refl +neg-distrib-+ +[1+ m ] +0 = cong -[1+_] (ℕ.+-identityʳ m) +neg-distrib-+ +[1+ m ] +[1+ n ] = cong -[1+_] (ℕ.+-suc m n) +neg-distrib-+ -[1+ m ] -[1+ n ] = cong +[1+_] (sym (ℕ.+-suc m n)) +neg-distrib-+ (+ m) -[1+ n ] = -[n⊖m]≡-m+n m (suc n) +neg-distrib-+ -[1+ m ] (+ n) = + trans (-[n⊖m]≡-m+n n (suc m)) (+-comm (- + n) (+ suc m)) + +◃-distrib-+ : ∀ s m n → s ◃ (m ℕ.+ n) ≡ (s ◃ m) + (s ◃ n) +◃-distrib-+ Sign.- m n = begin + Sign.- ◃ (m ℕ.+ n) ≡⟨ -◃n≡-n (m ℕ.+ n) ⟩ + - (+ (m ℕ.+ n)) ≡⟨⟩ + - ((+ m) + (+ n)) ≡⟨ neg-distrib-+ (+ m) (+ n) ⟩ + (- (+ m)) + (- (+ n)) ≡⟨ sym (cong₂ _+_ (-◃n≡-n m) (-◃n≡-n n)) ⟩ + (Sign.- ◃ m) + (Sign.- ◃ n) ∎ where open ≡-Reasoning +◃-distrib-+ Sign.+ m n = begin + Sign.+ ◃ (m ℕ.+ n) ≡⟨ +◃n≡+n (m ℕ.+ n) ⟩ + + (m ℕ.+ n) ≡⟨⟩ + (+ m) + (+ n) ≡⟨ sym (cong₂ _+_ (+◃n≡+n m) (+◃n≡+n n)) ⟩ + (Sign.+ ◃ m) + (Sign.+ ◃ n) ∎ where open ≡-Reasoning + +------------------------------------------------------------------------ +-- Properties of _+_ and _≤_ + ++-monoʳ-≤ : ∀ n → (_+_ n) Preserves _≤_ ⟶ _≤_ ++-monoʳ-≤ (+ n) {_} (-≤- o≤m) = ⊖-monoʳ-≥-≤ n (s≤s o≤m) ++-monoʳ-≤ (+ n) { -[1+ m ]} -≤+ = ≤-trans (m⊖n≤m n (suc m)) (+≤+ (ℕ.m≤m+n n _)) ++-monoʳ-≤ (+ n) {_} (+≤+ m≤o) = +≤+ (ℕ.+-monoʳ-≤ n m≤o) ++-monoʳ-≤ -[1+ n ] {_} {_} (-≤- n≤m) = -≤- (ℕ.+-monoʳ-≤ (suc n) n≤m) ++-monoʳ-≤ -[1+ n ] {_} {+ m} -≤+ = ≤-trans (-≤- (ℕ.m≤m+n (suc n) _)) (-1+m≤n⊖m (suc n) m) ++-monoʳ-≤ -[1+ n ] {_} {_} (+≤+ m≤n) = ⊖-monoˡ-≤ (suc n) m≤n + ++-monoˡ-≤ : ∀ n → (_+ n) Preserves _≤_ ⟶ _≤_ ++-monoˡ-≤ n {i} {j} rewrite +-comm i n | +-comm j n = +-monoʳ-≤ n + ++-mono-≤ : _+_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ ++-mono-≤ {m} {n} {i} {j} m≤n i≤j = begin + m + i ≤⟨ +-monoˡ-≤ i m≤n ⟩ + n + i ≤⟨ +-monoʳ-≤ n i≤j ⟩ + n + j ∎ + where open ≤-Reasoning + +i≤j⇒i≤k+j : ∀ k .{{_ : NonNegative k}} → i ≤ j → i ≤ k + j +i≤j⇒i≤k+j (+ n) i≤j = subst (_≤ _) (+-identityˡ _) (+-mono-≤ (+≤+ z≤n) i≤j) + +i≤j+i : ∀ i j .{{_ : NonNegative j}} → i ≤ j + i +i≤j+i i j = i≤j⇒i≤k+j j ≤-refl + +i≤i+j : ∀ i j .{{_ : NonNegative j}} → i ≤ i + j +i≤i+j i j rewrite +-comm i j = i≤j+i i j + +------------------------------------------------------------------------ +-- Properties of _+_ and _<_ + ++-monoʳ-< : ∀ i → (_+_ i) Preserves _<_ ⟶ _<_ ++-monoʳ-< (+ n) {_} {_} (-<- o<m) = ⊖-monoʳ->-< n (s<s o<m) ++-monoʳ-< (+ n) {_} {_} -<+ = <-≤-trans (m⊖1+n<m n _) (+≤+ (ℕ.m≤m+n n _)) ++-monoʳ-< (+ n) {_} {_} (+<+ m<o) = +<+ (ℕ.+-monoʳ-< n m<o) ++-monoʳ-< -[1+ n ] {_} {_} (-<- o<m) = -<- (ℕ.+-monoʳ-< (suc n) o<m) ++-monoʳ-< -[1+ n ] {_} {+ o} -<+ = <-≤-trans (-<- (ℕ.m≤m+n (suc n) _)) (-[1+m]≤n⊖m+1 n o) ++-monoʳ-< -[1+ n ] {_} {_} (+<+ m<o) = ⊖-monoˡ-< (suc n) m<o + ++-monoˡ-< : ∀ i → (_+ i) Preserves _<_ ⟶ _<_ ++-monoˡ-< i {j} {k} rewrite +-comm j i | +-comm k i = +-monoʳ-< i + ++-mono-< : _+_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_ ++-mono-< {i} {j} {k} {l} i<j k<l = begin-strict + i + k <⟨ +-monoˡ-< k i<j ⟩ + j + k <⟨ +-monoʳ-< j k<l ⟩ + j + l ∎ + where open ≤-Reasoning + ++-mono-≤-< : _+_ Preserves₂ _≤_ ⟶ _<_ ⟶ _<_ ++-mono-≤-< {i} {j} {k} i≤j j<k = ≤-<-trans (+-monoˡ-≤ k i≤j) (+-monoʳ-< j j<k) + ++-mono-<-≤ : _+_ Preserves₂ _<_ ⟶ _≤_ ⟶ _<_ ++-mono-<-≤ {i} {j} {k} i<j j≤k = <-≤-trans (+-monoˡ-< k i<j) (+-monoʳ-≤ j j≤k) + +------------------------------------------------------------------------ +-- Properties of _-_ +------------------------------------------------------------------------ + +neg-minus-pos : ∀ m n → -[1+ m ] - (+ n) ≡ -[1+ (n ℕ.+ m) ] +neg-minus-pos m zero = refl +neg-minus-pos zero (suc n) = cong (-[1+_] ∘ suc) (sym (ℕ.+-identityʳ n)) +neg-minus-pos (suc m) (suc n) = cong (-[1+_] ∘ suc) (ℕ.+-comm (suc m) n) + ++-minus-telescope : ∀ i j k → (i - j) + (j - k) ≡ i - k ++-minus-telescope i j k = begin + (i - j) + (j - k) ≡⟨ +-assoc i (- j) (j - k) ⟩ + i + (- j + (j - k)) ≡⟨ cong (λ v → i + v) (+-assoc (- j) j _) ⟨ + i + ((- j + j) - k) ≡⟨ +-assoc i (- j + j) (- k) ⟨ + i + (- j + j) - k ≡⟨ cong (λ a → i + a - k) (+-inverseˡ j) ⟩ + i + 0ℤ - k ≡⟨ cong (_- k) (+-identityʳ i) ⟩ + i - k ∎ where open ≡-Reasoning + +[+m]-[+n]≡m⊖n : ∀ m n → (+ m) - (+ n) ≡ m ⊖ n +[+m]-[+n]≡m⊖n zero zero = refl +[+m]-[+n]≡m⊖n zero (suc n) = refl +[+m]-[+n]≡m⊖n (suc m) zero = cong +[1+_] (ℕ.+-identityʳ m) +[+m]-[+n]≡m⊖n (suc m) (suc n) = refl + +∣i-j∣≡∣j-i∣ : ∀ i j → ∣ i - j ∣ ≡ ∣ j - i ∣ +∣i-j∣≡∣j-i∣ -[1+ m ] -[1+ n ] = ∣m⊖n∣≡∣n⊖m∣ (suc n) (suc m) +∣i-j∣≡∣j-i∣ -[1+ m ] (+ n) = begin + ∣ -[1+ m ] - (+ n) ∣ ≡⟨ cong ∣_∣ (neg-minus-pos m n) ⟩ + suc (n ℕ.+ m) ≡⟨ ℕ.+-suc n m ⟨ + n ℕ.+ suc m ∎ where open ≡-Reasoning +∣i-j∣≡∣j-i∣ (+ m) -[1+ n ] = begin + m ℕ.+ suc n ≡⟨ ℕ.+-suc m n ⟩ + suc (m ℕ.+ n) ≡⟨ cong ∣_∣ (neg-minus-pos n m) ⟨ + ∣ -[1+ n ] + - + m ∣ ∎ where open ≡-Reasoning +∣i-j∣≡∣j-i∣ (+ m) (+ n) = begin + ∣ + m - + n ∣ ≡⟨ cong ∣_∣ ([+m]-[+n]≡m⊖n m n) ⟩ + ∣ m ⊖ n ∣ ≡⟨ ∣m⊖n∣≡∣n⊖m∣ m n ⟩ + ∣ n ⊖ m ∣ ≡⟨ cong ∣_∣ ([+m]-[+n]≡m⊖n n m) ⟨ + ∣ + n - + m ∣ ∎ where open ≡-Reasoning + +∣-∣-≤ : i ≤ j → + ∣ i - j ∣ ≡ j - i +∣-∣-≤ (-≤- {m} {n} n≤m) = begin + + ∣ -[1+ m ] + +[1+ n ] ∣ ≡⟨ cong (λ j → + ∣ j ∣) ([1+m]⊖[1+n]≡m⊖n n m) ⟩ + + ∣ n ⊖ m ∣ ≡⟨ cong +_ (∣⊖∣-≤ n≤m) ⟩ + + ( m ∸ n ) ≡⟨ sym (≤-⊖ n≤m) ⟩ + m ⊖ n ≡⟨ sym ([1+m]⊖[1+n]≡m⊖n m n) ⟩ + suc m ⊖ suc n ∎ where open ≡-Reasoning +∣-∣-≤ (-≤+ {m} {zero}) = refl +∣-∣-≤ (-≤+ {m} {suc n}) = begin + + ∣ -[1+ m ] - + suc n ∣ ≡⟨⟩ + + suc (suc m ℕ.+ n) ≡⟨ cong (λ n → + suc n) (ℕ.+-comm (suc m) n) ⟩ + + (suc n ℕ.+ suc m) ≡⟨⟩ + + suc n - -[1+ m ] ∎ where open ≡-Reasoning +∣-∣-≤ (+≤+ {m} {n} m≤n) = begin + + ∣ + m - + n ∣ ≡⟨ cong (λ j → + ∣ j ∣) (m-n≡m⊖n m n) ⟩ + + ∣ m ⊖ n ∣ ≡⟨ cong +_ ( ∣⊖∣-≤ m≤n ) ⟩ + + (n ∸ m) ≡⟨ sym (≤-⊖ m≤n) ⟩ + n ⊖ m ≡⟨ sym (m-n≡m⊖n n m) ⟩ + + n - + m ∎ where open ≡-Reasoning + +i≡j⇒i-j≡0 : i ≡ j → i - j ≡ 0ℤ +i≡j⇒i-j≡0 {i} refl = +-inverseʳ i + +i-j≡0⇒i≡j : ∀ i j → i - j ≡ 0ℤ → i ≡ j +i-j≡0⇒i≡j i j i-j≡0 = begin + i ≡⟨ +-identityʳ i ⟨ + i + 0ℤ ≡⟨ cong (_+_ i) (+-inverseˡ j) ⟨ + i + (- j + j) ≡⟨ +-assoc i (- j) j ⟨ + (i - j) + j ≡⟨ cong (_+ j) i-j≡0 ⟩ + 0ℤ + j ≡⟨ +-identityˡ j ⟩ + j ∎ where open ≡-Reasoning + +i≤j⇒i-k≤j : ∀ k .{{_ : NonNegative k}} → i ≤ j → i - k ≤ j +i≤j⇒i-k≤j {i} +0 i≤j rewrite +-identityʳ i = i≤j +i≤j⇒i-k≤j {+ m} +[1+ n ] i≤j = ≤-trans (m⊖n≤m m (suc n)) i≤j +i≤j⇒i-k≤j { -[1+ m ]} +[1+ n ] i≤j = ≤-trans (-≤- (ℕ.≤-trans (ℕ.m≤m+n m n) (ℕ.n≤1+n _))) i≤j + +i-j≤i : ∀ i j .{{_ : NonNegative j}} → i - j ≤ i +i-j≤i i j = i≤j⇒i-k≤j j ≤-refl + +i≤j⇒i-j≤0 : i ≤ j → i - j ≤ 0ℤ +i≤j⇒i-j≤0 {_} {j} -≤+ = i≤j⇒i-k≤j j -≤+ +i≤j⇒i-j≤0 { -[1+ m ]} { -[1+ n ]} (-≤- n≤m) = begin + suc n ⊖ suc m ≡⟨ [1+m]⊖[1+n]≡m⊖n n m ⟩ + n ⊖ m ≤⟨ ⊖-monoʳ-≥-≤ n n≤m ⟩ + n ⊖ n ≡⟨ n⊖n≡0 n ⟩ + 0ℤ ∎ where open ≤-Reasoning +i≤j⇒i-j≤0 {_} {+0} (+≤+ z≤n) = +≤+ z≤n +i≤j⇒i-j≤0 {_} {+[1+ n ]} (+≤+ z≤n) = -≤+ +i≤j⇒i-j≤0 {+[1+ m ]} {+[1+ n ]} (+≤+ (s≤s m≤n)) = begin + suc m ⊖ suc n ≡⟨ [1+m]⊖[1+n]≡m⊖n m n ⟩ + m ⊖ n ≤⟨ ⊖-monoʳ-≥-≤ m m≤n ⟩ + m ⊖ m ≡⟨ n⊖n≡0 m ⟩ + 0ℤ ∎ where open ≤-Reasoning + +i-j≤0⇒i≤j : i - j ≤ 0ℤ → i ≤ j +i-j≤0⇒i≤j {i} {j} i-j≤0 = begin + i ≡⟨ +-identityʳ i ⟨ + i + 0ℤ ≡⟨ cong (_+_ i) (+-inverseˡ j) ⟨ + i + (- j + j) ≡⟨ +-assoc i (- j) j ⟨ + (i - j) + j ≤⟨ +-monoˡ-≤ j i-j≤0 ⟩ + 0ℤ + j ≡⟨ +-identityˡ j ⟩ + j ∎ + where open ≤-Reasoning + +i≤j⇒0≤j-i : i ≤ j → 0ℤ ≤ j - i +i≤j⇒0≤j-i {i} {j} i≤j = begin + 0ℤ ≡⟨ +-inverseʳ i ⟨ + i - i ≤⟨ +-monoˡ-≤ (- i) i≤j ⟩ + j - i ∎ + where open ≤-Reasoning + +0≤i-j⇒j≤i : 0ℤ ≤ i - j → j ≤ i +0≤i-j⇒j≤i {i} {j} 0≤i-j = begin + j ≡⟨ +-identityˡ j ⟨ + 0ℤ + j ≤⟨ +-monoˡ-≤ j 0≤i-j ⟩ + i - j + j ≡⟨ +-assoc i (- j) j ⟩ + i + (- j + j) ≡⟨ cong (_+_ i) (+-inverseˡ j) ⟩ + i + 0ℤ ≡⟨ +-identityʳ i ⟩ + i ∎ + where open ≤-Reasoning + +------------------------------------------------------------------------ +-- Properties of suc +------------------------------------------------------------------------ + +i≤j⇒i≤1+j : i ≤ j → i ≤ sucℤ j +i≤j⇒i≤1+j = i≤j⇒i≤k+j (+ 1) + +i≤suc[i] : ∀ i → i ≤ sucℤ i +i≤suc[i] i = i≤j+i i (+ 1) + +suc-+ : ∀ m n → +[1+ m ] + n ≡ sucℤ (+ m + n) +suc-+ m (+ n) = refl +suc-+ m (-[1+ n ]) = sym (distribʳ-⊖-+-pos 1 m (suc n)) + +i≢suc[i] : i ≢ sucℤ i +i≢suc[i] {+ _} () +i≢suc[i] { -[1+ 0 ]} () +i≢suc[i] { -[1+ suc n ]} () + +1-[1+n]≡-n : ∀ n → sucℤ -[1+ n ] ≡ - (+ n) +1-[1+n]≡-n zero = refl +1-[1+n]≡-n (suc n) = refl + +suc-mono : sucℤ Preserves _≤_ ⟶ _≤_ +suc-mono (-≤+ {m} {n}) = begin + 1 ⊖ suc m ≡⟨ [1+m]⊖[1+n]≡m⊖n 0 m ⟩ + 0 ⊖ m ≤⟨ 0⊖m≤+ m ⟩ + sucℤ (+ n) ∎ where open ≤-Reasoning +suc-mono (-≤- n≤m) = ⊖-monoʳ-≥-≤ 1 (s≤s n≤m) +suc-mono (+≤+ m≤n) = +≤+ (s≤s m≤n) + +suc[i]≤j⇒i<j : sucℤ i ≤ j → i < j +suc[i]≤j⇒i<j {+ i} {+ _} (+≤+ i≤j) = +<+ i≤j +suc[i]≤j⇒i<j { -[1+ 0 ]} {+ j} p = -<+ +suc[i]≤j⇒i<j { -[1+ suc i ]} {+ j} -≤+ = -<+ +suc[i]≤j⇒i<j { -[1+ suc i ]} { -[1+ j ]} (-≤- j≤i) = -<- (s≤s j≤i) + +i<j⇒suc[i]≤j : i < j → sucℤ i ≤ j +i<j⇒suc[i]≤j {+ _} {+ _} (+<+ i<j) = +≤+ i<j +i<j⇒suc[i]≤j { -[1+ 0 ]} {+ _} -<+ = +≤+ z≤n +i<j⇒suc[i]≤j { -[1+ suc i ]} { -[1+ _ ]} (-<- j<i) = -≤- (s≤s⁻¹ j<i) +i<j⇒suc[i]≤j { -[1+ suc i ]} {+ _} -<+ = -≤+ + +------------------------------------------------------------------------ +-- Properties of pred +------------------------------------------------------------------------ + +suc-pred : ∀ i → sucℤ (pred i) ≡ i +suc-pred i = begin + sucℤ (pred i) ≡⟨ +-assoc 1ℤ -1ℤ i ⟨ + 0ℤ + i ≡⟨ +-identityˡ i ⟩ + i ∎ where open ≡-Reasoning + +pred-suc : ∀ i → pred (sucℤ i) ≡ i +pred-suc i = begin + pred (sucℤ i) ≡⟨ +-assoc -1ℤ 1ℤ i ⟨ + 0ℤ + i ≡⟨ +-identityˡ i ⟩ + i ∎ where open ≡-Reasoning + ++-pred : ∀ i j → i + pred j ≡ pred (i + j) ++-pred i j = begin + i + (-1ℤ + j) ≡⟨ +-assoc i -1ℤ j ⟨ + i + -1ℤ + j ≡⟨ cong (_+ j) (+-comm i -1ℤ) ⟩ + -1ℤ + i + j ≡⟨ +-assoc -1ℤ i j ⟩ + -1ℤ + (i + j) ∎ where open ≡-Reasoning + +pred-+ : ∀ i j → pred i + j ≡ pred (i + j) +pred-+ i j = begin + pred i + j ≡⟨ +-comm (pred i) j ⟩ + j + pred i ≡⟨ +-pred j i ⟩ + pred (j + i) ≡⟨ cong pred (+-comm j i) ⟩ + pred (i + j) ∎ where open ≡-Reasoning + +neg-suc : ∀ m → -[1+ m ] ≡ pred (- + m) +neg-suc zero = refl +neg-suc (suc m) = refl + +minus-suc : ∀ m n → m - +[1+ n ] ≡ pred (m - + n) +minus-suc m n = begin + m + - +[1+ n ] ≡⟨ cong (_+_ m) (neg-suc n) ⟩ + m + pred (- (+ n)) ≡⟨ +-pred m (- + n) ⟩ + pred (m - + n) ∎ where open ≡-Reasoning + +i≤pred[j]⇒i<j : i ≤ pred j → i < j +i≤pred[j]⇒i<j {_} { + n} leq = ≤-<-trans leq (m⊖1+n<m n 1) +i≤pred[j]⇒i<j {_} { -[1+ n ]} leq = ≤-<-trans leq (-<- ℕ.≤-refl) + +i<j⇒i≤pred[j] : i < j → i ≤ pred j +i<j⇒i≤pred[j] {_} { +0} -<+ = -≤- z≤n +i<j⇒i≤pred[j] {_} { +[1+ n ]} -<+ = -≤+ +i<j⇒i≤pred[j] {_} { +[1+ n ]} (+<+ m<n) = +≤+ (s≤s⁻¹ m<n) +i<j⇒i≤pred[j] {_} { -[1+ n ]} (-<- n<m) = -≤- n<m + +i≤j⇒pred[i]≤j : i ≤ j → pred i ≤ j +i≤j⇒pred[i]≤j -≤+ = -≤+ +i≤j⇒pred[i]≤j (-≤- n≤m) = -≤- (ℕ.m≤n⇒m≤1+n n≤m) +i≤j⇒pred[i]≤j (+≤+ z≤n) = -≤+ +i≤j⇒pred[i]≤j (+≤+ (s≤s m≤n)) = +≤+ (ℕ.m≤n⇒m≤1+n m≤n) + +pred-mono : pred Preserves _≤_ ⟶ _≤_ +pred-mono (-≤+ {n = 0}) = -≤- z≤n +pred-mono (-≤+ {n = suc n}) = -≤+ +pred-mono (-≤- n≤m) = -≤- (s≤s n≤m) +pred-mono (+≤+ m≤n) = ⊖-monoˡ-≤ 1 m≤n + +------------------------------------------------------------------------ +-- Properties of _*_ +------------------------------------------------------------------------ +-- Algebraic properties + +*-comm : Commutative _*_ +*-comm -[1+ m ] -[1+ n ] rewrite ℕ.*-comm (suc m) (suc n) = refl +*-comm -[1+ m ] (+ n) rewrite ℕ.*-comm (suc m) n = refl +*-comm (+ m) -[1+ n ] rewrite ℕ.*-comm m (suc n) = refl +*-comm (+ m) (+ n) rewrite ℕ.*-comm m n = refl + +*-identityˡ : LeftIdentity 1ℤ _*_ +*-identityˡ -[1+ n ] rewrite ℕ.+-identityʳ n = refl +*-identityˡ +0 = refl +*-identityˡ +[1+ n ] rewrite ℕ.+-identityʳ n = refl + +*-identityʳ : RightIdentity 1ℤ _*_ +*-identityʳ = comm∧idˡ⇒idʳ *-comm *-identityˡ + +*-identity : Identity 1ℤ _*_ +*-identity = *-identityˡ , *-identityʳ + +*-zeroˡ : LeftZero 0ℤ _*_ +*-zeroˡ _ = refl + +*-zeroʳ : RightZero 0ℤ _*_ +*-zeroʳ = comm∧zeˡ⇒zeʳ *-comm *-zeroˡ + +*-zero : Zero 0ℤ _*_ +*-zero = *-zeroˡ , *-zeroʳ + +private + lemma : ∀ m n o → o ℕ.+ (n ℕ.+ m ℕ.* suc n) ℕ.* suc o + ≡ o ℕ.+ n ℕ.* suc o ℕ.+ m ℕ.* suc (o ℕ.+ n ℕ.* suc o) + lemma = + solve 3 (λ m n o → o :+ (n :+ m :* (con 1 :+ n)) :* (con 1 :+ o) + := o :+ n :* (con 1 :+ o) :+ + m :* (con 1 :+ (o :+ n :* (con 1 :+ o)))) + refl + +*-assoc : Associative _*_ +*-assoc +0 _ _ = refl +*-assoc i +0 _ rewrite ℕ.*-zeroʳ ∣ i ∣ = refl +*-assoc i j +0 rewrite + ℕ.*-zeroʳ ∣ j ∣ + | ℕ.*-zeroʳ ∣ i ∣ + | ℕ.*-zeroʳ ∣ sign i 𝕊* sign j ◃ ∣ i ∣ ℕ.* ∣ j ∣ ∣ + = refl +*-assoc -[1+ m ] -[1+ n ] +[1+ o ] = cong (+_ ∘ suc) (lemma m n o) +*-assoc -[1+ m ] +[1+ n ] -[1+ o ] = cong (+_ ∘ suc) (lemma m n o) +*-assoc +[1+ m ] +[1+ n ] +[1+ o ] = cong (+_ ∘ suc) (lemma m n o) +*-assoc +[1+ m ] -[1+ n ] -[1+ o ] = cong (+_ ∘ suc) (lemma m n o) +*-assoc -[1+ m ] -[1+ n ] -[1+ o ] = cong -[1+_] (lemma m n o) +*-assoc -[1+ m ] +[1+ n ] +[1+ o ] = cong -[1+_] (lemma m n o) +*-assoc +[1+ m ] -[1+ n ] +[1+ o ] = cong -[1+_] (lemma m n o) +*-assoc +[1+ m ] +[1+ n ] -[1+ o ] = cong -[1+_] (lemma m n o) + +private + + -- lemma used to prove distributivity. + distrib-lemma : ∀ m n o → (o ⊖ n) * -[1+ m ] ≡ m ℕ.+ n ℕ.* suc m ⊖ (m ℕ.+ o ℕ.* suc m) + distrib-lemma m n o + rewrite +-cancelˡ-⊖ m (n ℕ.* suc m) (o ℕ.* suc m) + | ⊖-swap (n ℕ.* suc m) (o ℕ.* suc m) + with n ℕ.≤? o + ... | yes n≤o + rewrite ⊖-≥ n≤o + | ⊖-≥ (ℕ.*-mono-≤ n≤o (ℕ.≤-refl {x = suc m})) + | -◃n≡-n ((o ∸ n) ℕ.* suc m) + | ℕ.*-distribʳ-∸ (suc m) o n + = refl + ... | no n≰o + rewrite sign-⊖-≰ n≰o + | ∣⊖∣-≰ n≰o + | +◃n≡+n ((n ∸ o) ℕ.* suc m) + | ⊖-≰ (n≰o ∘ ℕ.*-cancelʳ-≤ n o (suc m)) + | neg-involutive (+ (n ℕ.* suc m ∸ o ℕ.* suc m)) + | ℕ.*-distribʳ-∸ (suc m) n o + = refl + +*-distribʳ-+ : _*_ DistributesOverʳ _+_ +*-distribʳ-+ +0 y z + rewrite ℕ.*-zeroʳ ∣ y ∣ + | ℕ.*-zeroʳ ∣ z ∣ + | ℕ.*-zeroʳ ∣ y + z ∣ + = refl +*-distribʳ-+ x +0 z + rewrite +-identityˡ z + | +-identityˡ (sign z 𝕊* sign x ◃ ∣ z ∣ ℕ.* ∣ x ∣) + = refl +*-distribʳ-+ x y +0 + rewrite +-identityʳ y + | +-identityʳ (sign y 𝕊* sign x ◃ ∣ y ∣ ℕ.* ∣ x ∣) + = refl +*-distribʳ-+ -[1+ m ] -[1+ n ] -[1+ o ] = cong (+_) $ + solve 3 (λ m n o → (con 2 :+ n :+ o) :* (con 1 :+ m) + := (con 1 :+ n) :* (con 1 :+ m) :+ + (con 1 :+ o) :* (con 1 :+ m)) + refl m n o +*-distribʳ-+ +[1+ m ] +[1+ n ] +[1+ o ] = cong (+_) $ + solve 3 (λ m n o → (con 1 :+ n :+ (con 1 :+ o)) :* (con 1 :+ m) + := (con 1 :+ n) :* (con 1 :+ m) :+ + (con 1 :+ o) :* (con 1 :+ m)) + refl m n o +*-distribʳ-+ -[1+ m ] +[1+ n ] +[1+ o ] = cong -[1+_] $ + solve 3 (λ m n o → m :+ (n :+ (con 1 :+ o)) :* (con 1 :+ m) + := (con 1 :+ n) :* (con 1 :+ m) :+ + (m :+ o :* (con 1 :+ m))) + refl m n o +*-distribʳ-+ +[1+ m ] -[1+ n ] -[1+ o ] = cong -[1+_] $ + solve 3 (λ m n o → m :+ (con 1 :+ m :+ (n :+ o) :* (con 1 :+ m)) + := (con 1 :+ n) :* (con 1 :+ m) :+ + (m :+ o :* (con 1 :+ m))) + refl m n o +*-distribʳ-+ -[1+ m ] -[1+ n ] +[1+ o ] = begin + (suc o ⊖ suc n) * -[1+ m ] ≡⟨ cong (_* -[1+ m ]) ([1+m]⊖[1+n]≡m⊖n o n) ⟩ + (o ⊖ n) * -[1+ m ] ≡⟨ distrib-lemma m n o ⟩ + m ℕ.+ n ℕ.* suc m ⊖ (m ℕ.+ o ℕ.* suc m) ≡⟨ [1+m]⊖[1+n]≡m⊖n (m ℕ.+ n ℕ.* suc m) (m ℕ.+ o ℕ.* suc m) ⟨ + -[1+ n ] * -[1+ m ] + +[1+ o ] * -[1+ m ] ∎ where open ≡-Reasoning +*-distribʳ-+ -[1+ m ] +[1+ n ] -[1+ o ] = begin + (+[1+ n ] + -[1+ o ]) * -[1+ m ] ≡⟨ cong (_* -[1+ m ]) ([1+m]⊖[1+n]≡m⊖n n o) ⟩ + (n ⊖ o) * -[1+ m ] ≡⟨ distrib-lemma m o n ⟩ + m ℕ.+ o ℕ.* suc m ⊖ (m ℕ.+ n ℕ.* suc m) ≡⟨ [1+m]⊖[1+n]≡m⊖n (m ℕ.+ o ℕ.* suc m) (m ℕ.+ n ℕ.* suc m) ⟨ + +[1+ n ] * -[1+ m ] + -[1+ o ] * -[1+ m ] ∎ where open ≡-Reasoning +*-distribʳ-+ +[1+ m ] -[1+ n ] +[1+ o ] with n ℕ.≤? o +... | yes n≤o + rewrite [1+m]⊖[1+n]≡m⊖n o n + | [1+m]⊖[1+n]≡m⊖n (m ℕ.+ o ℕ.* suc m) (m ℕ.+ n ℕ.* suc m) + | +-cancelˡ-⊖ m (o ℕ.* suc m) (n ℕ.* suc m) + | ⊖-≥ n≤o + | +-comm (- (+ (m ℕ.+ n ℕ.* suc m))) (+ (m ℕ.+ o ℕ.* suc m)) + | ⊖-≥ (ℕ.*-mono-≤ n≤o (ℕ.≤-refl {x = suc m})) + | ℕ.*-distribʳ-∸ (suc m) o n + | +◃n≡+n (o ℕ.* suc m ∸ n ℕ.* suc m) + = refl +... | no n≰o + rewrite [1+m]⊖[1+n]≡m⊖n o n + | [1+m]⊖[1+n]≡m⊖n (m ℕ.+ o ℕ.* suc m) (m ℕ.+ n ℕ.* suc m) + | +-cancelˡ-⊖ m (o ℕ.* suc m) (n ℕ.* suc m) + | sign-⊖-≰ n≰o + | ∣⊖∣-≰ n≰o + | -◃n≡-n ((n ∸ o) ℕ.* suc m) + | ⊖-≰ (n≰o ∘ ℕ.*-cancelʳ-≤ n o (suc m)) + | ℕ.*-distribʳ-∸ (suc m) n o + = refl +*-distribʳ-+ +[1+ o ] +[1+ m ] -[1+ n ] with n ℕ.≤? m +... | yes n≤m + rewrite [1+m]⊖[1+n]≡m⊖n m n + | [1+m]⊖[1+n]≡m⊖n (o ℕ.+ m ℕ.* suc o) (o ℕ.+ n ℕ.* suc o) + | +-cancelˡ-⊖ o (m ℕ.* suc o) (n ℕ.* suc o) + | ⊖-≥ n≤m + | ⊖-≥ (ℕ.*-mono-≤ n≤m (ℕ.≤-refl {x = suc o})) + | +◃n≡+n ((m ∸ n) ℕ.* suc o) + | ℕ.*-distribʳ-∸ (suc o) m n + = refl +... | no n≰m + rewrite [1+m]⊖[1+n]≡m⊖n m n + | [1+m]⊖[1+n]≡m⊖n (o ℕ.+ m ℕ.* suc o) (o ℕ.+ n ℕ.* suc o) + | +-cancelˡ-⊖ o (m ℕ.* suc o) (n ℕ.* suc o) + | sign-⊖-≰ n≰m + | ∣⊖∣-≰ n≰m + | ⊖-≰ (n≰m ∘ ℕ.*-cancelʳ-≤ n m (suc o)) + | -◃n≡-n ((n ∸ m) ℕ.* suc o) + | ℕ.*-distribʳ-∸ (suc o) n m + = refl + +*-distribˡ-+ : _*_ DistributesOverˡ _+_ +*-distribˡ-+ = comm∧distrʳ⇒distrˡ *-comm *-distribʳ-+ + +*-distrib-+ : _*_ DistributesOver _+_ +*-distrib-+ = *-distribˡ-+ , *-distribʳ-+ + +------------------------------------------------------------------------ +-- Structures + +*-isMagma : IsMagma _*_ +*-isMagma = record + { isEquivalence = isEquivalence + ; ∙-cong = cong₂ _*_ + } + +*-isSemigroup : IsSemigroup _*_ +*-isSemigroup = record + { isMagma = *-isMagma + ; assoc = *-assoc + } + +*-isCommutativeSemigroup : IsCommutativeSemigroup _*_ +*-isCommutativeSemigroup = record + { isSemigroup = *-isSemigroup + ; comm = *-comm + } + +*-1-isMonoid : IsMonoid _*_ 1ℤ +*-1-isMonoid = record + { isSemigroup = *-isSemigroup + ; identity = *-identity + } + +*-1-isCommutativeMonoid : IsCommutativeMonoid _*_ 1ℤ +*-1-isCommutativeMonoid = record + { isMonoid = *-1-isMonoid + ; comm = *-comm + } + ++-*-isSemiring : IsSemiring _+_ _*_ 0ℤ 1ℤ ++-*-isSemiring = record + { isSemiringWithoutAnnihilatingZero = record + { +-isCommutativeMonoid = +-0-isCommutativeMonoid + ; *-cong = cong₂ _*_ + ; *-assoc = *-assoc + ; *-identity = *-identity + ; distrib = *-distrib-+ + } + ; zero = *-zero + } + ++-*-isCommutativeSemiring : IsCommutativeSemiring _+_ _*_ 0ℤ 1ℤ ++-*-isCommutativeSemiring = record + { isSemiring = +-*-isSemiring + ; *-comm = *-comm + } + ++-*-isRing : IsRing _+_ _*_ -_ 0ℤ 1ℤ ++-*-isRing = record + { +-isAbelianGroup = +-0-isAbelianGroup + ; *-cong = cong₂ _*_ + ; *-assoc = *-assoc + ; *-identity = *-identity + ; distrib = *-distrib-+ + } + ++-*-isCommutativeRing : IsCommutativeRing _+_ _*_ -_ 0ℤ 1ℤ ++-*-isCommutativeRing = record + { isRing = +-*-isRing + ; *-comm = *-comm + } + +------------------------------------------------------------------------ +-- Bundles + +*-magma : Magma 0ℓ 0ℓ +*-magma = record + { isMagma = *-isMagma + } + +*-semigroup : Semigroup 0ℓ 0ℓ +*-semigroup = record + { isSemigroup = *-isSemigroup + } + +*-commutativeSemigroup : CommutativeSemigroup 0ℓ 0ℓ +*-commutativeSemigroup = record + { isCommutativeSemigroup = *-isCommutativeSemigroup + } + +*-1-monoid : Monoid 0ℓ 0ℓ +*-1-monoid = record + { isMonoid = *-1-isMonoid + } + +*-1-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ +*-1-commutativeMonoid = record + { isCommutativeMonoid = *-1-isCommutativeMonoid + } + ++-*-semiring : Semiring 0ℓ 0ℓ ++-*-semiring = record + { isSemiring = +-*-isSemiring + } + ++-*-commutativeSemiring : CommutativeSemiring 0ℓ 0ℓ ++-*-commutativeSemiring = record + { isCommutativeSemiring = +-*-isCommutativeSemiring + } + ++-*-ring : Ring 0ℓ 0ℓ ++-*-ring = record + { isRing = +-*-isRing + } + ++-*-commutativeRing : CommutativeRing 0ℓ 0ℓ ++-*-commutativeRing = record + { isCommutativeRing = +-*-isCommutativeRing + } + +------------------------------------------------------------------------ +-- Other properties of _*_ and _≡_ + +abs-* : ℤtoℕ.Homomorphic₂ ∣_∣ _*_ ℕ._*_ +abs-* i j = abs-◃ _ _ + +*-cancelʳ-≡ : ∀ i j k .{{_ : NonZero k}} → i * k ≡ j * k → i ≡ j +*-cancelʳ-≡ i j k eq with sign-cong′ eq +... | inj₁ s[ik]≡s[jk] = ◃-cong + (𝕊ₚ.*-cancelʳ-≡ (sign k) (sign i) (sign j) s[ik]≡s[jk]) + (ℕ.*-cancelʳ-≡ ∣ i ∣ ∣ j ∣ _ (abs-cong eq)) +... | inj₂ (∣ik∣≡0 , ∣jk∣≡0) = trans + (∣i∣≡0⇒i≡0 (ℕ.m*n≡0⇒m≡0 _ _ ∣ik∣≡0)) + (sym (∣i∣≡0⇒i≡0 (ℕ.m*n≡0⇒m≡0 _ _ ∣jk∣≡0))) + +*-cancelˡ-≡ : ∀ i j k .{{_ : NonZero i}} → i * j ≡ i * k → j ≡ k +*-cancelˡ-≡ i j k rewrite *-comm i j | *-comm i k = *-cancelʳ-≡ j k i + +suc-* : ∀ i j → sucℤ i * j ≡ j + i * j +suc-* i j = begin + sucℤ i * j ≡⟨ *-distribʳ-+ j (+ 1) i ⟩ + + 1 * j + i * j ≡⟨ cong (_+ i * j) (*-identityˡ j) ⟩ + j + i * j ∎ + where open ≡-Reasoning + +*-suc : ∀ i j → i * sucℤ j ≡ i + i * j +*-suc i j = begin + i * sucℤ j ≡⟨ *-comm i _ ⟩ + sucℤ j * i ≡⟨ suc-* j i ⟩ + i + j * i ≡⟨ cong (λ v → i + v) (*-comm j i) ⟩ + i + i * j ∎ + where open ≡-Reasoning + +-1*i≡-i : ∀ i → -1ℤ * i ≡ - i +-1*i≡-i -[1+ n ] = cong +[1+_] (ℕ.+-identityʳ n) +-1*i≡-i +0 = refl +-1*i≡-i +[1+ n ] = cong -[1+_] (ℕ.+-identityʳ n) + +i*j≡0⇒i≡0∨j≡0 : ∀ i {j} → i * j ≡ 0ℤ → i ≡ 0ℤ ⊎ j ≡ 0ℤ +i*j≡0⇒i≡0∨j≡0 i p with ℕ.m*n≡0⇒m≡0∨n≡0 ∣ i ∣ (abs-cong {t = Sign.+} p) +... | inj₁ ∣i∣≡0 = inj₁ (∣i∣≡0⇒i≡0 ∣i∣≡0) +... | inj₂ ∣j∣≡0 = inj₂ (∣i∣≡0⇒i≡0 ∣j∣≡0) + +------------------------------------------------------------------------ +-- Properties of _^_ +------------------------------------------------------------------------ + +^-identityʳ : ∀ i → i ^ 1 ≡ i +^-identityʳ = *-identityʳ + +^-zeroˡ : ∀ n → 1ℤ ^ n ≡ 1ℤ +^-zeroˡ zero = refl +^-zeroˡ (suc n) = begin + 1ℤ ^ suc n ≡⟨⟩ + 1ℤ * (1ℤ ^ n) ≡⟨ *-identityˡ (1ℤ ^ n) ⟩ + 1ℤ ^ n ≡⟨ ^-zeroˡ n ⟩ + 1ℤ ∎ + where open ≡-Reasoning + +^-distribˡ-+-* : ∀ i m n → i ^ (m ℕ.+ n) ≡ i ^ m * i ^ n +^-distribˡ-+-* i zero n = sym (*-identityˡ (i ^ n)) +^-distribˡ-+-* i (suc m) n = begin + i * (i ^ (m ℕ.+ n)) ≡⟨ cong (i *_) (^-distribˡ-+-* i m n) ⟩ + i * ((i ^ m) * (i ^ n)) ≡⟨ sym (*-assoc i _ _) ⟩ + (i * (i ^ m)) * (i ^ n) ∎ + where open ≡-Reasoning + +^-isMagmaHomomorphism : ∀ i → Morphism.IsMagmaHomomorphism ℕ.+-rawMagma *-rawMagma (i ^_) +^-isMagmaHomomorphism i = record + { isRelHomomorphism = record { cong = cong (i ^_) } + ; homo = ^-distribˡ-+-* i + } + +^-isMonoidHomomorphism : ∀ i → Morphism.IsMonoidHomomorphism ℕ.+-0-rawMonoid *-1-rawMonoid (i ^_) +^-isMonoidHomomorphism i = record + { isMagmaHomomorphism = ^-isMagmaHomomorphism i + ; ε-homo = refl + } + +^-*-assoc : ∀ i m n → (i ^ m) ^ n ≡ i ^ (m ℕ.* n) +^-*-assoc i m zero = cong (i ^_) (sym $ ℕ.*-zeroʳ m) +^-*-assoc i m (suc n) = begin + (i ^ m) * ((i ^ m) ^ n) ≡⟨ cong ((i ^ m) *_) (^-*-assoc i m n) ⟩ + (i ^ m) * (i ^ (m ℕ.* n)) ≡⟨ sym (^-distribˡ-+-* i m (m ℕ.* n)) ⟩ + i ^ (m ℕ.+ m ℕ.* n) ≡⟨ cong (i ^_) (sym (ℕ.*-suc m n)) ⟩ + i ^ (m ℕ.* suc n) ∎ + where open ≡-Reasoning + +i^n≡0⇒i≡0 : ∀ i n → i ^ n ≡ 0ℤ → i ≡ 0ℤ +i^n≡0⇒i≡0 i (suc n) eq = [ id , i^n≡0⇒i≡0 i n ]′ (i*j≡0⇒i≡0∨j≡0 i eq) + +------------------------------------------------------------------------ +-- Properties of _*_ and +_/-_ + +pos-* : ℕtoℤ.Homomorphic₂ +_ ℕ._*_ _*_ +pos-* zero n = refl +pos-* (suc m) zero = pos-* m zero +pos-* (suc m) (suc n) = refl + +neg-distribˡ-* : ∀ i j → - (i * j) ≡ (- i) * j +neg-distribˡ-* i j = begin + - (i * j) ≡⟨ -1*i≡-i (i * j) ⟨ + -1ℤ * (i * j) ≡⟨ *-assoc -1ℤ i j ⟨ + -1ℤ * i * j ≡⟨ cong (_* j) (-1*i≡-i i) ⟩ + - i * j ∎ where open ≡-Reasoning + +neg-distribʳ-* : ∀ i j → - (i * j) ≡ i * (- j) +neg-distribʳ-* i j = begin + - (i * j) ≡⟨ cong -_ (*-comm i j) ⟩ + - (j * i) ≡⟨ neg-distribˡ-* j i ⟩ + - j * i ≡⟨ *-comm (- j) i ⟩ + i * (- j) ∎ where open ≡-Reasoning ------------------------------------------------------------------------ --- Properties of _*_ and _≤_ - -*-cancelʳ-≤-pos : ∀ i j k .{{_ : Positive k}} → i * k ≤ j * k → i ≤ j -*-cancelʳ-≤-pos -[1+ m ] -[1+ n ] +[1+ o ] (-≤- n≤m) = - -≤- (ℕ.≤-pred (ℕ.*-cancelʳ-≤ (suc n) (suc m) (suc o) (s≤s n≤m))) -*-cancelʳ-≤-pos -[1+ _ ] (+ _) +[1+ o ] _ = -≤+ -*-cancelʳ-≤-pos +0 +0 +[1+ o ] _ = +≤+ z≤n -*-cancelʳ-≤-pos +0 +[1+ _ ] +[1+ o ] _ = +≤+ z≤n -*-cancelʳ-≤-pos +[1+ _ ] +0 +[1+ o ] (+≤+ ()) -*-cancelʳ-≤-pos +[1+ m ] +[1+ n ] +[1+ o ] (+≤+ m≤n) = - +≤+ (ℕ.*-cancelʳ-≤ (suc m) (suc n) (suc o) m≤n) - -*-cancelˡ-≤-pos : ∀ i j k .{{_ : Positive k}} → k * i ≤ k * j → i ≤ j -*-cancelˡ-≤-pos i j k rewrite *-comm k i | *-comm k j = *-cancelʳ-≤-pos i j k - -*-monoʳ-≤-nonNeg : ∀ i .{{_ : NonNegative i}} → (_* i) Preserves _≤_ ⟶ _≤_ -*-monoʳ-≤-nonNeg +0 {i} {j} i≤j rewrite *-zeroʳ i | *-zeroʳ j = +≤+ z≤n -*-monoʳ-≤-nonNeg +[1+ n ] (-≤+ {n = 0}) = -≤+ -*-monoʳ-≤-nonNeg +[1+ n ] (-≤+ {n = suc _}) = -≤+ -*-monoʳ-≤-nonNeg +[1+ n ] (-≤- n≤m) = -≤- (ℕ.≤-pred (ℕ.*-mono-≤ (s≤s n≤m) (ℕ.≤-refl {x = suc n}))) -*-monoʳ-≤-nonNeg +[1+ n ] {+0} {+0} (+≤+ m≤n) = +≤+ m≤n -*-monoʳ-≤-nonNeg +[1+ n ] {+0} {+[1+ _ ]} (+≤+ m≤n) = +≤+ z≤n -*-monoʳ-≤-nonNeg +[1+ n ] {+[1+ _ ]} {+[1+ _ ]} (+≤+ m≤n) = +≤+ (ℕ.*-monoˡ-≤ (suc n) m≤n) - -*-monoˡ-≤-nonNeg : ∀ i .{{_ : NonNegative i}} → (i *_) Preserves _≤_ ⟶ _≤_ -*-monoˡ-≤-nonNeg i {j} {k} rewrite *-comm i j | *-comm i k = *-monoʳ-≤-nonNeg i - -*-cancelˡ-≤-neg : ∀ i j k .{{_ : Negative i}} → i * j ≤ i * k → j ≥ k -*-cancelˡ-≤-neg i@(-[1+ _ ]) j k ij≤ik = neg-cancel-≤ (*-cancelˡ-≤-pos (- j) (- k) (- i) (begin - - i * - j ≡˘⟨ neg-distribʳ-* (- i) j ⟩ - -(- i * j) ≡⟨ neg-distribˡ-* (- i) j ⟩ - i * j ≤⟨ ij≤ik ⟩ - i * k ≡˘⟨ neg-distribˡ-* (- i) k ⟩ - -(- i * k) ≡⟨ neg-distribʳ-* (- i) k ⟩ - - i * - k ∎)) - where open ≤-Reasoning - -*-cancelʳ-≤-neg : ∀ i j k .{{_ : Negative k}} → i * k ≤ j * k → i ≥ j -*-cancelʳ-≤-neg i j k rewrite *-comm i k | *-comm j k = *-cancelˡ-≤-neg k i j - -*-monoˡ-≤-nonPos : ∀ i .{{_ : NonPositive i}} → (i *_) Preserves _≤_ ⟶ _≥_ -*-monoˡ-≤-nonPos +0 {j} {k} j≤k = +≤+ z≤n -*-monoˡ-≤-nonPos i@(-[1+ m ]) {j} {k} j≤k = begin - i * k ≡˘⟨ neg-distribˡ-* (- i) k ⟩ - -(- i * k) ≡⟨ neg-distribʳ-* (- i) k ⟩ - - i * - k ≤⟨ *-monoˡ-≤-nonNeg (- i) (neg-mono-≤ j≤k) ⟩ - - i * - j ≡˘⟨ neg-distribʳ-* (- i) j ⟩ - -(- i * j) ≡⟨ neg-distribˡ-* (- i) j ⟩ - i * j ∎ - where open ≤-Reasoning - -*-monoʳ-≤-nonPos : ∀ i .{{_ : NonPositive i}} → (_* i) Preserves _≤_ ⟶ _≥_ -*-monoʳ-≤-nonPos i {j} {k} rewrite *-comm k i | *-comm j i = *-monoˡ-≤-nonPos i - ------------------------------------------------------------------------- --- Properties of _*_ and _<_ - -*-monoˡ-<-pos : ∀ i .{{_ : Positive i}} → (i *_) Preserves _<_ ⟶ _<_ -*-monoˡ-<-pos +[1+ n ] {+ m} {+ o} (+<+ m<o) = +◃-mono-< (ℕ.+-mono-<-≤ m<o (ℕ.*-monoʳ-≤ n (ℕ.<⇒≤ m<o))) -*-monoˡ-<-pos +[1+ n ] { -[1+ m ]} {+ o} leq = -◃<+◃ _ (suc n ℕ.* o) -*-monoˡ-<-pos +[1+ n ] { -[1+ m ]} { -[1+ o ]} (-<- o<m) = -<- (ℕ.+-mono-<-≤ o<m (ℕ.*-monoʳ-≤ n (ℕ.<⇒≤ (s≤s o<m)))) - -*-monoʳ-<-pos : ∀ i .{{_ : Positive i}} → (_* i) Preserves _<_ ⟶ _<_ -*-monoʳ-<-pos i {j} {k} rewrite *-comm j i | *-comm k i = *-monoˡ-<-pos i - -*-cancelˡ-<-nonNeg : ∀ k .{{_ : NonNegative k}} → k * i < k * j → i < j -*-cancelˡ-<-nonNeg {+ i} {+ j} (+ n) leq = +<+ (ℕ.*-cancelˡ-< n _ _ (+◃-cancel-< leq)) -*-cancelˡ-<-nonNeg {+ i} { -[1+ j ]} (+ n) leq = contradiction leq +◃≮-◃ -*-cancelˡ-<-nonNeg { -[1+ i ]} {+ j} (+ n)leq = -<+ -*-cancelˡ-<-nonNeg { -[1+ i ]} { -[1+ j ]} (+ n) leq = -<- (ℕ.≤-pred (ℕ.*-cancelˡ-< n _ _ (neg◃-cancel-< leq))) - -*-cancelʳ-<-nonNeg : ∀ k .{{_ : NonNegative k}} → i * k < j * k → i < j -*-cancelʳ-<-nonNeg {i} {j} k rewrite *-comm i k | *-comm j k = *-cancelˡ-<-nonNeg k - -*-monoˡ-<-neg : ∀ i .{{_ : Negative i}} → (i *_) Preserves _<_ ⟶ _>_ -*-monoˡ-<-neg i@(-[1+ _ ]) {j} {k} j<k = begin-strict - i * k ≡˘⟨ neg-distribˡ-* (- i) k ⟩ - -(- i * k) ≡⟨ neg-distribʳ-* (- i) k ⟩ - - i * - k <⟨ *-monoˡ-<-pos (- i) (neg-mono-< j<k) ⟩ - - i * - j ≡˘⟨ neg-distribʳ-* (- i) j ⟩ - - (- i * j) ≡⟨ neg-distribˡ-* (- i) j ⟩ - i * j ∎ - where open ≤-Reasoning - -*-monoʳ-<-neg : ∀ i .{{_ : Negative i}} → (_* i) Preserves _<_ ⟶ _>_ -*-monoʳ-<-neg i {j} {k} rewrite *-comm k i | *-comm j i = *-monoˡ-<-neg i - -*-cancelˡ-<-nonPos : ∀ k .{{_ : NonPositive k}} → k * i < k * j → i > j -*-cancelˡ-<-nonPos {i} {j} +0 (+<+ ()) -*-cancelˡ-<-nonPos {i} {j} k@(-[1+ _ ]) ki<kj = neg-cancel-< (*-cancelˡ-<-nonNeg (- k) (begin-strict - - k * - i ≡˘⟨ neg-distribʳ-* (- k) i ⟩ - -(- k * i) ≡⟨ neg-distribˡ-* (- k) i ⟩ - k * i <⟨ ki<kj ⟩ - k * j ≡˘⟨ neg-distribˡ-* (- k) j ⟩ - -(- k * j) ≡⟨ neg-distribʳ-* (- k) j ⟩ - - k * - j ∎)) - where open ≤-Reasoning - -*-cancelʳ-<-nonPos : ∀ k .{{_ : NonPositive k}} → i * k < j * k → i > j -*-cancelʳ-<-nonPos {i} {j} k rewrite *-comm i k | *-comm j k = *-cancelˡ-<-nonPos k - -*-cancelˡ-<-neg : ∀ n → -[1+ n ] * i < -[1+ n ] * j → i > j -*-cancelˡ-<-neg {i} {j} n = *-cancelˡ-<-nonPos -[1+ n ] - -*-cancelʳ-<-neg : ∀ n → i * -[1+ n ] < j * -[1+ n ] → i > j -*-cancelʳ-<-neg {i} {j} n = *-cancelʳ-<-nonPos -[1+ n ] - ------------------------------------------------------------------------- --- Properties of _*_ and ∣_∣ - -∣i*j∣≡∣i∣*∣j∣ : ∀ i j → ∣ i * j ∣ ≡ ∣ i ∣ ℕ.* ∣ j ∣ -∣i*j∣≡∣i∣*∣j∣ i j = abs-◃ (sign i 𝕊* sign j) (∣ i ∣ ℕ.* ∣ j ∣) - ------------------------------------------------------------------------- --- Properties of _⊓_ and _⊔_ ------------------------------------------------------------------------- --- Basic specification in terms of _≤_ - -i≤j⇒i⊓j≡i : i ≤ j → i ⊓ j ≡ i -i≤j⇒i⊓j≡i (-≤- i≥j) = cong -[1+_] (ℕ.m≥n⇒m⊔n≡m i≥j) -i≤j⇒i⊓j≡i -≤+ = refl -i≤j⇒i⊓j≡i (+≤+ i≤j) = cong +_ (ℕ.m≤n⇒m⊓n≡m i≤j) - -i≥j⇒i⊓j≡j : i ≥ j → i ⊓ j ≡ j -i≥j⇒i⊓j≡j (-≤- i≥j) = cong -[1+_] (ℕ.m≤n⇒m⊔n≡n i≥j) -i≥j⇒i⊓j≡j -≤+ = refl -i≥j⇒i⊓j≡j (+≤+ i≤j) = cong +_ (ℕ.m≥n⇒m⊓n≡n i≤j) - -i≤j⇒i⊔j≡j : i ≤ j → i ⊔ j ≡ j -i≤j⇒i⊔j≡j (-≤- i≥j) = cong -[1+_] (ℕ.m≥n⇒m⊓n≡n i≥j) -i≤j⇒i⊔j≡j -≤+ = refl -i≤j⇒i⊔j≡j (+≤+ i≤j) = cong +_ (ℕ.m≤n⇒m⊔n≡n i≤j) - -i≥j⇒i⊔j≡i : i ≥ j → i ⊔ j ≡ i -i≥j⇒i⊔j≡i (-≤- i≥j) = cong -[1+_] (ℕ.m≤n⇒m⊓n≡m i≥j) -i≥j⇒i⊔j≡i -≤+ = refl -i≥j⇒i⊔j≡i (+≤+ i≤j) = cong +_ (ℕ.m≥n⇒m⊔n≡m i≤j) - -⊓-operator : MinOperator ≤-totalPreorder -⊓-operator = record - { x≤y⇒x⊓y≈x = i≤j⇒i⊓j≡i - ; x≥y⇒x⊓y≈y = i≥j⇒i⊓j≡j - } - -⊔-operator : MaxOperator ≤-totalPreorder -⊔-operator = record - { x≤y⇒x⊔y≈y = i≤j⇒i⊔j≡j - ; x≥y⇒x⊔y≈x = i≥j⇒i⊔j≡i - } - ------------------------------------------------------------------------- --- Automatically derived properties of _⊓_ and _⊔_ - -private - module ⊓-⊔-properties = MinMaxOp ⊓-operator ⊔-operator - module ⊓-⊔-latticeProperties = LatticeMinMaxOp ⊓-operator ⊔-operator - -open ⊓-⊔-properties public - using - ( ⊓-idem -- : Idempotent _⊓_ - ; ⊓-sel -- : Selective _⊓_ - ; ⊓-assoc -- : Associative _⊓_ - ; ⊓-comm -- : Commutative _⊓_ - - ; ⊔-idem -- : Idempotent _⊔_ - ; ⊔-sel -- : Selective _⊔_ - ; ⊔-assoc -- : Associative _⊔_ - ; ⊔-comm -- : Commutative _⊔_ - - ; ⊓-distribˡ-⊔ -- : _⊓_ DistributesOverˡ _⊔_ - ; ⊓-distribʳ-⊔ -- : _⊓_ DistributesOverʳ _⊔_ - ; ⊓-distrib-⊔ -- : _⊓_ DistributesOver _⊔_ - ; ⊔-distribˡ-⊓ -- : _⊔_ DistributesOverˡ _⊓_ - ; ⊔-distribʳ-⊓ -- : _⊔_ DistributesOverʳ _⊓_ - ; ⊔-distrib-⊓ -- : _⊔_ DistributesOver _⊓_ - ; ⊓-absorbs-⊔ -- : _⊓_ Absorbs _⊔_ - ; ⊔-absorbs-⊓ -- : _⊔_ Absorbs _⊓_ - ; ⊔-⊓-absorptive -- : Absorptive _⊔_ _⊓_ - ; ⊓-⊔-absorptive -- : Absorptive _⊓_ _⊔_ - - ; ⊓-isMagma -- : IsMagma _⊓_ - ; ⊓-isSemigroup -- : IsSemigroup _⊓_ - ; ⊓-isCommutativeSemigroup -- : IsCommutativeSemigroup _⊓_ - ; ⊓-isBand -- : IsBand _⊓_ - ; ⊓-isSelectiveMagma -- : IsSelectiveMagma _⊓_ - - ; ⊔-isMagma -- : IsMagma _⊔_ - ; ⊔-isSemigroup -- : IsSemigroup _⊔_ - ; ⊔-isCommutativeSemigroup -- : IsCommutativeSemigroup _⊔_ - ; ⊔-isBand -- : IsBand _⊔_ - ; ⊔-isSelectiveMagma -- : IsSelectiveMagma _⊔_ - - ; ⊓-magma -- : Magma _ _ - ; ⊓-semigroup -- : Semigroup _ _ - ; ⊓-band -- : Band _ _ - ; ⊓-commutativeSemigroup -- : CommutativeSemigroup _ _ - ; ⊓-selectiveMagma -- : SelectiveMagma _ _ - - ; ⊔-magma -- : Magma _ _ - ; ⊔-semigroup -- : Semigroup _ _ - ; ⊔-band -- : Band _ _ - ; ⊔-commutativeSemigroup -- : CommutativeSemigroup _ _ - ; ⊔-selectiveMagma -- : SelectiveMagma _ _ - - ; ⊓-glb -- : ∀ {m n o} → m ≥ o → n ≥ o → m ⊓ n ≥ o - ; ⊓-triangulate -- : ∀ m n o → m ⊓ n ⊓ o ≡ (m ⊓ n) ⊓ (n ⊓ o) - ; ⊓-mono-≤ -- : _⊓_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ - ; ⊓-monoˡ-≤ -- : ∀ n → (_⊓ n) Preserves _≤_ ⟶ _≤_ - ; ⊓-monoʳ-≤ -- : ∀ n → (n ⊓_) Preserves _≤_ ⟶ _≤_ - - ; ⊔-lub -- : ∀ {m n o} → m ≤ o → n ≤ o → m ⊔ n ≤ o - ; ⊔-triangulate -- : ∀ m n o → m ⊔ n ⊔ o ≡ (m ⊔ n) ⊔ (n ⊔ o) - ; ⊔-mono-≤ -- : _⊔_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ - ; ⊔-monoˡ-≤ -- : ∀ n → (_⊔ n) Preserves _≤_ ⟶ _≤_ - ; ⊔-monoʳ-≤ -- : ∀ n → (n ⊔_) Preserves _≤_ ⟶ _≤_ - ) - renaming - ( x⊓y≈y⇒y≤x to i⊓j≡j⇒j≤i -- : ∀ {i j} → i ⊓ j ≡ j → j ≤ i - ; x⊓y≈x⇒x≤y to i⊓j≡i⇒i≤j -- : ∀ {i j} → i ⊓ j ≡ i → i ≤ j - ; x⊓y≤x to i⊓j≤i -- : ∀ i j → i ⊓ j ≤ i - ; x⊓y≤y to i⊓j≤j -- : ∀ i j → i ⊓ j ≤ j - ; x≤y⇒x⊓z≤y to i≤j⇒i⊓k≤j -- : ∀ {i j} k → i ≤ j → i ⊓ k ≤ j - ; x≤y⇒z⊓x≤y to i≤j⇒k⊓i≤j -- : ∀ {i j} k → i ≤ j → k ⊓ i ≤ j - ; x≤y⊓z⇒x≤y to i≤j⊓k⇒i≤j -- : ∀ {i} j k → i ≤ j ⊓ k → i ≤ j - ; x≤y⊓z⇒x≤z to i≤j⊓k⇒i≤k -- : ∀ {i} j k → i ≤ j ⊓ k → i ≤ k - - ; x⊔y≈y⇒x≤y to i⊔j≡j⇒i≤j -- : ∀ {i j} → i ⊔ j ≡ j → i ≤ j - ; x⊔y≈x⇒y≤x to i⊔j≡i⇒j≤i -- : ∀ {i j} → i ⊔ j ≡ i → j ≤ i - ; x≤x⊔y to i≤i⊔j -- : ∀ i j → i ≤ i ⊔ j - ; x≤y⊔x to i≤j⊔i -- : ∀ i j → i ≤ j ⊔ i - ; x≤y⇒x≤y⊔z to i≤j⇒i≤j⊔k -- : ∀ {i j} k → i ≤ j → i ≤ j ⊔ k - ; x≤y⇒x≤z⊔y to i≤j⇒i≤k⊔j -- : ∀ {i j} k → i ≤ j → i ≤ k ⊔ j - ; x⊔y≤z⇒x≤z to i⊔j≤k⇒i≤k -- : ∀ i j {k} → i ⊔ j ≤ k → i ≤ k - ; x⊔y≤z⇒y≤z to i⊔j≤k⇒j≤k -- : ∀ i j {k} → i ⊔ j ≤ k → j ≤ k - - ; x⊓y≤x⊔y to i⊓j≤i⊔j -- : ∀ i j → i ⊓ j ≤ i ⊔ j - ) - -open ⊓-⊔-latticeProperties public - using - ( ⊓-isSemilattice -- : IsSemilattice _⊓_ - ; ⊔-isSemilattice -- : IsSemilattice _⊔_ - ; ⊔-⊓-isLattice -- : IsLattice _⊔_ _⊓_ - ; ⊓-⊔-isLattice -- : IsLattice _⊓_ _⊔_ - ; ⊔-⊓-isDistributiveLattice -- : IsDistributiveLattice _⊔_ _⊓_ - ; ⊓-⊔-isDistributiveLattice -- : IsDistributiveLattice _⊓_ _⊔_ - - ; ⊓-semilattice -- : Semilattice _ _ - ; ⊔-semilattice -- : Semilattice _ _ - ; ⊔-⊓-lattice -- : Lattice _ _ - ; ⊓-⊔-lattice -- : Lattice _ _ - ; ⊔-⊓-distributiveLattice -- : DistributiveLattice _ _ - ; ⊓-⊔-distributiveLattice -- : DistributiveLattice _ _ - ) - ------------------------------------------------------------------------- --- Other properties of _⊓_ and _⊔_ - -mono-≤-distrib-⊔ : ∀ {f} → f Preserves _≤_ ⟶ _≤_ → - ∀ i j → f (i ⊔ j) ≡ f i ⊔ f j -mono-≤-distrib-⊔ {f} = ⊓-⊔-properties.mono-≤-distrib-⊔ (cong f) - -mono-≤-distrib-⊓ : ∀ {f} → f Preserves _≤_ ⟶ _≤_ → - ∀ i j → f (i ⊓ j) ≡ f i ⊓ f j -mono-≤-distrib-⊓ {f} = ⊓-⊔-properties.mono-≤-distrib-⊓ (cong f) - -antimono-≤-distrib-⊓ : ∀ {f} → f Preserves _≤_ ⟶ _≥_ → - ∀ i j → f (i ⊓ j) ≡ f i ⊔ f j -antimono-≤-distrib-⊓ {f} = ⊓-⊔-properties.antimono-≤-distrib-⊓ (cong f) - -antimono-≤-distrib-⊔ : ∀ {f} → f Preserves _≤_ ⟶ _≥_ → - ∀ i j → f (i ⊔ j) ≡ f i ⊓ f j -antimono-≤-distrib-⊔ {f} = ⊓-⊔-properties.antimono-≤-distrib-⊔ (cong f) - -mono-<-distrib-⊓ : ∀ f → f Preserves _<_ ⟶ _<_ → ∀ i j → f (i ⊓ j) ≡ f i ⊓ f j -mono-<-distrib-⊓ f f-mono-< i j with <-cmp i j -... | tri< i<j _ _ = trans (cong f (i≤j⇒i⊓j≡i (<⇒≤ i<j))) (sym (i≤j⇒i⊓j≡i (<⇒≤ (f-mono-< i<j)))) -... | tri≈ _ refl _ = trans (cong f (i≤j⇒i⊓j≡i ≤-refl)) (sym (i≤j⇒i⊓j≡i ≤-refl)) -... | tri> _ _ i>j = trans (cong f (i≥j⇒i⊓j≡j (<⇒≤ i>j))) (sym (i≥j⇒i⊓j≡j (<⇒≤ (f-mono-< i>j)))) - -mono-<-distrib-⊔ : ∀ f → f Preserves _<_ ⟶ _<_ → ∀ i j → f (i ⊔ j) ≡ f i ⊔ f j -mono-<-distrib-⊔ f f-mono-< i j with <-cmp i j -... | tri< i<j _ _ = trans (cong f (i≤j⇒i⊔j≡j (<⇒≤ i<j))) (sym (i≤j⇒i⊔j≡j (<⇒≤ (f-mono-< i<j)))) -... | tri≈ _ refl _ = trans (cong f (i≤j⇒i⊔j≡j ≤-refl)) (sym (i≤j⇒i⊔j≡j ≤-refl)) -... | tri> _ _ i>j = trans (cong f (i≥j⇒i⊔j≡i (<⇒≤ i>j))) (sym (i≥j⇒i⊔j≡i (<⇒≤ (f-mono-< i>j)))) - -antimono-<-distrib-⊔ : ∀ f → f Preserves _<_ ⟶ _>_ → ∀ i j → f (i ⊔ j) ≡ f i ⊓ f j -antimono-<-distrib-⊔ f f-mono-< i j with <-cmp i j -... | tri< i<j _ _ = trans (cong f (i≤j⇒i⊔j≡j (<⇒≤ i<j))) (sym (i≥j⇒i⊓j≡j (<⇒≤ (f-mono-< i<j)))) -... | tri≈ _ refl _ = trans (cong f (i≤j⇒i⊔j≡j ≤-refl)) (sym (i≥j⇒i⊓j≡j ≤-refl)) -... | tri> _ _ i>j = trans (cong f (i≥j⇒i⊔j≡i (<⇒≤ i>j))) (sym (i≤j⇒i⊓j≡i (<⇒≤ (f-mono-< i>j)))) - -antimono-<-distrib-⊓ : ∀ f → f Preserves _<_ ⟶ _>_ → ∀ i j → f (i ⊓ j) ≡ f i ⊔ f j -antimono-<-distrib-⊓ f f-mono-< i j with <-cmp i j -... | tri< i<j _ _ = trans (cong f (i≤j⇒i⊓j≡i (<⇒≤ i<j))) (sym (i≥j⇒i⊔j≡i (<⇒≤ (f-mono-< i<j)))) -... | tri≈ _ refl _ = trans (cong f (i≤j⇒i⊓j≡i ≤-refl)) (sym (i≥j⇒i⊔j≡i ≤-refl)) -... | tri> _ _ i>j = trans (cong f (i≥j⇒i⊓j≡j (<⇒≤ i>j))) (sym (i≤j⇒i⊔j≡j (<⇒≤ (f-mono-< i>j)))) - ------------------------------------------------------------------------- --- Other properties of _⊓_, _⊔_ and -_ - -neg-distrib-⊔-⊓ : ∀ i j → - (i ⊔ j) ≡ - i ⊓ - j -neg-distrib-⊔-⊓ = antimono-<-distrib-⊔ -_ neg-mono-< - -neg-distrib-⊓-⊔ : ∀ i j → - (i ⊓ j) ≡ - i ⊔ - j -neg-distrib-⊓-⊔ = antimono-<-distrib-⊓ -_ neg-mono-< - ------------------------------------------------------------------------- --- Other properties of _⊓_, _⊔_ and _*_ - -*-distribˡ-⊓-nonNeg : ∀ i j k .{{_ : NonNegative i}} → - i * (j ⊓ k) ≡ (i * j) ⊓ (i * k) -*-distribˡ-⊓-nonNeg i j k = mono-≤-distrib-⊓ (*-monoˡ-≤-nonNeg i) j k - -*-distribʳ-⊓-nonNeg : ∀ i j k .{{_ : NonNegative i}} → - (j ⊓ k) * i ≡ (j * i) ⊓ (k * i) -*-distribʳ-⊓-nonNeg i j k = mono-≤-distrib-⊓ (*-monoʳ-≤-nonNeg i) j k - -*-distribˡ-⊓-nonPos : ∀ i j k .{{_ : NonPositive i}} → - i * (j ⊓ k) ≡ (i * j) ⊔ (i * k) -*-distribˡ-⊓-nonPos i j k = antimono-≤-distrib-⊓ (*-monoˡ-≤-nonPos i) j k - -*-distribʳ-⊓-nonPos : ∀ i j k .{{_ : NonPositive i}} → - (j ⊓ k) * i ≡ (j * i) ⊔ (k * i) -*-distribʳ-⊓-nonPos i j k = antimono-≤-distrib-⊓ (*-monoʳ-≤-nonPos i) j k - -*-distribˡ-⊔-nonNeg : ∀ i j k .{{_ : NonNegative i}} → - i * (j ⊔ k) ≡ (i * j) ⊔ (i * k) -*-distribˡ-⊔-nonNeg i j k = mono-≤-distrib-⊔ (*-monoˡ-≤-nonNeg i) j k - -*-distribʳ-⊔-nonNeg : ∀ i j k .{{_ : NonNegative i}} → - (j ⊔ k) * i ≡ (j * i) ⊔ (k * i) -*-distribʳ-⊔-nonNeg i j k = mono-≤-distrib-⊔ (*-monoʳ-≤-nonNeg i) j k - -*-distribˡ-⊔-nonPos : ∀ i j k .{{_ : NonPositive i}} → - i * (j ⊔ k) ≡ (i * j) ⊓ (i * k) -*-distribˡ-⊔-nonPos i j k = antimono-≤-distrib-⊔ (*-monoˡ-≤-nonPos i) j k - -*-distribʳ-⊔-nonPos : ∀ i j k .{{_ : NonPositive i}} → - (j ⊔ k) * i ≡ (j * i) ⊓ (k * i) -*-distribʳ-⊔-nonPos i j k = antimono-≤-distrib-⊔ (*-monoʳ-≤-nonPos i) j k - - ------------------------------------------------------------------------- --- DEPRECATED NAMES ------------------------------------------------------------------------- --- Please use the new names as continuing support for the old names is --- not guaranteed. - --- Version 1.5 - -neg-mono-<-> = neg-mono-< -{-# WARNING_ON_USAGE neg-mono-<-> -"Warning: neg-mono-<-> was deprecated in v1.5. +-- Properties of _*_ and _◃_ + +◃-distrib-* : ∀ s t m n → (s 𝕊* t) ◃ (m ℕ.* n) ≡ (s ◃ m) * (t ◃ n) +◃-distrib-* s t zero zero = refl +◃-distrib-* s t zero (suc n) = refl +◃-distrib-* s t (suc m) zero = + trans + (cong₂ _◃_ (𝕊ₚ.*-comm s t) (ℕ.*-comm m 0)) + (*-comm (t ◃ zero) (s ◃ suc m)) +◃-distrib-* s t (suc m) (suc n) = + sym (cong₂ _◃_ + (cong₂ _𝕊*_ (sign-◃ s (suc m)) (sign-◃ t (suc n))) + (∣s◃m∣*∣t◃n∣≡m*n s t (suc m) (suc n))) + +------------------------------------------------------------------------ +-- Properties of _*_ and _≤_ + +*-cancelʳ-≤-pos : ∀ i j k .{{_ : Positive k}} → i * k ≤ j * k → i ≤ j +*-cancelʳ-≤-pos -[1+ m ] -[1+ n ] +[1+ o ] (-≤- n≤m) = + -≤- (s≤s⁻¹ (ℕ.*-cancelʳ-≤ (suc n) (suc m) (suc o) (s≤s n≤m))) +*-cancelʳ-≤-pos -[1+ _ ] (+ _) +[1+ o ] _ = -≤+ +*-cancelʳ-≤-pos +0 +0 +[1+ o ] _ = +≤+ z≤n +*-cancelʳ-≤-pos +0 +[1+ _ ] +[1+ o ] _ = +≤+ z≤n +*-cancelʳ-≤-pos +[1+ _ ] +0 +[1+ o ] (+≤+ ()) +*-cancelʳ-≤-pos +[1+ m ] +[1+ n ] +[1+ o ] (+≤+ m≤n) = + +≤+ (ℕ.*-cancelʳ-≤ (suc m) (suc n) (suc o) m≤n) + +*-cancelˡ-≤-pos : ∀ i j k .{{_ : Positive k}} → k * i ≤ k * j → i ≤ j +*-cancelˡ-≤-pos i j k rewrite *-comm k i | *-comm k j = *-cancelʳ-≤-pos i j k + +*-monoʳ-≤-nonNeg : ∀ i .{{_ : NonNegative i}} → (_* i) Preserves _≤_ ⟶ _≤_ +*-monoʳ-≤-nonNeg +0 {i} {j} i≤j rewrite *-zeroʳ i | *-zeroʳ j = +≤+ z≤n +*-monoʳ-≤-nonNeg +[1+ n ] (-≤+ {n = 0}) = -≤+ +*-monoʳ-≤-nonNeg +[1+ n ] (-≤+ {n = suc _}) = -≤+ +*-monoʳ-≤-nonNeg +[1+ n ] (-≤- n≤m) = -≤- (s≤s⁻¹ (ℕ.*-mono-≤ (s≤s n≤m) (ℕ.≤-refl {x = suc n}))) +*-monoʳ-≤-nonNeg +[1+ n ] {+0} {+0} (+≤+ m≤n) = +≤+ m≤n +*-monoʳ-≤-nonNeg +[1+ n ] {+0} {+[1+ _ ]} (+≤+ m≤n) = +≤+ z≤n +*-monoʳ-≤-nonNeg +[1+ n ] {+[1+ _ ]} {+[1+ _ ]} (+≤+ m≤n) = +≤+ (ℕ.*-monoˡ-≤ (suc n) m≤n) + +*-monoˡ-≤-nonNeg : ∀ i .{{_ : NonNegative i}} → (i *_) Preserves _≤_ ⟶ _≤_ +*-monoˡ-≤-nonNeg i {j} {k} rewrite *-comm i j | *-comm i k = *-monoʳ-≤-nonNeg i + +*-cancelˡ-≤-neg : ∀ i j k .{{_ : Negative i}} → i * j ≤ i * k → j ≥ k +*-cancelˡ-≤-neg i@(-[1+ _ ]) j k ij≤ik = neg-cancel-≤ (*-cancelˡ-≤-pos (- j) (- k) (- i) (begin + - i * - j ≡⟨ neg-distribʳ-* (- i) j ⟨ + -(- i * j) ≡⟨ neg-distribˡ-* (- i) j ⟩ + i * j ≤⟨ ij≤ik ⟩ + i * k ≡⟨ neg-distribˡ-* (- i) k ⟨ + -(- i * k) ≡⟨ neg-distribʳ-* (- i) k ⟩ + - i * - k ∎)) + where open ≤-Reasoning + +*-cancelʳ-≤-neg : ∀ i j k .{{_ : Negative k}} → i * k ≤ j * k → i ≥ j +*-cancelʳ-≤-neg i j k rewrite *-comm i k | *-comm j k = *-cancelˡ-≤-neg k i j + +*-monoˡ-≤-nonPos : ∀ i .{{_ : NonPositive i}} → (i *_) Preserves _≤_ ⟶ _≥_ +*-monoˡ-≤-nonPos +0 {j} {k} j≤k = +≤+ z≤n +*-monoˡ-≤-nonPos i@(-[1+ m ]) {j} {k} j≤k = begin + i * k ≡⟨ neg-distribˡ-* (- i) k ⟨ + -(- i * k) ≡⟨ neg-distribʳ-* (- i) k ⟩ + - i * - k ≤⟨ *-monoˡ-≤-nonNeg (- i) (neg-mono-≤ j≤k) ⟩ + - i * - j ≡⟨ neg-distribʳ-* (- i) j ⟨ + -(- i * j) ≡⟨ neg-distribˡ-* (- i) j ⟩ + i * j ∎ + where open ≤-Reasoning + +*-monoʳ-≤-nonPos : ∀ i .{{_ : NonPositive i}} → (_* i) Preserves _≤_ ⟶ _≥_ +*-monoʳ-≤-nonPos i {j} {k} rewrite *-comm k i | *-comm j i = *-monoˡ-≤-nonPos i + +------------------------------------------------------------------------ +-- Properties of _*_ and _<_ + +*-monoˡ-<-pos : ∀ i .{{_ : Positive i}} → (i *_) Preserves _<_ ⟶ _<_ +*-monoˡ-<-pos +[1+ n ] {+ m} {+ o} (+<+ m<o) = +◃-mono-< (ℕ.+-mono-<-≤ m<o (ℕ.*-monoʳ-≤ n (ℕ.<⇒≤ m<o))) +*-monoˡ-<-pos +[1+ n ] { -[1+ m ]} {+ o} leq = -◃<+◃ _ (suc n ℕ.* o) +*-monoˡ-<-pos +[1+ n ] { -[1+ m ]} { -[1+ o ]} (-<- o<m) = -<- (ℕ.+-mono-<-≤ o<m (ℕ.*-monoʳ-≤ n (ℕ.<⇒≤ (s≤s o<m)))) + +*-monoʳ-<-pos : ∀ i .{{_ : Positive i}} → (_* i) Preserves _<_ ⟶ _<_ +*-monoʳ-<-pos i {j} {k} rewrite *-comm j i | *-comm k i = *-monoˡ-<-pos i + +*-cancelˡ-<-nonNeg : ∀ k .{{_ : NonNegative k}} → k * i < k * j → i < j +*-cancelˡ-<-nonNeg {+ i} {+ j} (+ n) leq = +<+ (ℕ.*-cancelˡ-< n _ _ (+◃-cancel-< leq)) +*-cancelˡ-<-nonNeg {+ i} { -[1+ j ]} (+ n) leq = contradiction leq +◃≮-◃ +*-cancelˡ-<-nonNeg { -[1+ i ]} {+ j} (+ n)leq = -<+ +*-cancelˡ-<-nonNeg { -[1+ i ]} { -[1+ j ]} (+ n) leq = -<- (s<s⁻¹ (ℕ.*-cancelˡ-< n _ _ (neg◃-cancel-< leq))) + +*-cancelʳ-<-nonNeg : ∀ k .{{_ : NonNegative k}} → i * k < j * k → i < j +*-cancelʳ-<-nonNeg {i} {j} k rewrite *-comm i k | *-comm j k = *-cancelˡ-<-nonNeg k + +*-monoˡ-<-neg : ∀ i .{{_ : Negative i}} → (i *_) Preserves _<_ ⟶ _>_ +*-monoˡ-<-neg i@(-[1+ _ ]) {j} {k} j<k = begin-strict + i * k ≡⟨ neg-distribˡ-* (- i) k ⟨ + -(- i * k) ≡⟨ neg-distribʳ-* (- i) k ⟩ + - i * - k <⟨ *-monoˡ-<-pos (- i) (neg-mono-< j<k) ⟩ + - i * - j ≡⟨ neg-distribʳ-* (- i) j ⟨ + - (- i * j) ≡⟨ neg-distribˡ-* (- i) j ⟩ + i * j ∎ + where open ≤-Reasoning + +*-monoʳ-<-neg : ∀ i .{{_ : Negative i}} → (_* i) Preserves _<_ ⟶ _>_ +*-monoʳ-<-neg i {j} {k} rewrite *-comm k i | *-comm j i = *-monoˡ-<-neg i + +*-cancelˡ-<-nonPos : ∀ k .{{_ : NonPositive k}} → k * i < k * j → i > j +*-cancelˡ-<-nonPos {i} {j} +0 (+<+ ()) +*-cancelˡ-<-nonPos {i} {j} k@(-[1+ _ ]) ki<kj = neg-cancel-< (*-cancelˡ-<-nonNeg (- k) (begin-strict + - k * - i ≡⟨ neg-distribʳ-* (- k) i ⟨ + -(- k * i) ≡⟨ neg-distribˡ-* (- k) i ⟩ + k * i <⟨ ki<kj ⟩ + k * j ≡⟨ neg-distribˡ-* (- k) j ⟨ + -(- k * j) ≡⟨ neg-distribʳ-* (- k) j ⟩ + - k * - j ∎)) + where open ≤-Reasoning + +*-cancelʳ-<-nonPos : ∀ k .{{_ : NonPositive k}} → i * k < j * k → i > j +*-cancelʳ-<-nonPos {i} {j} k rewrite *-comm i k | *-comm j k = *-cancelˡ-<-nonPos k + +*-cancelˡ-<-neg : ∀ n → -[1+ n ] * i < -[1+ n ] * j → i > j +*-cancelˡ-<-neg {i} {j} n = *-cancelˡ-<-nonPos -[1+ n ] + +*-cancelʳ-<-neg : ∀ n → i * -[1+ n ] < j * -[1+ n ] → i > j +*-cancelʳ-<-neg {i} {j} n = *-cancelʳ-<-nonPos -[1+ n ] + +------------------------------------------------------------------------ +-- Properties of _*_ and ∣_∣ + +∣i*j∣≡∣i∣*∣j∣ : ∀ i j → ∣ i * j ∣ ≡ ∣ i ∣ ℕ.* ∣ j ∣ +∣i*j∣≡∣i∣*∣j∣ i j = abs-◃ (sign i 𝕊* sign j) (∣ i ∣ ℕ.* ∣ j ∣) + +------------------------------------------------------------------------ +-- Properties of _⊓_ and _⊔_ +------------------------------------------------------------------------ +-- Basic specification in terms of _≤_ + +i≤j⇒i⊓j≡i : i ≤ j → i ⊓ j ≡ i +i≤j⇒i⊓j≡i (-≤- i≥j) = cong -[1+_] (ℕ.m≥n⇒m⊔n≡m i≥j) +i≤j⇒i⊓j≡i -≤+ = refl +i≤j⇒i⊓j≡i (+≤+ i≤j) = cong +_ (ℕ.m≤n⇒m⊓n≡m i≤j) + +i≥j⇒i⊓j≡j : i ≥ j → i ⊓ j ≡ j +i≥j⇒i⊓j≡j (-≤- i≥j) = cong -[1+_] (ℕ.m≤n⇒m⊔n≡n i≥j) +i≥j⇒i⊓j≡j -≤+ = refl +i≥j⇒i⊓j≡j (+≤+ i≤j) = cong +_ (ℕ.m≥n⇒m⊓n≡n i≤j) + +i≤j⇒i⊔j≡j : i ≤ j → i ⊔ j ≡ j +i≤j⇒i⊔j≡j (-≤- i≥j) = cong -[1+_] (ℕ.m≥n⇒m⊓n≡n i≥j) +i≤j⇒i⊔j≡j -≤+ = refl +i≤j⇒i⊔j≡j (+≤+ i≤j) = cong +_ (ℕ.m≤n⇒m⊔n≡n i≤j) + +i≥j⇒i⊔j≡i : i ≥ j → i ⊔ j ≡ i +i≥j⇒i⊔j≡i (-≤- i≥j) = cong -[1+_] (ℕ.m≤n⇒m⊓n≡m i≥j) +i≥j⇒i⊔j≡i -≤+ = refl +i≥j⇒i⊔j≡i (+≤+ i≤j) = cong +_ (ℕ.m≥n⇒m⊔n≡m i≤j) + +⊓-operator : MinOperator ≤-totalPreorder +⊓-operator = record + { x≤y⇒x⊓y≈x = i≤j⇒i⊓j≡i + ; x≥y⇒x⊓y≈y = i≥j⇒i⊓j≡j + } + +⊔-operator : MaxOperator ≤-totalPreorder +⊔-operator = record + { x≤y⇒x⊔y≈y = i≤j⇒i⊔j≡j + ; x≥y⇒x⊔y≈x = i≥j⇒i⊔j≡i + } + +------------------------------------------------------------------------ +-- Automatically derived properties of _⊓_ and _⊔_ + +private + module ⊓-⊔-properties = MinMaxOp ⊓-operator ⊔-operator + module ⊓-⊔-latticeProperties = LatticeMinMaxOp ⊓-operator ⊔-operator + +open ⊓-⊔-properties public + using + ( ⊓-idem -- : Idempotent _⊓_ + ; ⊓-sel -- : Selective _⊓_ + ; ⊓-assoc -- : Associative _⊓_ + ; ⊓-comm -- : Commutative _⊓_ + + ; ⊔-idem -- : Idempotent _⊔_ + ; ⊔-sel -- : Selective _⊔_ + ; ⊔-assoc -- : Associative _⊔_ + ; ⊔-comm -- : Commutative _⊔_ + + ; ⊓-distribˡ-⊔ -- : _⊓_ DistributesOverˡ _⊔_ + ; ⊓-distribʳ-⊔ -- : _⊓_ DistributesOverʳ _⊔_ + ; ⊓-distrib-⊔ -- : _⊓_ DistributesOver _⊔_ + ; ⊔-distribˡ-⊓ -- : _⊔_ DistributesOverˡ _⊓_ + ; ⊔-distribʳ-⊓ -- : _⊔_ DistributesOverʳ _⊓_ + ; ⊔-distrib-⊓ -- : _⊔_ DistributesOver _⊓_ + ; ⊓-absorbs-⊔ -- : _⊓_ Absorbs _⊔_ + ; ⊔-absorbs-⊓ -- : _⊔_ Absorbs _⊓_ + ; ⊔-⊓-absorptive -- : Absorptive _⊔_ _⊓_ + ; ⊓-⊔-absorptive -- : Absorptive _⊓_ _⊔_ + + ; ⊓-isMagma -- : IsMagma _⊓_ + ; ⊓-isSemigroup -- : IsSemigroup _⊓_ + ; ⊓-isCommutativeSemigroup -- : IsCommutativeSemigroup _⊓_ + ; ⊓-isBand -- : IsBand _⊓_ + ; ⊓-isSelectiveMagma -- : IsSelectiveMagma _⊓_ + + ; ⊔-isMagma -- : IsMagma _⊔_ + ; ⊔-isSemigroup -- : IsSemigroup _⊔_ + ; ⊔-isCommutativeSemigroup -- : IsCommutativeSemigroup _⊔_ + ; ⊔-isBand -- : IsBand _⊔_ + ; ⊔-isSelectiveMagma -- : IsSelectiveMagma _⊔_ + + ; ⊓-magma -- : Magma _ _ + ; ⊓-semigroup -- : Semigroup _ _ + ; ⊓-band -- : Band _ _ + ; ⊓-commutativeSemigroup -- : CommutativeSemigroup _ _ + ; ⊓-selectiveMagma -- : SelectiveMagma _ _ + + ; ⊔-magma -- : Magma _ _ + ; ⊔-semigroup -- : Semigroup _ _ + ; ⊔-band -- : Band _ _ + ; ⊔-commutativeSemigroup -- : CommutativeSemigroup _ _ + ; ⊔-selectiveMagma -- : SelectiveMagma _ _ + + ; ⊓-glb -- : ∀ {m n o} → m ≥ o → n ≥ o → m ⊓ n ≥ o + ; ⊓-triangulate -- : ∀ m n o → m ⊓ n ⊓ o ≡ (m ⊓ n) ⊓ (n ⊓ o) + ; ⊓-mono-≤ -- : _⊓_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ + ; ⊓-monoˡ-≤ -- : ∀ n → (_⊓ n) Preserves _≤_ ⟶ _≤_ + ; ⊓-monoʳ-≤ -- : ∀ n → (n ⊓_) Preserves _≤_ ⟶ _≤_ + + ; ⊔-lub -- : ∀ {m n o} → m ≤ o → n ≤ o → m ⊔ n ≤ o + ; ⊔-triangulate -- : ∀ m n o → m ⊔ n ⊔ o ≡ (m ⊔ n) ⊔ (n ⊔ o) + ; ⊔-mono-≤ -- : _⊔_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ + ; ⊔-monoˡ-≤ -- : ∀ n → (_⊔ n) Preserves _≤_ ⟶ _≤_ + ; ⊔-monoʳ-≤ -- : ∀ n → (n ⊔_) Preserves _≤_ ⟶ _≤_ + ) + renaming + ( x⊓y≈y⇒y≤x to i⊓j≡j⇒j≤i -- : ∀ {i j} → i ⊓ j ≡ j → j ≤ i + ; x⊓y≈x⇒x≤y to i⊓j≡i⇒i≤j -- : ∀ {i j} → i ⊓ j ≡ i → i ≤ j + ; x⊓y≤x to i⊓j≤i -- : ∀ i j → i ⊓ j ≤ i + ; x⊓y≤y to i⊓j≤j -- : ∀ i j → i ⊓ j ≤ j + ; x≤y⇒x⊓z≤y to i≤j⇒i⊓k≤j -- : ∀ {i j} k → i ≤ j → i ⊓ k ≤ j + ; x≤y⇒z⊓x≤y to i≤j⇒k⊓i≤j -- : ∀ {i j} k → i ≤ j → k ⊓ i ≤ j + ; x≤y⊓z⇒x≤y to i≤j⊓k⇒i≤j -- : ∀ {i} j k → i ≤ j ⊓ k → i ≤ j + ; x≤y⊓z⇒x≤z to i≤j⊓k⇒i≤k -- : ∀ {i} j k → i ≤ j ⊓ k → i ≤ k + + ; x⊔y≈y⇒x≤y to i⊔j≡j⇒i≤j -- : ∀ {i j} → i ⊔ j ≡ j → i ≤ j + ; x⊔y≈x⇒y≤x to i⊔j≡i⇒j≤i -- : ∀ {i j} → i ⊔ j ≡ i → j ≤ i + ; x≤x⊔y to i≤i⊔j -- : ∀ i j → i ≤ i ⊔ j + ; x≤y⊔x to i≤j⊔i -- : ∀ i j → i ≤ j ⊔ i + ; x≤y⇒x≤y⊔z to i≤j⇒i≤j⊔k -- : ∀ {i j} k → i ≤ j → i ≤ j ⊔ k + ; x≤y⇒x≤z⊔y to i≤j⇒i≤k⊔j -- : ∀ {i j} k → i ≤ j → i ≤ k ⊔ j + ; x⊔y≤z⇒x≤z to i⊔j≤k⇒i≤k -- : ∀ i j {k} → i ⊔ j ≤ k → i ≤ k + ; x⊔y≤z⇒y≤z to i⊔j≤k⇒j≤k -- : ∀ i j {k} → i ⊔ j ≤ k → j ≤ k + + ; x⊓y≤x⊔y to i⊓j≤i⊔j -- : ∀ i j → i ⊓ j ≤ i ⊔ j + ) + +open ⊓-⊔-latticeProperties public + using + ( ⊓-isSemilattice -- : IsSemilattice _⊓_ + ; ⊔-isSemilattice -- : IsSemilattice _⊔_ + ; ⊔-⊓-isLattice -- : IsLattice _⊔_ _⊓_ + ; ⊓-⊔-isLattice -- : IsLattice _⊓_ _⊔_ + ; ⊔-⊓-isDistributiveLattice -- : IsDistributiveLattice _⊔_ _⊓_ + ; ⊓-⊔-isDistributiveLattice -- : IsDistributiveLattice _⊓_ _⊔_ + + ; ⊓-semilattice -- : Semilattice _ _ + ; ⊔-semilattice -- : Semilattice _ _ + ; ⊔-⊓-lattice -- : Lattice _ _ + ; ⊓-⊔-lattice -- : Lattice _ _ + ; ⊔-⊓-distributiveLattice -- : DistributiveLattice _ _ + ; ⊓-⊔-distributiveLattice -- : DistributiveLattice _ _ + ) + +------------------------------------------------------------------------ +-- Other properties of _⊓_ and _⊔_ + +mono-≤-distrib-⊔ : ∀ {f} → f Preserves _≤_ ⟶ _≤_ → + ∀ i j → f (i ⊔ j) ≡ f i ⊔ f j +mono-≤-distrib-⊔ {f} = ⊓-⊔-properties.mono-≤-distrib-⊔ (cong f) + +mono-≤-distrib-⊓ : ∀ {f} → f Preserves _≤_ ⟶ _≤_ → + ∀ i j → f (i ⊓ j) ≡ f i ⊓ f j +mono-≤-distrib-⊓ {f} = ⊓-⊔-properties.mono-≤-distrib-⊓ (cong f) + +antimono-≤-distrib-⊓ : ∀ {f} → f Preserves _≤_ ⟶ _≥_ → + ∀ i j → f (i ⊓ j) ≡ f i ⊔ f j +antimono-≤-distrib-⊓ {f} = ⊓-⊔-properties.antimono-≤-distrib-⊓ (cong f) + +antimono-≤-distrib-⊔ : ∀ {f} → f Preserves _≤_ ⟶ _≥_ → + ∀ i j → f (i ⊔ j) ≡ f i ⊓ f j +antimono-≤-distrib-⊔ {f} = ⊓-⊔-properties.antimono-≤-distrib-⊔ (cong f) + +mono-<-distrib-⊓ : ∀ f → f Preserves _<_ ⟶ _<_ → ∀ i j → f (i ⊓ j) ≡ f i ⊓ f j +mono-<-distrib-⊓ f f-mono-< i j with <-cmp i j +... | tri< i<j _ _ = trans (cong f (i≤j⇒i⊓j≡i (<⇒≤ i<j))) (sym (i≤j⇒i⊓j≡i (<⇒≤ (f-mono-< i<j)))) +... | tri≈ _ refl _ = trans (cong f (i≤j⇒i⊓j≡i ≤-refl)) (sym (i≤j⇒i⊓j≡i ≤-refl)) +... | tri> _ _ i>j = trans (cong f (i≥j⇒i⊓j≡j (<⇒≤ i>j))) (sym (i≥j⇒i⊓j≡j (<⇒≤ (f-mono-< i>j)))) + +mono-<-distrib-⊔ : ∀ f → f Preserves _<_ ⟶ _<_ → ∀ i j → f (i ⊔ j) ≡ f i ⊔ f j +mono-<-distrib-⊔ f f-mono-< i j with <-cmp i j +... | tri< i<j _ _ = trans (cong f (i≤j⇒i⊔j≡j (<⇒≤ i<j))) (sym (i≤j⇒i⊔j≡j (<⇒≤ (f-mono-< i<j)))) +... | tri≈ _ refl _ = trans (cong f (i≤j⇒i⊔j≡j ≤-refl)) (sym (i≤j⇒i⊔j≡j ≤-refl)) +... | tri> _ _ i>j = trans (cong f (i≥j⇒i⊔j≡i (<⇒≤ i>j))) (sym (i≥j⇒i⊔j≡i (<⇒≤ (f-mono-< i>j)))) + +antimono-<-distrib-⊔ : ∀ f → f Preserves _<_ ⟶ _>_ → ∀ i j → f (i ⊔ j) ≡ f i ⊓ f j +antimono-<-distrib-⊔ f f-mono-< i j with <-cmp i j +... | tri< i<j _ _ = trans (cong f (i≤j⇒i⊔j≡j (<⇒≤ i<j))) (sym (i≥j⇒i⊓j≡j (<⇒≤ (f-mono-< i<j)))) +... | tri≈ _ refl _ = trans (cong f (i≤j⇒i⊔j≡j ≤-refl)) (sym (i≥j⇒i⊓j≡j ≤-refl)) +... | tri> _ _ i>j = trans (cong f (i≥j⇒i⊔j≡i (<⇒≤ i>j))) (sym (i≤j⇒i⊓j≡i (<⇒≤ (f-mono-< i>j)))) + +antimono-<-distrib-⊓ : ∀ f → f Preserves _<_ ⟶ _>_ → ∀ i j → f (i ⊓ j) ≡ f i ⊔ f j +antimono-<-distrib-⊓ f f-mono-< i j with <-cmp i j +... | tri< i<j _ _ = trans (cong f (i≤j⇒i⊓j≡i (<⇒≤ i<j))) (sym (i≥j⇒i⊔j≡i (<⇒≤ (f-mono-< i<j)))) +... | tri≈ _ refl _ = trans (cong f (i≤j⇒i⊓j≡i ≤-refl)) (sym (i≥j⇒i⊔j≡i ≤-refl)) +... | tri> _ _ i>j = trans (cong f (i≥j⇒i⊓j≡j (<⇒≤ i>j))) (sym (i≤j⇒i⊔j≡j (<⇒≤ (f-mono-< i>j)))) + +------------------------------------------------------------------------ +-- Other properties of _⊓_, _⊔_ and -_ + +neg-distrib-⊔-⊓ : ∀ i j → - (i ⊔ j) ≡ - i ⊓ - j +neg-distrib-⊔-⊓ = antimono-<-distrib-⊔ -_ neg-mono-< + +neg-distrib-⊓-⊔ : ∀ i j → - (i ⊓ j) ≡ - i ⊔ - j +neg-distrib-⊓-⊔ = antimono-<-distrib-⊓ -_ neg-mono-< + +------------------------------------------------------------------------ +-- Other properties of _⊓_, _⊔_ and _*_ + +*-distribˡ-⊓-nonNeg : ∀ i j k .{{_ : NonNegative i}} → + i * (j ⊓ k) ≡ (i * j) ⊓ (i * k) +*-distribˡ-⊓-nonNeg i j k = mono-≤-distrib-⊓ (*-monoˡ-≤-nonNeg i) j k + +*-distribʳ-⊓-nonNeg : ∀ i j k .{{_ : NonNegative i}} → + (j ⊓ k) * i ≡ (j * i) ⊓ (k * i) +*-distribʳ-⊓-nonNeg i j k = mono-≤-distrib-⊓ (*-monoʳ-≤-nonNeg i) j k + +*-distribˡ-⊓-nonPos : ∀ i j k .{{_ : NonPositive i}} → + i * (j ⊓ k) ≡ (i * j) ⊔ (i * k) +*-distribˡ-⊓-nonPos i j k = antimono-≤-distrib-⊓ (*-monoˡ-≤-nonPos i) j k + +*-distribʳ-⊓-nonPos : ∀ i j k .{{_ : NonPositive i}} → + (j ⊓ k) * i ≡ (j * i) ⊔ (k * i) +*-distribʳ-⊓-nonPos i j k = antimono-≤-distrib-⊓ (*-monoʳ-≤-nonPos i) j k + +*-distribˡ-⊔-nonNeg : ∀ i j k .{{_ : NonNegative i}} → + i * (j ⊔ k) ≡ (i * j) ⊔ (i * k) +*-distribˡ-⊔-nonNeg i j k = mono-≤-distrib-⊔ (*-monoˡ-≤-nonNeg i) j k + +*-distribʳ-⊔-nonNeg : ∀ i j k .{{_ : NonNegative i}} → + (j ⊔ k) * i ≡ (j * i) ⊔ (k * i) +*-distribʳ-⊔-nonNeg i j k = mono-≤-distrib-⊔ (*-monoʳ-≤-nonNeg i) j k + +*-distribˡ-⊔-nonPos : ∀ i j k .{{_ : NonPositive i}} → + i * (j ⊔ k) ≡ (i * j) ⊓ (i * k) +*-distribˡ-⊔-nonPos i j k = antimono-≤-distrib-⊔ (*-monoˡ-≤-nonPos i) j k + +*-distribʳ-⊔-nonPos : ∀ i j k .{{_ : NonPositive i}} → + (j ⊔ k) * i ≡ (j * i) ⊓ (k * i) +*-distribʳ-⊔-nonPos i j k = antimono-≤-distrib-⊔ (*-monoʳ-≤-nonPos i) j k + + +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 1.5 + +neg-mono-<-> = neg-mono-< +{-# WARNING_ON_USAGE neg-mono-<-> +"Warning: neg-mono-<-> was deprecated in v1.5. Please use neg-mono-< instead." -#-} +#-} -neg-mono-≤-≥ = neg-mono-≤ -{-# WARNING_ON_USAGE neg-mono-≤-≥ -"Warning: neg-mono-≤-≥ was deprecated in v1.5. +neg-mono-≤-≥ = neg-mono-≤ +{-# WARNING_ON_USAGE neg-mono-≤-≥ +"Warning: neg-mono-≤-≥ was deprecated in v1.5. Please use neg-mono-≤ instead." -#-} +#-} -*-monoʳ-≤-non-neg = *-monoʳ-≤-nonNeg -{-# WARNING_ON_USAGE *-monoʳ-≤-non-neg -"Warning: *-monoʳ-≤-non-neg was deprecated in v1.5. +*-monoʳ-≤-non-neg = *-monoʳ-≤-nonNeg +{-# WARNING_ON_USAGE *-monoʳ-≤-non-neg +"Warning: *-monoʳ-≤-non-neg was deprecated in v1.5. Please use *-monoʳ-≤-nonNeg instead." -#-} +#-} -*-monoˡ-≤-non-neg = *-monoˡ-≤-nonNeg -{-# WARNING_ON_USAGE *-monoˡ-≤-non-neg -"Warning: *-monoˡ-≤-non-neg deprecated in v1.5. +*-monoˡ-≤-non-neg = *-monoˡ-≤-nonNeg +{-# WARNING_ON_USAGE *-monoˡ-≤-non-neg +"Warning: *-monoˡ-≤-non-neg deprecated in v1.5. Please use *-monoˡ-≤-nonNeg instead." -#-} +#-} -*-cancelˡ-<-non-neg = *-cancelˡ-<-nonNeg -{-# WARNING_ON_USAGE *-cancelˡ-<-non-neg -"Warning: *-cancelˡ-<-non-neg was deprecated in v1.5. +*-cancelˡ-<-non-neg = *-cancelˡ-<-nonNeg +{-# WARNING_ON_USAGE *-cancelˡ-<-non-neg +"Warning: *-cancelˡ-<-non-neg was deprecated in v1.5. Please use *-cancelˡ-<-nonNeg instead." -#-} +#-} -*-cancelʳ-<-non-neg = *-cancelʳ-<-nonNeg -{-# WARNING_ON_USAGE *-cancelʳ-<-non-neg -"Warning: *-cancelʳ-<-non-neg was deprecated in v1.5. +*-cancelʳ-<-non-neg = *-cancelʳ-<-nonNeg +{-# WARNING_ON_USAGE *-cancelʳ-<-non-neg +"Warning: *-cancelʳ-<-non-neg was deprecated in v1.5. Please use *-cancelʳ-<-nonNeg instead." -#-} +#-} --- Version 1.6 +-- Version 1.6 -m≤n⇒m⊓n≡m = i≤j⇒i⊓j≡i -{-# WARNING_ON_USAGE m≤n⇒m⊓n≡m -"Warning: m≤n⇒m⊓n≡m was deprecated in v1.6 +m≤n⇒m⊓n≡m = i≤j⇒i⊓j≡i +{-# WARNING_ON_USAGE m≤n⇒m⊓n≡m +"Warning: m≤n⇒m⊓n≡m was deprecated in v1.6 Please use i≤j⇒i⊓j≡i instead." -#-} -m⊓n≡m⇒m≤n = i⊓j≡i⇒i≤j -{-# WARNING_ON_USAGE m⊓n≡m⇒m≤n -"Warning: m≤n⇒m⊓n≡m was deprecated in v1.6 +#-} +m⊓n≡m⇒m≤n = i⊓j≡i⇒i≤j +{-# WARNING_ON_USAGE m⊓n≡m⇒m≤n +"Warning: m≤n⇒m⊓n≡m was deprecated in v1.6 Please use i⊓j≡i⇒i≤j instead." -#-} -m≥n⇒m⊓n≡n = i≥j⇒i⊓j≡j -{-# WARNING_ON_USAGE m≥n⇒m⊓n≡n -"Warning: m≥n⇒m⊓n≡n was deprecated in v1.6 +#-} +m≥n⇒m⊓n≡n = i≥j⇒i⊓j≡j +{-# WARNING_ON_USAGE m≥n⇒m⊓n≡n +"Warning: m≥n⇒m⊓n≡n was deprecated in v1.6 Please use i≥j⇒i⊓j≡j instead." -#-} -m⊓n≡n⇒m≥n = i⊓j≡j⇒j≤i -{-# WARNING_ON_USAGE m⊓n≡n⇒m≥n -"Warning: m⊓n≡n⇒m≥n was deprecated in v1.6 +#-} +m⊓n≡n⇒m≥n = i⊓j≡j⇒j≤i +{-# WARNING_ON_USAGE m⊓n≡n⇒m≥n +"Warning: m⊓n≡n⇒m≥n was deprecated in v1.6 Please use i⊓j≡j⇒j≤i instead." -#-} -m⊓n≤n = i⊓j≤j -{-# WARNING_ON_USAGE m⊓n≤n -"Warning: m⊓n≤n was deprecated in v1.6 +#-} +m⊓n≤n = i⊓j≤j +{-# WARNING_ON_USAGE m⊓n≤n +"Warning: m⊓n≤n was deprecated in v1.6 Please use i⊓j≤j instead." -#-} -m⊓n≤m = i⊓j≤i -{-# WARNING_ON_USAGE m⊓n≤m -"Warning: m⊓n≤m was deprecated in v1.6 +#-} +m⊓n≤m = i⊓j≤i +{-# WARNING_ON_USAGE m⊓n≤m +"Warning: m⊓n≤m was deprecated in v1.6 Please use i⊓j≤i instead." -#-} -m≤n⇒m⊔n≡n = i≤j⇒i⊔j≡j -{-# WARNING_ON_USAGE m≤n⇒m⊔n≡n -"Warning: m≤n⇒m⊔n≡n was deprecated in v1.6 +#-} +m≤n⇒m⊔n≡n = i≤j⇒i⊔j≡j +{-# WARNING_ON_USAGE m≤n⇒m⊔n≡n +"Warning: m≤n⇒m⊔n≡n was deprecated in v1.6 Please use i≤j⇒i⊔j≡j instead." -#-} -m⊔n≡n⇒m≤n = i⊔j≡j⇒i≤j -{-# WARNING_ON_USAGE m⊔n≡n⇒m≤n -"Warning: m⊔n≡n⇒m≤n was deprecated in v1.6 +#-} +m⊔n≡n⇒m≤n = i⊔j≡j⇒i≤j +{-# WARNING_ON_USAGE m⊔n≡n⇒m≤n +"Warning: m⊔n≡n⇒m≤n was deprecated in v1.6 Please use i⊔j≡j⇒i≤j instead." -#-} -m≥n⇒m⊔n≡m = i≥j⇒i⊔j≡i -{-# WARNING_ON_USAGE m≥n⇒m⊔n≡m -"Warning: m≥n⇒m⊔n≡m was deprecated in v1.6 +#-} +m≥n⇒m⊔n≡m = i≥j⇒i⊔j≡i +{-# WARNING_ON_USAGE m≥n⇒m⊔n≡m +"Warning: m≥n⇒m⊔n≡m was deprecated in v1.6 Please use i≥j⇒i⊔j≡i instead." -#-} -m⊔n≡m⇒m≥n = i⊔j≡i⇒j≤i -{-# WARNING_ON_USAGE m⊔n≡m⇒m≥n -"Warning: m⊔n≡m⇒m≥n was deprecated in v1.6 +#-} +m⊔n≡m⇒m≥n = i⊔j≡i⇒j≤i +{-# WARNING_ON_USAGE m⊔n≡m⇒m≥n +"Warning: m⊔n≡m⇒m≥n was deprecated in v1.6 Please use i⊔j≡i⇒j≤i instead." -#-} -m≤m⊔n = i≤i⊔j -{-# WARNING_ON_USAGE m≤m⊔n -"Warning: m≤m⊔n was deprecated in v1.6 +#-} +m≤m⊔n = i≤i⊔j +{-# WARNING_ON_USAGE m≤m⊔n +"Warning: m≤m⊔n was deprecated in v1.6 Please use i≤i⊔j instead." -#-} -n≤m⊔n = i≤j⊔i -{-# WARNING_ON_USAGE n≤m⊔n -"Warning: n≤m⊔n was deprecated in v1.6 +#-} +n≤m⊔n = i≤j⊔i +{-# WARNING_ON_USAGE n≤m⊔n +"Warning: n≤m⊔n was deprecated in v1.6 Please use i≤j⊔i instead." -#-} +#-} --- Version 2.0 +-- Version 2.0 -+-pos-monoʳ-≤ : ∀ n → (_+_ (+ n)) Preserves _≤_ ⟶ _≤_ -+-pos-monoʳ-≤ n {_} (-≤- o≤m) = ⊖-monoʳ-≥-≤ n (s≤s o≤m) -+-pos-monoʳ-≤ n { -[1+ m ]} -≤+ = ≤-trans (m⊖n≤m n (suc m)) (+≤+ (ℕ.m≤m+n n _)) -+-pos-monoʳ-≤ n {_} (+≤+ m≤o) = +≤+ (ℕ.+-monoʳ-≤ n m≤o) -{-# WARNING_ON_USAGE +-pos-monoʳ-≤ -"Warning: +-pos-monoʳ-≤ was deprecated in v2.0 ++-pos-monoʳ-≤ : ∀ n → (_+_ (+ n)) Preserves _≤_ ⟶ _≤_ ++-pos-monoʳ-≤ n {_} (-≤- o≤m) = ⊖-monoʳ-≥-≤ n (s≤s o≤m) ++-pos-monoʳ-≤ n { -[1+ m ]} -≤+ = ≤-trans (m⊖n≤m n (suc m)) (+≤+ (ℕ.m≤m+n n _)) ++-pos-monoʳ-≤ n {_} (+≤+ m≤o) = +≤+ (ℕ.+-monoʳ-≤ n m≤o) +{-# WARNING_ON_USAGE +-pos-monoʳ-≤ +"Warning: +-pos-monoʳ-≤ was deprecated in v2.0 Please use +-monoʳ-≤ instead." -#-} -+-neg-monoʳ-≤ : ∀ n → (_+_ (-[1+ n ])) Preserves _≤_ ⟶ _≤_ -+-neg-monoʳ-≤ n {_} {_} (-≤- n≤m) = -≤- (ℕ.+-monoʳ-≤ (suc n) n≤m) -+-neg-monoʳ-≤ n {_} {+ m} -≤+ = ≤-trans (-≤- (ℕ.m≤m+n (suc n) _)) (-1+m≤n⊖m (suc n) m) -+-neg-monoʳ-≤ n {_} {_} (+≤+ m≤n) = ⊖-monoˡ-≤ (suc n) m≤n -{-# WARNING_ON_USAGE +-neg-monoʳ-≤ -"Warning: +-neg-monoʳ-≤ was deprecated in v2.0 +#-} ++-neg-monoʳ-≤ : ∀ n → (_+_ (-[1+ n ])) Preserves _≤_ ⟶ _≤_ ++-neg-monoʳ-≤ n {_} {_} (-≤- n≤m) = -≤- (ℕ.+-monoʳ-≤ (suc n) n≤m) ++-neg-monoʳ-≤ n {_} {+ m} -≤+ = ≤-trans (-≤- (ℕ.m≤m+n (suc n) _)) (-1+m≤n⊖m (suc n) m) ++-neg-monoʳ-≤ n {_} {_} (+≤+ m≤n) = ⊖-monoˡ-≤ (suc n) m≤n +{-# WARNING_ON_USAGE +-neg-monoʳ-≤ +"Warning: +-neg-monoʳ-≤ was deprecated in v2.0 Please use +-monoʳ-≤ instead." -#-} -n≮n = i≮i -{-# WARNING_ON_USAGE n≮n -"Warning: n≮n was deprecated in v2.0 +#-} +n≮n = i≮i +{-# WARNING_ON_USAGE n≮n +"Warning: n≮n was deprecated in v2.0 Please use i≮i instead." -#-} -∣n∣≡0⇒n≡0 = ∣i∣≡0⇒i≡0 -{-# WARNING_ON_USAGE ∣n∣≡0⇒n≡0 -"Warning: ∣n∣≡0⇒n≡0 was deprecated in v2.0 +#-} +∣n∣≡0⇒n≡0 = ∣i∣≡0⇒i≡0 +{-# WARNING_ON_USAGE ∣n∣≡0⇒n≡0 +"Warning: ∣n∣≡0⇒n≡0 was deprecated in v2.0 Please use ∣i∣≡0⇒i≡0 instead." -#-} -∣-n∣≡∣n∣ = ∣-i∣≡∣i∣ -{-# WARNING_ON_USAGE ∣-n∣≡∣n∣ -"Warning: ∣-n∣≡∣n∣ was deprecated in v2.0 +#-} +∣-n∣≡∣n∣ = ∣-i∣≡∣i∣ +{-# WARNING_ON_USAGE ∣-n∣≡∣n∣ +"Warning: ∣-n∣≡∣n∣ was deprecated in v2.0 Please use ∣-i∣≡∣i∣ instead." -#-} -0≤n⇒+∣n∣≡n = 0≤i⇒+∣i∣≡i -{-# WARNING_ON_USAGE 0≤n⇒+∣n∣≡n -"Warning: 0≤n⇒+∣n∣≡n was deprecated in v2.0 +#-} +0≤n⇒+∣n∣≡n = 0≤i⇒+∣i∣≡i +{-# WARNING_ON_USAGE 0≤n⇒+∣n∣≡n +"Warning: 0≤n⇒+∣n∣≡n was deprecated in v2.0 Please use 0≤i⇒+∣i∣≡i instead." -#-} -+∣n∣≡n⇒0≤n = +∣i∣≡i⇒0≤i -{-# WARNING_ON_USAGE +∣n∣≡n⇒0≤n -"Warning: +∣n∣≡n⇒0≤n was deprecated in v2.0 +#-} ++∣n∣≡n⇒0≤n = +∣i∣≡i⇒0≤i +{-# WARNING_ON_USAGE +∣n∣≡n⇒0≤n +"Warning: +∣n∣≡n⇒0≤n was deprecated in v2.0 Please use +∣i∣≡i⇒0≤i instead." -#-} -+∣n∣≡n⊎+∣n∣≡-n = +∣i∣≡i⊎+∣i∣≡-i -{-# WARNING_ON_USAGE +∣n∣≡n⊎+∣n∣≡-n -"Warning: +∣n∣≡n⊎+∣n∣≡-n was deprecated in v2.0 +#-} ++∣n∣≡n⊎+∣n∣≡-n = +∣i∣≡i⊎+∣i∣≡-i +{-# WARNING_ON_USAGE +∣n∣≡n⊎+∣n∣≡-n +"Warning: +∣n∣≡n⊎+∣n∣≡-n was deprecated in v2.0 Please use +∣i∣≡i⊎+∣i∣≡-i instead." -#-} -∣m+n∣≤∣m∣+∣n∣ = ∣i+j∣≤∣i∣+∣j∣ -{-# WARNING_ON_USAGE ∣m+n∣≤∣m∣+∣n∣ -"Warning: ∣m+n∣≤∣m∣+∣n∣ was deprecated in v2.0 +#-} +∣m+n∣≤∣m∣+∣n∣ = ∣i+j∣≤∣i∣+∣j∣ +{-# WARNING_ON_USAGE ∣m+n∣≤∣m∣+∣n∣ +"Warning: ∣m+n∣≤∣m∣+∣n∣ was deprecated in v2.0 Please use ∣i+j∣≤∣i∣+∣j∣ instead." -#-} -∣m-n∣≤∣m∣+∣n∣ = ∣i-j∣≤∣i∣+∣j∣ -{-# WARNING_ON_USAGE ∣m-n∣≤∣m∣+∣n∣ -"Warning: ∣m-n∣≤∣m∣+∣n∣ was deprecated in v2.0 +#-} +∣m-n∣≤∣m∣+∣n∣ = ∣i-j∣≤∣i∣+∣j∣ +{-# WARNING_ON_USAGE ∣m-n∣≤∣m∣+∣n∣ +"Warning: ∣m-n∣≤∣m∣+∣n∣ was deprecated in v2.0 Please use ∣i-j∣≤∣i∣+∣j∣ instead." -#-} -signₙ◃∣n∣≡n = signᵢ◃∣i∣≡i -{-# WARNING_ON_USAGE signₙ◃∣n∣≡n -"Warning: signₙ◃∣n∣≡n was deprecated in v2.0 +#-} +signₙ◃∣n∣≡n = signᵢ◃∣i∣≡i +{-# WARNING_ON_USAGE signₙ◃∣n∣≡n +"Warning: signₙ◃∣n∣≡n was deprecated in v2.0 Please use signᵢ◃∣i∣≡i instead." -#-} -◃-≡ = ◃-cong -{-# WARNING_ON_USAGE ◃-≡ -"Warning: ◃-≡ was deprecated in v2.0 +#-} +◃-≡ = ◃-cong +{-# WARNING_ON_USAGE ◃-≡ +"Warning: ◃-≡ was deprecated in v2.0 Please use ◃-cong instead." -#-} -∣m-n∣≡∣n-m∣ = ∣i-j∣≡∣j-i∣ -{-# WARNING_ON_USAGE ∣m-n∣≡∣n-m∣ -"Warning: ∣m-n∣≡∣n-m∣ was deprecated in v2.0 +#-} +∣m-n∣≡∣n-m∣ = ∣i-j∣≡∣j-i∣ +{-# WARNING_ON_USAGE ∣m-n∣≡∣n-m∣ +"Warning: ∣m-n∣≡∣n-m∣ was deprecated in v2.0 Please use ∣i-j∣≡∣j-i∣ instead." -#-} -m≡n⇒m-n≡0 = i≡j⇒i-j≡0 -{-# WARNING_ON_USAGE m≡n⇒m-n≡0 -"Warning: m≡n⇒m-n≡0 was deprecated in v2.0 +#-} +m≡n⇒m-n≡0 = i≡j⇒i-j≡0 +{-# WARNING_ON_USAGE m≡n⇒m-n≡0 +"Warning: m≡n⇒m-n≡0 was deprecated in v2.0 Please use i≡j⇒i-j≡0 instead." -#-} -m-n≡0⇒m≡n = i-j≡0⇒i≡j -{-# WARNING_ON_USAGE m-n≡0⇒m≡n -"Warning: m-n≡0⇒m≡n was deprecated in v2.0 +#-} +m-n≡0⇒m≡n = i-j≡0⇒i≡j +{-# WARNING_ON_USAGE m-n≡0⇒m≡n +"Warning: m-n≡0⇒m≡n was deprecated in v2.0 Please use i-j≡0⇒i≡j instead." -#-} -≤-steps = i≤j⇒i≤k+j -{-# WARNING_ON_USAGE ≤-steps -"Warning: ≤-steps was deprecated in v2.0 +#-} +≤-steps = i≤j⇒i≤k+j +{-# WARNING_ON_USAGE ≤-steps +"Warning: ≤-steps was deprecated in v2.0 Please use i≤j⇒i≤k+j instead." -#-} -≤-steps-neg = i≤j⇒i-k≤j -{-# WARNING_ON_USAGE ≤-steps-neg -"Warning: ≤-steps-neg was deprecated in v2.0 +#-} +≤-steps-neg = i≤j⇒i-k≤j +{-# WARNING_ON_USAGE ≤-steps-neg +"Warning: ≤-steps-neg was deprecated in v2.0 Please use i≤j⇒i-k≤j instead." -#-} -≤-step = i≤j⇒i≤1+j -{-# WARNING_ON_USAGE ≤-step -"Warning: ≤-step was deprecated in v2.0 +#-} +≤-step = i≤j⇒i≤1+j +{-# WARNING_ON_USAGE ≤-step +"Warning: ≤-step was deprecated in v2.0 Please use i≤j⇒i≤1+j instead." -#-} -≤-step-neg = i≤j⇒pred[i]≤j -{-# WARNING_ON_USAGE ≤-step-neg -"Warning: ≤-step-neg was deprecated in v2.0 +#-} +≤-step-neg = i≤j⇒pred[i]≤j +{-# WARNING_ON_USAGE ≤-step-neg +"Warning: ≤-step-neg was deprecated in v2.0 Please use i≤j⇒pred[i]≤j instead." -#-} -m≤n⇒m-n≤0 = i≤j⇒i-j≤0 -{-# WARNING_ON_USAGE m≤n⇒m-n≤0 -"Warning: m≤n⇒m-n≤0 was deprecated in v2.0 +#-} +m≤n⇒m-n≤0 = i≤j⇒i-j≤0 +{-# WARNING_ON_USAGE m≤n⇒m-n≤0 +"Warning: m≤n⇒m-n≤0 was deprecated in v2.0 Please use i≤j⇒i-j≤0 instead." -#-} -m-n≤0⇒m≤n = i-j≤0⇒i≤j -{-# WARNING_ON_USAGE m-n≤0⇒m≤n -"Warning: m-n≤0⇒m≤n was deprecated in v2.0 +#-} +m-n≤0⇒m≤n = i-j≤0⇒i≤j +{-# WARNING_ON_USAGE m-n≤0⇒m≤n +"Warning: m-n≤0⇒m≤n was deprecated in v2.0 Please use i-j≤0⇒i≤j instead." -#-} -m≤n⇒0≤n-m = i≤j⇒0≤j-i -{-# WARNING_ON_USAGE m≤n⇒0≤n-m -"Warning: m≤n⇒0≤n-m was deprecated in v2.0 +#-} +m≤n⇒0≤n-m = i≤j⇒0≤j-i +{-# WARNING_ON_USAGE m≤n⇒0≤n-m +"Warning: m≤n⇒0≤n-m was deprecated in v2.0 Please use i≤j⇒0≤j-i instead." -#-} -0≤n-m⇒m≤n = 0≤i-j⇒j≤i -{-# WARNING_ON_USAGE 0≤n-m⇒m≤n -"Warning: 0≤n-m⇒m≤n was deprecated in v2.0 +#-} +0≤n-m⇒m≤n = 0≤i-j⇒j≤i +{-# WARNING_ON_USAGE 0≤n-m⇒m≤n +"Warning: 0≤n-m⇒m≤n was deprecated in v2.0 Please use 0≤i-j⇒j≤i instead." -#-} -n≤1+n = i≤suc[i] -{-# WARNING_ON_USAGE n≤1+n -"Warning: n≤1+n was deprecated in v2.0 +#-} +n≤1+n = i≤suc[i] +{-# WARNING_ON_USAGE n≤1+n +"Warning: n≤1+n was deprecated in v2.0 Please use i≤suc[i] instead." -#-} -n≢1+n = i≢suc[i] -{-# WARNING_ON_USAGE n≢1+n -"Warning: n≢1+n was deprecated in v2.0 +#-} +n≢1+n = i≢suc[i] +{-# WARNING_ON_USAGE n≢1+n +"Warning: n≢1+n was deprecated in v2.0 Please use i≢suc[i] instead." -#-} -m≤pred[n]⇒m<n = i≤pred[j]⇒i<j -{-# WARNING_ON_USAGE m≤pred[n]⇒m<n -"Warning: m≤pred[n]⇒m<n was deprecated in v2.0 +#-} +m≤pred[n]⇒m<n = i≤pred[j]⇒i<j +{-# WARNING_ON_USAGE m≤pred[n]⇒m<n +"Warning: m≤pred[n]⇒m<n was deprecated in v2.0 Please use i≤pred[j]⇒i<j instead." -#-} -m<n⇒m≤pred[n] = i<j⇒i≤pred[j] -{-# WARNING_ON_USAGE m<n⇒m≤pred[n] -"Warning: m<n⇒m≤pred[n] was deprecated in v2.0 +#-} +m<n⇒m≤pred[n] = i<j⇒i≤pred[j] +{-# WARNING_ON_USAGE m<n⇒m≤pred[n] +"Warning: m<n⇒m≤pred[n] was deprecated in v2.0 Please use i<j⇒i≤pred[j] instead." -#-} --1*n≡-n = -1*i≡-i -{-# WARNING_ON_USAGE -1*n≡-n -"Warning: -1*n≡-n was deprecated in v2.0 +#-} +-1*n≡-n = -1*i≡-i +{-# WARNING_ON_USAGE -1*n≡-n +"Warning: -1*n≡-n was deprecated in v2.0 Please use -1*i≡-i instead." -#-} -m*n≡0⇒m≡0∨n≡0 = i*j≡0⇒i≡0∨j≡0 -{-# WARNING_ON_USAGE m*n≡0⇒m≡0∨n≡0 -"Warning: m*n≡0⇒m≡0∨n≡0 was deprecated in v2.0 +#-} +m*n≡0⇒m≡0∨n≡0 = i*j≡0⇒i≡0∨j≡0 +{-# WARNING_ON_USAGE m*n≡0⇒m≡0∨n≡0 +"Warning: m*n≡0⇒m≡0∨n≡0 was deprecated in v2.0 Please use i*j≡0⇒i≡0∨j≡0 instead." -#-} -∣m*n∣≡∣m∣*∣n∣ = ∣i*j∣≡∣i∣*∣j∣ -{-# WARNING_ON_USAGE ∣m*n∣≡∣m∣*∣n∣ -"Warning: ∣m*n∣≡∣m∣*∣n∣ was deprecated in v2.0 +#-} +∣m*n∣≡∣m∣*∣n∣ = ∣i*j∣≡∣i∣*∣j∣ +{-# WARNING_ON_USAGE ∣m*n∣≡∣m∣*∣n∣ +"Warning: ∣m*n∣≡∣m∣*∣n∣ was deprecated in v2.0 Please use ∣i*j∣≡∣i∣*∣j∣ instead." -#-} -n≤m+n : ∀ n → i ≤ + n + i -n≤m+n {i} n = i≤j+i i (+ n) -{-# WARNING_ON_USAGE n≤m+n -"Warning: n≤m+n was deprecated in v2.0 +#-} +n≤m+n : ∀ n → i ≤ + n + i +n≤m+n {i} n = i≤j+i i (+ n) +{-# WARNING_ON_USAGE n≤m+n +"Warning: n≤m+n was deprecated in v2.0 Please use i≤j+i instead. Note the change of form of the explicit arguments." -#-} -m≤m+n : ∀ n → i ≤ i + + n -m≤m+n {i} n = i≤i+j i (+ n) -{-# WARNING_ON_USAGE m≤m+n -"Warning: m≤m+n was deprecated in v2.0 +#-} +m≤m+n : ∀ n → i ≤ i + + n +m≤m+n {i} n = i≤i+j i (+ n) +{-# WARNING_ON_USAGE m≤m+n +"Warning: m≤m+n was deprecated in v2.0 Please use i≤i+j instead. Note the change of form of the explicit arguments." -#-} -m-n≤m : ∀ i n → i - + n ≤ i -m-n≤m i n = i-j≤i i (+ n) -{-# WARNING_ON_USAGE m-n≤m -"Warning: m-n≤m was deprecated in v2.0 +#-} +m-n≤m : ∀ i n → i - + n ≤ i +m-n≤m i n = i-j≤i i (+ n) +{-# WARNING_ON_USAGE m-n≤m +"Warning: m-n≤m was deprecated in v2.0 Please use i-j≤i instead. Note the change of form of the explicit arguments." -#-} -*-monoʳ-≤-pos : ∀ n → (_* + suc n) Preserves _≤_ ⟶ _≤_ -*-monoʳ-≤-pos n = *-monoʳ-≤-nonNeg +[1+ n ] -{-# WARNING_ON_USAGE *-monoʳ-≤-pos -"Warning: *-monoʳ-≤-pos was deprecated in v2.0 +#-} +*-monoʳ-≤-pos : ∀ n → (_* + suc n) Preserves _≤_ ⟶ _≤_ +*-monoʳ-≤-pos n = *-monoʳ-≤-nonNeg +[1+ n ] +{-# WARNING_ON_USAGE *-monoʳ-≤-pos +"Warning: *-monoʳ-≤-pos was deprecated in v2.0 Please use *-monoʳ-≤-nonNeg instead." -#-} -*-monoˡ-≤-pos : ∀ n → (+ suc n *_) Preserves _≤_ ⟶ _≤_ -*-monoˡ-≤-pos n = *-monoˡ-≤-nonNeg +[1+ n ] -{-# WARNING_ON_USAGE *-monoˡ-≤-pos -"Warning: *-monoˡ-≤-pos was deprecated in v2.0 +#-} +*-monoˡ-≤-pos : ∀ n → (+ suc n *_) Preserves _≤_ ⟶ _≤_ +*-monoˡ-≤-pos n = *-monoˡ-≤-nonNeg +[1+ n ] +{-# WARNING_ON_USAGE *-monoˡ-≤-pos +"Warning: *-monoˡ-≤-pos was deprecated in v2.0 Please use *-monoˡ-≤-nonNeg instead." -#-} -*-monoˡ-≤-neg : ∀ m → (-[1+ m ] *_) Preserves _≤_ ⟶ _≥_ -*-monoˡ-≤-neg m = *-monoˡ-≤-nonPos -[1+ m ] -{-# WARNING_ON_USAGE *-monoˡ-≤-neg -"Warning: *-monoˡ-≤-neg was deprecated in v2.0 +#-} +*-monoˡ-≤-neg : ∀ m → (-[1+ m ] *_) Preserves _≤_ ⟶ _≥_ +*-monoˡ-≤-neg m = *-monoˡ-≤-nonPos -[1+ m ] +{-# WARNING_ON_USAGE *-monoˡ-≤-neg +"Warning: *-monoˡ-≤-neg was deprecated in v2.0 Please use *-monoˡ-≤-nonPos instead." -#-} -*-monoʳ-≤-neg : ∀ m → (_* -[1+ m ]) Preserves _≤_ ⟶ _≥_ -*-monoʳ-≤-neg m = *-monoʳ-≤-nonPos -[1+ m ] -{-# WARNING_ON_USAGE *-monoʳ-≤-neg -"Warning: *-monoʳ-≤-neg was deprecated in v2.0 +#-} +*-monoʳ-≤-neg : ∀ m → (_* -[1+ m ]) Preserves _≤_ ⟶ _≥_ +*-monoʳ-≤-neg m = *-monoʳ-≤-nonPos -[1+ m ] +{-# WARNING_ON_USAGE *-monoʳ-≤-neg +"Warning: *-monoʳ-≤-neg was deprecated in v2.0 Please use *-monoʳ-≤-nonPos instead." -#-} -pos-+-commute : ℕtoℤ.Homomorphic₂ +_ ℕ._+_ _+_ -pos-+-commute = pos-+ -{-# WARNING_ON_USAGE pos-+-commute -"Warning: pos-+-commute was deprecated in v2.0 +#-} +pos-+-commute : ℕtoℤ.Homomorphic₂ +_ ℕ._+_ _+_ +pos-+-commute = pos-+ +{-# WARNING_ON_USAGE pos-+-commute +"Warning: pos-+-commute was deprecated in v2.0 Please use pos-+ instead." -#-} -abs-*-commute : ℤtoℕ.Homomorphic₂ ∣_∣ _*_ ℕ._*_ -abs-*-commute = abs-* -{-# WARNING_ON_USAGE abs-*-commute -"Warning: abs-*-commute was deprecated in v2.0 +#-} +abs-*-commute : ℤtoℕ.Homomorphic₂ ∣_∣ _*_ ℕ._*_ +abs-*-commute = abs-* +{-# WARNING_ON_USAGE abs-*-commute +"Warning: abs-*-commute was deprecated in v2.0 Please use abs-* instead." -#-} -pos-distrib-* : ∀ m n → (+ m) * (+ n) ≡ + (m ℕ.* n) -pos-distrib-* m n = sym (pos-* m n) -{-# WARNING_ON_USAGE pos-distrib-* -"Warning: pos-distrib-* was deprecated in v2.0 +#-} +pos-distrib-* : ∀ m n → (+ m) * (+ n) ≡ + (m ℕ.* n) +pos-distrib-* m n = sym (pos-* m n) +{-# WARNING_ON_USAGE pos-distrib-* +"Warning: pos-distrib-* was deprecated in v2.0 Please use pos-* instead." -#-} -+-isAbelianGroup = +-0-isAbelianGroup -{-# WARNING_ON_USAGE +-isAbelianGroup -"Warning: +-isAbelianGroup was deprecated in v2.0 +#-} ++-isAbelianGroup = +-0-isAbelianGroup +{-# WARNING_ON_USAGE +-isAbelianGroup +"Warning: +-isAbelianGroup was deprecated in v2.0 Please use +-0-isAbelianGroup instead." -#-} -{- issue1844/issue1755: raw bundles have moved to `Data.X.Base` -} -open Data.Integer.Base public - using (*-rawMagma; *-1-rawMonoid) +#-} +{- issue1844/issue1755: raw bundles have moved to `Data.X.Base` -} +open Data.Integer.Base public + using (*-rawMagma; *-1-rawMonoid) \ No newline at end of file diff --git a/Data.Integer.Show.html b/Data.Integer.Show.html index 6cc3840b..aee24974 100644 --- a/Data.Integer.Show.html +++ b/Data.Integer.Show.html @@ -11,8 +11,8 @@ open import Data.Integer.Base using (ℤ; +_; -[1+_]) open import Data.Nat.Base using (suc) -open import Data.Nat.Show using () renaming (show to showℕ) -open import Data.String.Base using (String; _++_) +open import Data.Nat.Show using () renaming (show to showℕ) +open import Data.String.Base using (String; _++_) ------------------------------------------------------------------------ -- Show @@ -22,5 +22,5 @@ show : ℤ → String show (+ n) = showℕ n -show -[1+ n ] = "-" ++ showℕ (suc n) +show -[1+ n ] = "-" ++ showℕ (suc n) \ No newline at end of file diff --git a/Data.Integer.Solver.html b/Data.Integer.Solver.html index f621fe0c..f16c7a11 100644 --- a/Data.Integer.Solver.html +++ b/Data.Integer.Solver.html @@ -13,12 +13,12 @@ import Algebra.Solver.Ring.Simple as Solver import Algebra.Solver.Ring.AlmostCommutativeRing as ACR -open import Data.Integer.Properties using (_≟_; +-*-commutativeRing) +open import Data.Integer.Properties using (_≟_; +-*-commutativeRing) ------------------------------------------------------------------------ -- A module for automatically solving propositional equivalences -- containing _+_ and _*_ module +-*-Solver = - Solver (ACR.fromCommutativeRing +-*-commutativeRing) _≟_ + Solver (ACR.fromCommutativeRing +-*-commutativeRing) _≟_ \ No newline at end of file diff --git a/Data.Integer.html b/Data.Integer.html index 22b84215..aacb4e35 100644 --- a/Data.Integer.html +++ b/Data.Integer.html @@ -17,7 +17,7 @@ open import Data.Integer.Base public open import Data.Integer.Properties public - using (_≟_; _≤?_; _<?_) + using (_≟_; _≤?_; _<?_) ------------------------------------------------------------------------ -- Deprecated @@ -25,25 +25,25 @@ -- Version 0.17 open import Data.Integer.Properties public - using (◃-cong; drop‿+≤+; drop‿-≤-) - renaming (◃-inverse to ◃-left-inverse) + using (◃-cong; drop‿+≤+; drop‿-≤-) + renaming (◃-inverse to ◃-left-inverse) -- Version 1.5 -- Show -import Data.Nat.Show as ℕ -open import Data.Sign as Sign using (Sign) -open import Data.String.Base using (String; _++_) +import Data.Nat.Show as ℕ using (show) +open import Data.Sign as Sign using (Sign) +open import Data.String.Base using (String; _++_) -show : ℤ → String -show i = showSign (sign i) ++ ℕ.show ∣ i ∣ - where - showSign : Sign → String - showSign Sign.- = "-" - showSign Sign.+ = "" +show : ℤ → String +show i = showSign (sign i) ++ ℕ.show ∣ i ∣ + where + showSign : Sign → String + showSign Sign.- = "-" + showSign Sign.+ = "" -{-# WARNING_ON_USAGE show -"Warning: show was deprecated in v1.5. +{-# WARNING_ON_USAGE show +"Warning: show was deprecated in v1.5. Please use Data.Integer.Show's show instead." -#-} +#-} \ No newline at end of file diff --git a/Data.Interval.Base.html b/Data.Interval.Base.html index 2bcc335e..2ceaa58f 100644 --- a/Data.Interval.Base.html +++ b/Data.Interval.Base.html @@ -10,26 +10,26 @@ module Data.Interval.Base where open import Algebra.Bundles.Raw -open import Data.Bool.Base using (Bool; true; false; if_then_else_) +open import Data.Bool.Base using (Bool; true; false; if_then_else_) open import Data.Nat.GCD open import Data.Nat.Coprimality as C - using (Coprime; coprime-/gcd; ¬0-coprimeTo-2+; coprime-+) -open import Data.Nat.DivMod using (/-monoˡ-≤) -open import Data.Nat.Divisibility using (_∣_; divides; ∣m+n∣m⇒∣n; ∣m∸n∣n⇒∣m) + using (Coprime; coprime-/gcd; ¬0-coprimeTo-2+; coprime-+) +open import Data.Nat.DivMod using (/-monoˡ-≤) +open import Data.Nat.Divisibility using (_∣_; divides; ∣m+n∣m⇒∣n; ∣m∸n∣n⇒∣m) open import Data.Nat.Base as ℕ using (ℕ; zero; suc) hiding (module ℕ) import Data.Nat.Properties as ℕ open import Data.Product open import Data.Sum.Base using (inj₂) -open import Function.Base using (id; _$_) +open import Function.Base using (id; _$_) open import Level using (0ℓ) -open import Relation.Nullary using (¬_; recompute) -open import Relation.Nullary.Negation using (contradiction) -open import Relation.Unary using (Pred) -open import Relation.Binary.Core using (Rel) +open import Relation.Nullary using (¬_; recompute) +open import Relation.Nullary.Negation using (contradiction) +open import Relation.Unary using (Pred) +open import Relation.Binary.Core using (Rel) open import Relation.Binary.PropositionalEquality.Core as P - using (_≡_; _≢_; refl) + using (_≡_; _≢_; refl) open import Data.Integer using (+_) -open import Data.Rational as ℚ using (ℚ) +open import Data.Rational as ℚ using (ℚ) ------------------------------------------------------------------------ -- The unit interval in reduced form. Note that there is exactly one @@ -42,8 +42,8 @@ field numerator : ℕ denominator-1 : ℕ - .isCoprime : Coprime numerator (suc denominator-1) - .isContained : numerator ℕ.≤ suc denominator-1 + .isCoprime : Coprime numerator (suc denominator-1) + .isContained : numerator ℕ.≤ suc denominator-1 denominator : ℕ denominator = suc denominator-1 @@ -54,7 +54,7 @@ ; denominator to ↧_ ) -mk𝕀+ : ∀ n d → .{{_ : ℕ.NonZero d}} → .(Coprime n d) → .(n ℕ.≤ d) → 𝕀 +mk𝕀+ : ∀ n d → .{{_ : ℕ.NonZero d}} → .(Coprime n d) → .(n ℕ.≤ d) → 𝕀 mk𝕀+ n (suc d) = mk𝕀 n d ------------------------------------------------------------------------ @@ -62,7 +62,7 @@ infix 4 _≃_ -_≃_ : Rel 𝕀 0ℓ +_≃_ : Rel 𝕀 0ℓ p ≃ q = (↥ p ℕ.* ↧ q) ≡ (↥ q ℕ.* ↧ p) ------------------------------------------------------------------------ @@ -70,29 +70,29 @@ infix 4 _≤_ _<_ _≥_ _>_ _≰_ _≱_ _≮_ _≯_ -data _≤_ : Rel 𝕀 0ℓ where - *≤* : ∀ {p q} → (↥ p ℕ.* ↧ q) ℕ.≤ (↥ q ℕ.* ↧ p) → p ≤ q +data _≤_ : Rel 𝕀 0ℓ where + *≤* : ∀ {p q} → (↥ p ℕ.* ↧ q) ℕ.≤ (↥ q ℕ.* ↧ p) → p ≤ q -data _<_ : Rel 𝕀 0ℓ where - *<* : ∀ {p q} → (↥ p ℕ.* ↧ q) ℕ.< (↥ q ℕ.* ↧ p) → p < q +data _<_ : Rel 𝕀 0ℓ where + *<* : ∀ {p q} → (↥ p ℕ.* ↧ q) ℕ.< (↥ q ℕ.* ↧ p) → p < q -_≥_ : Rel 𝕀 0ℓ +_≥_ : Rel 𝕀 0ℓ x ≥ y = y ≤ x -_>_ : Rel 𝕀 0ℓ +_>_ : Rel 𝕀 0ℓ x > y = y < x -_≰_ : Rel 𝕀 0ℓ -x ≰ y = ¬ (x ≤ y) +_≰_ : Rel 𝕀 0ℓ +x ≰ y = ¬ (x ≤ y) -_≱_ : Rel 𝕀 0ℓ -x ≱ y = ¬ (x ≥ y) +_≱_ : Rel 𝕀 0ℓ +x ≱ y = ¬ (x ≥ y) -_≮_ : Rel 𝕀 0ℓ -x ≮ y = ¬ (x < y) +_≮_ : Rel 𝕀 0ℓ +x ≮ y = ¬ (x < y) -_≯_ : Rel 𝕀 0ℓ -x ≯ y = ¬ (x > y) +_≯_ : Rel 𝕀 0ℓ +x ≯ y = ¬ (x > y) ------------------------------------------------------------------------ -- Boolean ordering @@ -100,7 +100,7 @@ infix 4 _≤ᵇ_ _≤ᵇ_ : 𝕀 → 𝕀 → Bool -p ≤ᵇ q = (↥ p ℕ.* ↧ q) ℕ.≤ᵇ (↥ q ℕ.* ↧ p) +p ≤ᵇ q = (↥ p ℕ.* ↧ q) ℕ.≤ᵇ (↥ q ℕ.* ↧ p) ------------------------------------------------------------------------ -- Constructing elements of the unit interval @@ -108,38 +108,38 @@ -- A constructor for 𝕀 that takes two natural numbers, say 6 and 21, -- and returns them in a normalized form, e.g. say 2 and 7 -normalize : ∀ (m n : ℕ) .{{_ : ℕ.NonZero n}} .{{_ : m ℕ.≤ n}} → 𝕀 +normalize : ∀ (m n : ℕ) .{{_ : ℕ.NonZero n}} .{{_ : m ℕ.≤ n}} → 𝕀 normalize m n {{_}} {{m≤n}} = - mk𝕀+ (m ℕ./ gcd m n) (n ℕ./ gcd m n) (coprime-/gcd m n) (/-monoˡ-≤ (gcd m n) m≤n) + mk𝕀+ (m ℕ./ gcd m n) (n ℕ./ gcd m n) (coprime-/gcd m n) (/-monoˡ-≤ (gcd m n) m≤n) where instance - g≢0 = ℕ.≢-nonZero (gcd[m,n]≢0 m n (inj₂ (ℕ.≢-nonZero⁻¹ n))) - n/g≢0 = ℕ.≢-nonZero (n/gcd[m,n]≢0 m n {{gcd≢0 = g≢0}}) + g≢0 = ℕ.≢-nonZero (gcd[m,n]≢0 m n (inj₂ (ℕ.≢-nonZero⁻¹ n))) + n/g≢0 = ℕ.≢-nonZero (n/gcd[m,n]≢0 m n {{gcd≢0 = g≢0}}) -- A constructor for 𝕀 that (unlike mk𝕀) automatically normalises its -- arguments. See the constants section below for how to use this operator. infixl 7 _/_ -_/_ : (n : ℕ) (d : ℕ) .{{_ : ℕ.NonZero d}} .{{_ : n ℕ.≤ d}} → 𝕀 +_/_ : (n : ℕ) (d : ℕ) .{{_ : ℕ.NonZero d}} .{{_ : n ℕ.≤ d}} → 𝕀 _/_ = normalize ------------------------------------------------------------------------ -- Conversion to rationals -toℚ : 𝕀 → ℚ +toℚ : 𝕀 → ℚ toℚ (mk𝕀 numerator denominator-1 isCoprime isContained) = - ℚ.mkℚ (+ numerator) denominator-1 isCoprime + ℚ.mkℚ (+ numerator) denominator-1 isCoprime ------------------------------------------------------------------------------ -- Some constants instance - instance-z≤n : ∀ {n} → zero ℕ.≤ n - instance-z≤n = ℕ.z≤n + instance-z≤n : ∀ {n} → zero ℕ.≤ n + instance-z≤n = ℕ.z≤n - instance-s≤s : ∀ {m n} → {{m ℕ.≤ n}} → suc m ℕ.≤ suc n - instance-s≤s {{h}} = ℕ.s≤s h + instance-s≤s : ∀ {m n} → {{m ℕ.≤ n}} → suc m ℕ.≤ suc n + instance-s≤s {{h}} = ℕ.s≤s h 0𝕀 : 𝕀 0𝕀 = 0 / 1 @@ -162,18 +162,18 @@ ------------------------------------------------------------------------ -- Simple predicates -NonZero : Pred 𝕀 0ℓ -NonZero p = ℕ.NonZero (↥ p) +NonZero : Pred 𝕀 0ℓ +NonZero p = ℕ.NonZero (↥ p) -NonOne : Pred 𝕀 0ℓ -NonOne p = ℕ.NonZero (𝕀.denominator-1 p) +NonOne : Pred 𝕀 0ℓ +NonOne p = ℕ.NonZero (𝕀.denominator-1 p) -- Constructors -≢-nonZero : ∀ {p} → p ≢ 0𝕀 → NonZero p +≢-nonZero : ∀ {p} → p ≢ 0𝕀 → NonZero p ≢-nonZero {mk𝕀 (suc _) _ _ _} _ = _ -≢-nonZero {mk𝕀 zero zero _ _} p≢0 = contradiction refl p≢0 -≢-nonZero {mk𝕀 zero (suc _) c _} p≢0 = contradiction (λ {i} → C.recompute c {i}) ¬0-coprimeTo-2+ +≢-nonZero {mk𝕀 zero zero _ _} p≢0 = contradiction refl p≢0 +≢-nonZero {mk𝕀 zero (suc _) c _} p≢0 = contradiction (λ {i} → C.recompute c {i}) ¬0-coprimeTo-2+ >-nonZero : ∀ {p} → p > 0𝕀 → NonZero p >-nonZero {mk𝕀 (suc _) _ _ _} (*<* x) = _ @@ -190,18 +190,18 @@ 1-_ : 𝕀 → 𝕀 1- p@record{isCoprime = isCoprime; isContained = isContained} = - mk𝕀+ (↧ p ℕ.∸ ↥ p) (↧ p) (coprime-∸ isContained isCoprime) (ℕ.m∸n≤m (↧ p) (↥ p)) + mk𝕀+ (↧ p ℕ.∸ ↥ p) (↧ p) (coprime-∸ isContained isCoprime) (ℕ.m∸n≤m (↧ p) (↥ p)) where - ∣m∸n∣m⇒∣n : ∀ i {m n} → n ℕ.≤ m → i ∣ m ℕ.∸ n → i ∣ m → i ∣ n - ∣m∸n∣m⇒∣n i {m} {n} n≤m (divides p m∸n≡p*i) (divides q m≡q*i) = - divides (q ℕ.∸ p) $ begin-equality - n ≡˘⟨ ℕ.m∸[m∸n]≡n n≤m ⟩ - m ℕ.∸ (m ℕ.∸ n) ≡⟨ P.cong₂ ℕ._∸_ m≡q*i m∸n≡p*i ⟩ - q ℕ.* i ℕ.∸ p ℕ.* i ≡˘⟨ ℕ.*-distribʳ-∸ i q p ⟩ - (q ℕ.∸ p) ℕ.* i ∎ - where open ℕ.≤-Reasoning - - coprime-∸ : ∀ {m n} → m ℕ.≤ n → Coprime m n → Coprime (n ℕ.∸ m) n + ∣m∸n∣m⇒∣n : ∀ i {m n} → n ℕ.≤ m → i ∣ m ℕ.∸ n → i ∣ m → i ∣ n + ∣m∸n∣m⇒∣n i {m} {n} n≤m (divides p m∸n≡p*i) (divides q m≡q*i) = + divides (q ℕ.∸ p) $ begin-equality + n ≡˘⟨ ℕ.m∸[m∸n]≡n n≤m ⟩ + m ℕ.∸ (m ℕ.∸ n) ≡⟨ P.cong₂ ℕ._∸_ m≡q*i m∸n≡p*i ⟩ + q ℕ.* i ℕ.∸ p ℕ.* i ≡˘⟨ ℕ.*-distribʳ-∸ i q p ⟩ + (q ℕ.∸ p) ℕ.* i ∎ + where open ℕ.≤-Reasoning + + coprime-∸ : ∀ {m n} → m ℕ.≤ n → Coprime m n → Coprime (n ℕ.∸ m) n coprime-∸ m≤n c (d₁ , d₂) = c (∣m∸n∣m⇒∣n _ m≤n d₁ d₂ , d₂) @@ -212,7 +212,7 @@ (↥ p ℕ.* ↥ q) (↧ p ℕ.* ↧ q) {{_}} - {{ℕ.*-mono-≤ {x = ↥ p} {y = ↧ p} {u = ↥ q} {v = ↧ q} isContained₁ isContained₂}} + {{ℕ.*-mono-≤ {x = ↥ p} {y = ↧ p} {u = ↥ q} {v = ↧ q} isContained₁ isContained₂}} -- disjunction _∨_ : 𝕀 → 𝕀 → 𝕀 @@ -227,16 +227,16 @@ _/_ (↥ p ℕ.* ↧ q) (↥ q ℕ.* ↧ p) - {{ℕ.m*n≢0 (↥ q) (↧ p)}} + {{ℕ.m*n≢0 (↥ q) (↧ p)}} {{h}} -- max _⊔_ : 𝕀 → 𝕀 → 𝕀 -p@record{} ⊔ q@record{} = if p ≤ᵇ q then q else p +p@record{} ⊔ q@record{} = if p ≤ᵇ q then q else p -- min _⊓_ : 𝕀 → 𝕀 → 𝕀 -p@record{} ⊓ q@record{} = if p ≤ᵇ q then p else q +p@record{} ⊓ q@record{} = if p ≤ᵇ q then p else q ------------------------------------------------------------------------ -- Raw bundles diff --git a/Data.List.Base.html b/Data.List.Base.html index 85d04ae9..eff57312 100644 --- a/Data.List.Base.html +++ b/Data.List.Base.html @@ -14,488 +14,561 @@ open import Algebra.Bundles.Raw using (RawMagma; RawMonoid) open import Data.Bool.Base as Bool - using (Bool; false; true; not; _∧_; _∨_; if_then_else_) -open import Data.Fin.Base using (Fin; zero; suc) -open import Data.Maybe.Base as Maybe using (Maybe; nothing; just; maybe′) -open import Data.Nat.Base as ℕ using (ℕ; zero; suc; _+_; _*_ ; _≤_ ; s≤s) -open import Data.Product as Prod using (_×_; _,_; map₁; map₂′) -open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂) -open import Data.These.Base as These using (These; this; that; these) -open import Function.Base using (id; _∘_ ; _∘′_; _∘₂_; const; flip) -open import Level using (Level) -open import Relation.Nullary.Decidable.Core using (does; ¬?) -open import Relation.Unary using (Pred; Decidable) -open import Relation.Binary.Core using (Rel) -import Relation.Binary.Definitions as B -open import Relation.Binary.PropositionalEquality.Core using (_≡_) - -private - variable - a b c p ℓ : Level - A : Set a - B : Set b - C : Set c - ------------------------------------------------------------------------- --- Types - -open import Agda.Builtin.List public - using (List; []; _∷_) - ------------------------------------------------------------------------- --- Operations for transforming lists - -map : (A → B) → List A → List B -map f [] = [] -map f (x ∷ xs) = f x ∷ map f xs - -mapMaybe : (A → Maybe B) → List A → List B -mapMaybe p [] = [] -mapMaybe p (x ∷ xs) with p x -... | just y = y ∷ mapMaybe p xs -... | nothing = mapMaybe p xs - -catMaybes : List (Maybe A) → List A -catMaybes = mapMaybe id - -infixr 5 _++_ - -_++_ : List A → List A → List A -[] ++ ys = ys -(x ∷ xs) ++ ys = x ∷ (xs ++ ys) - -intersperse : A → List A → List A -intersperse x [] = [] -intersperse x (y ∷ []) = y ∷ [] -intersperse x (y ∷ ys) = y ∷ x ∷ intersperse x ys + using (Bool; false; true; not; _∧_; _∨_; if_then_else_) +open import Data.Fin.Base using (Fin; zero; suc) +open import Data.Maybe.Base as Maybe using (Maybe; nothing; just; maybe′) +open import Data.Nat.Base as ℕ using (ℕ; zero; suc; _+_; _*_ ; _≤_ ; s≤s) +open import Data.Product.Base as Prod using (_×_; _,_; map₁; map₂′) +open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂) +open import Data.These.Base as These using (These; this; that; these) +open import Function.Base + using (id; _∘_ ; _∘′_; _∘₂_; _$_; const; flip) +open import Level using (Level) +open import Relation.Unary using (Pred; Decidable) +open import Relation.Binary.Core using (Rel) +import Relation.Binary.Definitions as B +open import Relation.Binary.PropositionalEquality.Core using (_≡_) +open import Relation.Nullary.Decidable.Core using (T?; does; ¬?) + +private + variable + a b c p ℓ : Level + A : Set a + B : Set b + C : Set c + +------------------------------------------------------------------------ +-- Types + +open import Agda.Builtin.List public + using (List; []; _∷_) + +------------------------------------------------------------------------ +-- Operations for transforming lists + +map : (A → B) → List A → List B +map f [] = [] +map f (x ∷ xs) = f x ∷ map f xs + +mapMaybe : (A → Maybe B) → List A → List B +mapMaybe p [] = [] +mapMaybe p (x ∷ xs) with p x +... | just y = y ∷ mapMaybe p xs +... | nothing = mapMaybe p xs + +catMaybes : List (Maybe A) → List A +catMaybes = mapMaybe id + +infixr 5 _++_ + +_++_ : List A → List A → List A +[] ++ ys = ys +(x ∷ xs) ++ ys = x ∷ (xs ++ ys) + +intersperse : A → List A → List A +intersperse x [] = [] +intersperse x (y ∷ []) = y ∷ [] +intersperse x (y ∷ ys) = y ∷ x ∷ intersperse x ys + +intercalate : List A → List (List A) → List A +intercalate xs [] = [] +intercalate xs (ys ∷ []) = ys +intercalate xs (ys ∷ yss) = ys ++ xs ++ intercalate xs yss -intercalate : List A → List (List A) → List A -intercalate xs [] = [] -intercalate xs (ys ∷ []) = ys -intercalate xs (ys ∷ yss) = ys ++ xs ++ intercalate xs yss +cartesianProductWith : (A → B → C) → List A → List B → List C +cartesianProductWith f [] _ = [] +cartesianProductWith f (x ∷ xs) ys = map (f x) ys ++ cartesianProductWith f xs ys -cartesianProductWith : (A → B → C) → List A → List B → List C -cartesianProductWith f [] _ = [] -cartesianProductWith f (x ∷ xs) ys = map (f x) ys ++ cartesianProductWith f xs ys +cartesianProduct : List A → List B → List (A × B) +cartesianProduct = cartesianProductWith _,_ -cartesianProduct : List A → List B → List (A × B) -cartesianProduct = cartesianProductWith _,_ +------------------------------------------------------------------------ +-- Aligning and zipping ------------------------------------------------------------------------- --- Aligning and zipping +alignWith : (These A B → C) → List A → List B → List C +alignWith f [] bs = map (f ∘′ that) bs +alignWith f as [] = map (f ∘′ this) as +alignWith f (a ∷ as) (b ∷ bs) = f (these a b) ∷ alignWith f as bs -alignWith : (These A B → C) → List A → List B → List C -alignWith f [] bs = map (f ∘′ that) bs -alignWith f as [] = map (f ∘′ this) as -alignWith f (a ∷ as) (b ∷ bs) = f (these a b) ∷ alignWith f as bs +zipWith : (A → B → C) → List A → List B → List C +zipWith f (x ∷ xs) (y ∷ ys) = f x y ∷ zipWith f xs ys +zipWith f _ _ = [] -zipWith : (A → B → C) → List A → List B → List C -zipWith f (x ∷ xs) (y ∷ ys) = f x y ∷ zipWith f xs ys -zipWith f _ _ = [] +unalignWith : (A → These B C) → List A → List B × List C +unalignWith f [] = [] , [] +unalignWith f (a ∷ as) with f a +... | this b = Prod.map₁ (b ∷_) (unalignWith f as) +... | that c = Prod.map₂ (c ∷_) (unalignWith f as) +... | these b c = Prod.map (b ∷_) (c ∷_) (unalignWith f as) -unalignWith : (A → These B C) → List A → List B × List C -unalignWith f [] = [] , [] -unalignWith f (a ∷ as) with f a -... | this b = Prod.map₁ (b ∷_) (unalignWith f as) -... | that c = Prod.map₂ (c ∷_) (unalignWith f as) -... | these b c = Prod.map (b ∷_) (c ∷_) (unalignWith f as) +unzipWith : (A → B × C) → List A → List B × List C +unzipWith f [] = [] , [] +unzipWith f (xy ∷ xys) = Prod.zip _∷_ _∷_ (f xy) (unzipWith f xys) -unzipWith : (A → B × C) → List A → List B × List C -unzipWith f [] = [] , [] -unzipWith f (xy ∷ xys) = Prod.zip _∷_ _∷_ (f xy) (unzipWith f xys) +partitionSumsWith : (A → B ⊎ C) → List A → List B × List C +partitionSumsWith f = unalignWith (These.fromSum ∘′ f) -partitionSumsWith : (A → B ⊎ C) → List A → List B × List C -partitionSumsWith f = unalignWith (These.fromSum ∘′ f) +align : List A → List B → List (These A B) +align = alignWith id -align : List A → List B → List (These A B) -align = alignWith id +zip : List A → List B → List (A × B) +zip = zipWith (_,_) -zip : List A → List B → List (A × B) -zip = zipWith (_,_) +unalign : List (These A B) → List A × List B +unalign = unalignWith id -unalign : List (These A B) → List A × List B -unalign = unalignWith id +unzip : List (A × B) → List A × List B +unzip = unzipWith id -unzip : List (A × B) → List A × List B -unzip = unzipWith id +partitionSums : List (A ⊎ B) → List A × List B +partitionSums = partitionSumsWith id -partitionSums : List (A ⊎ B) → List A × List B -partitionSums = partitionSumsWith id +merge : {R : Rel A ℓ} → B.Decidable R → List A → List A → List A +merge R? [] ys = ys +merge R? xs [] = xs +merge R? (x ∷ xs) (y ∷ ys) = if does (R? x y) + then x ∷ merge R? xs (y ∷ ys) + else y ∷ merge R? (x ∷ xs) ys -merge : {R : Rel A ℓ} → B.Decidable R → List A → List A → List A -merge R? [] ys = ys -merge R? xs [] = xs -merge R? (x ∷ xs) (y ∷ ys) = if does (R? x y) - then x ∷ merge R? xs (y ∷ ys) - else y ∷ merge R? (x ∷ xs) ys +------------------------------------------------------------------------ +-- Operations for reducing lists ------------------------------------------------------------------------- --- Operations for reducing lists +foldr : (A → B → B) → B → List A → B +foldr c n [] = n +foldr c n (x ∷ xs) = c x (foldr c n xs) -foldr : (A → B → B) → B → List A → B -foldr c n [] = n -foldr c n (x ∷ xs) = c x (foldr c n xs) +foldl : (A → B → A) → A → List B → A +foldl c n [] = n +foldl c n (x ∷ xs) = foldl c (c n x) xs -foldl : (A → B → A) → A → List B → A -foldl c n [] = n -foldl c n (x ∷ xs) = foldl c (c n x) xs +concat : List (List A) → List A +concat = foldr _++_ [] -concat : List (List A) → List A -concat = foldr _++_ [] +concatMap : (A → List B) → List A → List B +concatMap f = concat ∘ map f -concatMap : (A → List B) → List A → List B -concatMap f = concat ∘ map f +ap : List (A → B) → List A → List B +ap fs as = concatMap (flip map as) fs -ap : List (A → B) → List A → List B -ap fs as = concatMap (flip map as) fs +null : List A → Bool +null [] = true +null (x ∷ xs) = false -null : List A → Bool -null [] = true -null (x ∷ xs) = false +and : List Bool → Bool +and = foldr _∧_ true -and : List Bool → Bool -and = foldr _∧_ true +or : List Bool → Bool +or = foldr _∨_ false -or : List Bool → Bool -or = foldr _∨_ false +any : (A → Bool) → List A → Bool +any p = or ∘ map p -any : (A → Bool) → List A → Bool -any p = or ∘ map p +all : (A → Bool) → List A → Bool +all p = and ∘ map p -all : (A → Bool) → List A → Bool -all p = and ∘ map p +sum : List ℕ → ℕ +sum = foldr _+_ 0 -sum : List ℕ → ℕ -sum = foldr _+_ 0 +product : List ℕ → ℕ +product = foldr _*_ 1 -product : List ℕ → ℕ -product = foldr _*_ 1 +length : List A → ℕ +length = foldr (const suc) 0 -length : List A → ℕ -length = foldr (const suc) 0 +------------------------------------------------------------------------ +-- Operations for constructing lists ------------------------------------------------------------------------- --- Operations for constructing lists +[_] : A → List A +[ x ] = x ∷ [] -[_] : A → List A -[ x ] = x ∷ [] +fromMaybe : Maybe A → List A +fromMaybe (just x) = [ x ] +fromMaybe nothing = [] -fromMaybe : Maybe A → List A -fromMaybe (just x) = [ x ] -fromMaybe nothing = [] +replicate : ℕ → A → List A +replicate zero x = [] +replicate (suc n) x = x ∷ replicate n x -replicate : ℕ → A → List A -replicate zero x = [] -replicate (suc n) x = x ∷ replicate n x +iterate : (A → A) → A → ℕ → List A +iterate f e zero = [] +iterate f e (suc n) = e ∷ iterate f (f e) n -inits : List A → List (List A) -inits [] = [] ∷ [] -inits (x ∷ xs) = [] ∷ map (x ∷_) (inits xs) +inits : List A → List (List A) +inits [] = [] ∷ [] +inits (x ∷ xs) = [] ∷ map (x ∷_) (inits xs) -tails : List A → List (List A) -tails [] = [] ∷ [] -tails (x ∷ xs) = (x ∷ xs) ∷ tails xs +tails : List A → List (List A) +tails [] = [] ∷ [] +tails (x ∷ xs) = (x ∷ xs) ∷ tails xs --- Scans +insertAt : (xs : List A) → Fin (suc (length xs)) → A → List A +insertAt xs zero v = v ∷ xs +insertAt (x ∷ xs) (suc i) v = x ∷ insertAt xs i v -scanr : (A → B → B) → B → List A → List B -scanr f e [] = e ∷ [] -scanr f e (x ∷ xs) with scanr f e xs -... | [] = [] -- dead branch -... | y ∷ ys = f x y ∷ y ∷ ys +updateAt : (xs : List A) → Fin (length xs) → (A → A) → List A +updateAt (x ∷ xs) zero f = f x ∷ xs +updateAt (x ∷ xs) (suc i) f = x ∷ updateAt xs i f -scanl : (A → B → A) → A → List B → List A -scanl f e [] = e ∷ [] -scanl f e (x ∷ xs) = e ∷ scanl f (f e x) xs +-- Scans --- Tabulation +scanr : (A → B → B) → B → List A → List B +scanr f e [] = e ∷ [] +scanr f e (x ∷ xs) with scanr f e xs +... | [] = [] -- dead branch +... | y ∷ ys = f x y ∷ y ∷ ys -applyUpTo : (ℕ → A) → ℕ → List A -applyUpTo f zero = [] -applyUpTo f (suc n) = f zero ∷ applyUpTo (f ∘ suc) n +scanl : (A → B → A) → A → List B → List A +scanl f e [] = e ∷ [] +scanl f e (x ∷ xs) = e ∷ scanl f (f e x) xs -applyDownFrom : (ℕ → A) → ℕ → List A -applyDownFrom f zero = [] -applyDownFrom f (suc n) = f n ∷ applyDownFrom f n +-- Tabulation -tabulate : ∀ {n} (f : Fin n → A) → List A -tabulate {n = zero} f = [] -tabulate {n = suc n} f = f zero ∷ tabulate (f ∘ suc) +applyUpTo : (ℕ → A) → ℕ → List A +applyUpTo f zero = [] +applyUpTo f (suc n) = f zero ∷ applyUpTo (f ∘ suc) n -lookup : ∀ (xs : List A) → Fin (length xs) → A -lookup (x ∷ xs) zero = x -lookup (x ∷ xs) (suc i) = lookup xs i +applyDownFrom : (ℕ → A) → ℕ → List A +applyDownFrom f zero = [] +applyDownFrom f (suc n) = f n ∷ applyDownFrom f n --- Numerical +tabulate : ∀ {n} (f : Fin n → A) → List A +tabulate {n = zero} f = [] +tabulate {n = suc n} f = f zero ∷ tabulate (f ∘ suc) -upTo : ℕ → List ℕ -upTo = applyUpTo id +lookup : ∀ (xs : List A) → Fin (length xs) → A +lookup (x ∷ xs) zero = x +lookup (x ∷ xs) (suc i) = lookup xs i -downFrom : ℕ → List ℕ -downFrom = applyDownFrom id +-- Numerical -allFin : ∀ n → List (Fin n) -allFin n = tabulate id +upTo : ℕ → List ℕ +upTo = applyUpTo id -unfold : ∀ (P : ℕ → Set b) - (f : ∀ {n} → P (suc n) → Maybe (A × P n)) → - ∀ {n} → P n → List A -unfold P f {n = zero} s = [] -unfold P f {n = suc n} s with f s -... | nothing = [] -... | just (x , s′) = x ∷ unfold P f s′ +downFrom : ℕ → List ℕ +downFrom = applyDownFrom id ------------------------------------------------------------------------- --- Operations for reversing lists +allFin : ∀ n → List (Fin n) +allFin n = tabulate id -reverseAcc : List A → List A → List A -reverseAcc = foldl (flip _∷_) +unfold : ∀ (P : ℕ → Set b) + (f : ∀ {n} → P (suc n) → Maybe (A × P n)) → + ∀ {n} → P n → List A +unfold P f {n = zero} s = [] +unfold P f {n = suc n} s with f s +... | nothing = [] +... | just (x , s′) = x ∷ unfold P f s′ -reverse : List A → List A -reverse = reverseAcc [] +------------------------------------------------------------------------ +-- Operations for reversing lists --- "Reverse append" xs ʳ++ ys = reverse xs ++ ys +reverseAcc : List A → List A → List A +reverseAcc = foldl (flip _∷_) -infixr 5 _ʳ++_ +reverse : List A → List A +reverse = reverseAcc [] -_ʳ++_ : List A → List A → List A -_ʳ++_ = flip reverseAcc +-- "Reverse append" xs ʳ++ ys = reverse xs ++ ys --- Snoc: Cons, but from the right. +infixr 5 _ʳ++_ -infixl 6 _∷ʳ_ +_ʳ++_ : List A → List A → List A +_ʳ++_ = flip reverseAcc -_∷ʳ_ : List A → A → List A -xs ∷ʳ x = xs ++ [ x ] +-- Snoc: Cons, but from the right. +infixl 6 _∷ʳ_ +_∷ʳ_ : List A → A → List A +xs ∷ʳ x = xs ++ [ x ] --- Backwards initialisation -infixl 5 _∷ʳ′_ -data InitLast {A : Set a} : List A → Set a where - [] : InitLast [] - _∷ʳ′_ : (xs : List A) (x : A) → InitLast (xs ∷ʳ x) +-- Backwards initialisation -initLast : (xs : List A) → InitLast xs -initLast [] = [] -initLast (x ∷ xs) with initLast xs -... | [] = [] ∷ʳ′ x -... | ys ∷ʳ′ y = (x ∷ ys) ∷ʳ′ y +infixl 5 _∷ʳ′_ --- uncons, but from the right -unsnoc : List A → Maybe (List A × A) -unsnoc as with initLast as -... | [] = nothing -... | xs ∷ʳ′ x = just (xs , x) +data InitLast {A : Set a} : List A → Set a where + [] : InitLast [] + _∷ʳ′_ : (xs : List A) (x : A) → InitLast (xs ∷ʳ x) ------------------------------------------------------------------------- --- Operations for deconstructing lists +initLast : (xs : List A) → InitLast xs +initLast [] = [] +initLast (x ∷ xs) with initLast xs +... | [] = [] ∷ʳ′ x +... | ys ∷ʳ′ y = (x ∷ ys) ∷ʳ′ y --- Note that although the following three combinators can be useful for --- programming, when proving it is often a better idea to manually --- destruct a list argument as each branch of the pattern-matching will --- have a refined type. +-- uncons, but from the right +unsnoc : List A → Maybe (List A × A) +unsnoc as with initLast as +... | [] = nothing +... | xs ∷ʳ′ x = just (xs , x) -uncons : List A → Maybe (A × List A) -uncons [] = nothing -uncons (x ∷ xs) = just (x , xs) +------------------------------------------------------------------------ +-- Operations for deconstructing lists -head : List A → Maybe A -head [] = nothing -head (x ∷ _) = just x +-- Note that although the following three combinators can be useful for +-- programming, when proving it is often a better idea to manually +-- destruct a list argument as each branch of the pattern-matching will +-- have a refined type. -tail : List A → Maybe (List A) -tail [] = nothing -tail (_ ∷ xs) = just xs +uncons : List A → Maybe (A × List A) +uncons [] = nothing +uncons (x ∷ xs) = just (x , xs) -last : List A → Maybe A -last [] = nothing -last (x ∷ []) = just x -last (_ ∷ xs) = last xs +head : List A → Maybe A +head [] = nothing +head (x ∷ _) = just x -take : ℕ → List A → List A -take zero xs = [] -take (suc n) [] = [] -take (suc n) (x ∷ xs) = x ∷ take n xs +tail : List A → Maybe (List A) +tail [] = nothing +tail (_ ∷ xs) = just xs -drop : ℕ → List A → List A -drop zero xs = xs -drop (suc n) [] = [] -drop (suc n) (x ∷ xs) = drop n xs +last : List A → Maybe A +last [] = nothing +last (x ∷ []) = just x +last (_ ∷ xs) = last xs -splitAt : ℕ → List A → List A × List A -splitAt zero xs = ([] , xs) -splitAt (suc n) [] = ([] , []) -splitAt (suc n) (x ∷ xs) = Prod.map₁ (x ∷_) (splitAt n xs) - --- The following are functions which split a list up using boolean --- predicates. However, in practice they are difficult to use and --- prove properties about, and are mainly provided for advanced use --- cases where one wants to minimise dependencies. In most cases --- you probably want to use the versions defined below based on --- decidable predicates. e.g. use `takeWhile (_≤? 10) xs` --- instead of `takeWhileᵇ (_≤ᵇ 10) xs` - -takeWhileᵇ : (A → Bool) → List A → List A -takeWhileᵇ p [] = [] -takeWhileᵇ p (x ∷ xs) = if p x then x ∷ takeWhileᵇ p xs else [] +take : ℕ → List A → List A +take zero xs = [] +take (suc n) [] = [] +take (suc n) (x ∷ xs) = x ∷ take n xs -dropWhileᵇ : (A → Bool) → List A → List A -dropWhileᵇ p [] = [] -dropWhileᵇ p (x ∷ xs) = if p x then dropWhileᵇ p xs else x ∷ xs +drop : ℕ → List A → List A +drop zero xs = xs +drop (suc n) [] = [] +drop (suc n) (x ∷ xs) = drop n xs -filterᵇ : (A → Bool) → List A → List A -filterᵇ p [] = [] -filterᵇ p (x ∷ xs) = if p x then x ∷ filterᵇ p xs else filterᵇ p xs - -partitionᵇ : (A → Bool) → List A → List A × List A -partitionᵇ p [] = ([] , []) -partitionᵇ p (x ∷ xs) = (if p x then Prod.map₁ else Prod.map₂′) (x ∷_) (partitionᵇ p xs) - -spanᵇ : (A → Bool) → List A → List A × List A -spanᵇ p [] = ([] , []) -spanᵇ p (x ∷ xs) = if p x - then Prod.map₁ (x ∷_) (spanᵇ p xs) - else ([] , x ∷ xs) +splitAt : ℕ → List A → List A × List A +splitAt zero xs = ([] , xs) +splitAt (suc n) [] = ([] , []) +splitAt (suc n) (x ∷ xs) = Prod.map₁ (x ∷_) (splitAt n xs) + +removeAt : (xs : List A) → Fin (length xs) → List A +removeAt (x ∷ xs) zero = xs +removeAt (x ∷ xs) (suc i) = x ∷ removeAt xs i + +------------------------------------------------------------------------ +-- Operations for filtering lists + +-- The following are a variety of functions that can be used to +-- construct sublists using a predicate. +-- +-- Each function has two forms. The first main variant uses a +-- proof-relevant decidable predicate, while the second variant uses +-- a irrelevant boolean predicate and are suffixed with a `ᵇ` character, +-- typed as \^b. +-- +-- The decidable versions have several advantages: 1) easier to prove +-- properties, 2) better meta-variable inference and 3) most of the rest +-- of the library is set-up to work with decidable predicates. However, +-- in rare cases the boolean versions can be useful, mainly when one +-- wants to minimise dependencies. +-- +-- In summary, in most cases you probably want to use the decidable +-- versions over the boolean versions, e.g. use `takeWhile (_≤? 10) xs` +-- rather than `takeWhileᵇ (_≤ᵇ 10) xs`. + +takeWhile : ∀ {P : Pred A p} → Decidable P → List A → List A +takeWhile P? [] = [] +takeWhile P? (x ∷ xs) with does (P? x) +... | true = x ∷ takeWhile P? xs +... | false = [] + +takeWhileᵇ : (A → Bool) → List A → List A +takeWhileᵇ p = takeWhile (T? ∘ p) + +dropWhile : ∀ {P : Pred A p} → Decidable P → List A → List A +dropWhile P? [] = [] +dropWhile P? (x ∷ xs) with does (P? x) +... | true = dropWhile P? xs +... | false = x ∷ xs + +dropWhileᵇ : (A → Bool) → List A → List A +dropWhileᵇ p = dropWhile (T? ∘ p) + +filter : ∀ {P : Pred A p} → Decidable P → List A → List A +filter P? [] = [] +filter P? (x ∷ xs) with does (P? x) +... | false = filter P? xs +... | true = x ∷ filter P? xs + +filterᵇ : (A → Bool) → List A → List A +filterᵇ p = filter (T? ∘ p) + +partition : ∀ {P : Pred A p} → Decidable P → List A → (List A × List A) +partition P? [] = ([] , []) +partition P? (x ∷ xs) with does (P? x) | partition P? xs +... | true | (ys , zs) = (x ∷ ys , zs) +... | false | (ys , zs) = (ys , x ∷ zs) + +partitionᵇ : (A → Bool) → List A → List A × List A +partitionᵇ p = partition (T? ∘ p) + +span : ∀ {P : Pred A p} → Decidable P → List A → (List A × List A) +span P? [] = ([] , []) +span P? ys@(x ∷ xs) with does (P? x) +... | true = Prod.map (x ∷_) id (span P? xs) +... | false = ([] , ys) + + +spanᵇ : (A → Bool) → List A → List A × List A +spanᵇ p = span (T? ∘ p) + +break : ∀ {P : Pred A p} → Decidable P → List A → (List A × List A) +break P? = span (¬? ∘ P?) + +breakᵇ : (A → Bool) → List A → List A × List A +breakᵇ p = break (T? ∘ p) + +-- The predicate `P` represents the notion of newline character for the +-- type `A`. It is used to split the input list into a list of lines. +-- Some lines may be empty if the input contains at least two +-- consecutive newline characters. +linesBy : ∀ {P : Pred A p} → Decidable P → List A → List (List A) +linesBy {A = A} P? = go nothing where + + go : Maybe (List A) → List A → List (List A) + go acc [] = maybe′ ([_] ∘′ reverse) [] acc + go acc (c ∷ cs) with does (P? c) + ... | true = reverse (Maybe.fromMaybe [] acc) ∷ go nothing cs + ... | false = go (just (c ∷ Maybe.fromMaybe [] acc)) cs + +linesByᵇ : (A → Bool) → List A → List (List A) +linesByᵇ p = linesBy (T? ∘ p) + +-- The predicate `P` represents the notion of space character for the +-- type `A`. It is used to split the input list into a list of words. +-- All the words are non empty and the output does not contain any space +-- characters. +wordsBy : ∀ {P : Pred A p} → Decidable P → List A → List (List A) +wordsBy {A = A} P? = go [] where + + cons : List A → List (List A) → List (List A) + cons [] ass = ass + cons as ass = reverse as ∷ ass + + go : List A → List A → List (List A) + go acc [] = cons acc [] + go acc (c ∷ cs) with does (P? c) + ... | true = cons acc (go [] cs) + ... | false = go (c ∷ acc) cs + +wordsByᵇ : (A → Bool) → List A → List (List A) +wordsByᵇ p = wordsBy (T? ∘ p) + +derun : ∀ {R : Rel A p} → B.Decidable R → List A → List A +derun R? [] = [] +derun R? (x ∷ []) = x ∷ [] +derun R? (x ∷ xs@(y ∷ _)) with does (R? x y) | derun R? xs +... | true | ys = ys +... | false | ys = x ∷ ys + +derunᵇ : (A → A → Bool) → List A → List A +derunᵇ r = derun (T? ∘₂ r) + +deduplicate : ∀ {R : Rel A p} → B.Decidable R → List A → List A +deduplicate R? [] = [] +deduplicate R? (x ∷ xs) = x ∷ filter (¬? ∘ R? x) (deduplicate R? xs) + +deduplicateᵇ : (A → A → Bool) → List A → List A +deduplicateᵇ r = deduplicate (T? ∘₂ r) + +-- Finds the first element satisfying the boolean predicate +find : ∀ {P : Pred A p} → Decidable P → List A → Maybe A +find P? [] = nothing +find P? (x ∷ xs) = if does (P? x) then just x else find P? xs + +findᵇ : (A → Bool) → List A → Maybe A +findᵇ p = find (T? ∘ p) + +-- Finds the index of the first element satisfying the boolean predicate +findIndex : ∀ {P : Pred A p} → Decidable P → (xs : List A) → Maybe $ Fin (length xs) +findIndex P? [] = nothing +findIndex P? (x ∷ xs) = if does (P? x) + then just zero + else Maybe.map suc (findIndex P? xs) + +findIndexᵇ : (A → Bool) → (xs : List A) → Maybe $ Fin (length xs) +findIndexᵇ p = findIndex (T? ∘ p) + +-- Finds indices of all the elements satisfying the boolean predicate +findIndices : ∀ {P : Pred A p} → Decidable P → (xs : List A) → List $ Fin (length xs) +findIndices P? [] = [] +findIndices P? (x ∷ xs) = if does (P? x) + then zero ∷ indices + else indices + where indices = map suc (findIndices P? xs) + +findIndicesᵇ : (A → Bool) → (xs : List A) → List $ Fin (length xs) +findIndicesᵇ p = findIndices (T? ∘ p) + +------------------------------------------------------------------------ +-- Actions on single elements + +infixl 5 _[_]%=_ _[_]∷=_ + +-- xs [ i ]%= f modifies the i-th element of xs according to f + +_[_]%=_ : (xs : List A) → Fin (length xs) → (A → A) → List A +xs [ i ]%= f = updateAt xs i f + +-- xs [ i ]≔ y overwrites the i-th element of xs with y + +_[_]∷=_ : (xs : List A) → Fin (length xs) → A → List A +xs [ k ]∷= v = xs [ k ]%= const v + +------------------------------------------------------------------------ +-- Conditional versions of cons and snoc + +infixr 5 _?∷_ +_?∷_ : Maybe A → List A → List A +_?∷_ = maybe′ _∷_ id + +infixl 6 _∷ʳ?_ +_∷ʳ?_ : List A → Maybe A → List A +xs ∷ʳ? x = maybe′ (xs ∷ʳ_) xs x + +------------------------------------------------------------------------ +-- Raw algebraic bundles + +module _ (A : Set a) where + ++-rawMagma : RawMagma a _ + ++-rawMagma = record + { Carrier = List A + ; _≈_ = _≡_ + ; _∙_ = _++_ + } + + ++-[]-rawMonoid : RawMonoid a _ + ++-[]-rawMonoid = record + { Carrier = List A + ; _≈_ = _≡_ + ; _∙_ = _++_ + ; ε = [] + } + +------------------------------------------------------------------------ +-- DEPRECATED +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 1.4 + +infixl 5 _∷ʳ'_ +_∷ʳ'_ : (xs : List A) (x : A) → InitLast (xs ∷ʳ x) +_∷ʳ'_ = InitLast._∷ʳ′_ +{-# WARNING_ON_USAGE _∷ʳ'_ +"Warning: _∷ʳ'_ (ending in an apostrophe) was deprecated in v1.4. +Please use _∷ʳ′_ (ending in a prime) instead." +#-} -breakᵇ : (A → Bool) → List A → List A × List A -breakᵇ p = spanᵇ (not ∘ p) - -linesByᵇ : (A → Bool) → List A → List (List A) -linesByᵇ {A = A} p = go nothing - where - go : Maybe (List A) → List A → List (List A) - go acc [] = maybe′ ([_] ∘′ reverse) [] acc - go acc (c ∷ cs) with p c - ... | true = reverse (Maybe.fromMaybe [] acc) ∷ go nothing cs - ... | false = go (just (c ∷ Maybe.fromMaybe [] acc)) cs - -wordsByᵇ : (A → Bool) → List A → List (List A) -wordsByᵇ {A = A} p = go [] - where - cons : List A → List (List A) → List (List A) - cons [] ass = ass - cons as ass = reverse as ∷ ass - - go : List A → List A → List (List A) - go acc [] = cons acc [] - go acc (c ∷ cs) with p c - ... | true = cons acc (go [] cs) - ... | false = go (c ∷ acc) cs - -derunᵇ : (A → A → Bool) → List A → List A -derunᵇ r [] = [] -derunᵇ r (x ∷ []) = x ∷ [] -derunᵇ r (x ∷ y ∷ xs) = if r x y - then derunᵇ r (y ∷ xs) - else x ∷ derunᵇ r (y ∷ xs) - -deduplicateᵇ : (A → A → Bool) → List A → List A -deduplicateᵇ r [] = [] -deduplicateᵇ r (x ∷ xs) = x ∷ filterᵇ (not ∘ r x) (deduplicateᵇ r xs) - --- Equivalent functions that use a decidable predicate instead of a --- boolean function. - -takeWhile : ∀ {P : Pred A p} → Decidable P → List A → List A -takeWhile P? = takeWhileᵇ (does ∘ P?) - -dropWhile : ∀ {P : Pred A p} → Decidable P → List A → List A -dropWhile P? = dropWhileᵇ (does ∘ P?) - -filter : ∀ {P : Pred A p} → Decidable P → List A → List A -filter P? = filterᵇ (does ∘ P?) - -partition : ∀ {P : Pred A p} → Decidable P → List A → (List A × List A) -partition P? = partitionᵇ (does ∘ P?) - -span : ∀ {P : Pred A p} → Decidable P → List A → (List A × List A) -span P? = spanᵇ (does ∘ P?) - -break : ∀ {P : Pred A p} → Decidable P → List A → (List A × List A) -break P? = breakᵇ (does ∘ P?) - --- The predicate `P` represents the notion of newline character for the --- type `A`. It is used to split the input list into a list of lines. --- Some lines may be empty if the input contains at least two --- consecutive newline characters. -linesBy : ∀ {P : Pred A p} → Decidable P → List A → List (List A) -linesBy P? = linesByᵇ (does ∘ P?) - --- The predicate `P` represents the notion of space character for the --- type `A`. It is used to split the input list into a list of words. --- All the words are non empty and the output does not contain any space --- characters. -wordsBy : ∀ {P : Pred A p} → Decidable P → List A → List (List A) -wordsBy P? = wordsByᵇ (does ∘ P?) - -derun : ∀ {R : Rel A p} → B.Decidable R → List A → List A -derun R? = derunᵇ (does ∘₂ R?) - -deduplicate : ∀ {R : Rel A p} → B.Decidable R → List A → List A -deduplicate R? = deduplicateᵇ (does ∘₂ R?) - ------------------------------------------------------------------------- --- Actions on single elements - -infixl 5 _[_]%=_ _[_]∷=_ _─_ - -_[_]%=_ : (xs : List A) → Fin (length xs) → (A → A) → List A -(x ∷ xs) [ zero ]%= f = f x ∷ xs -(x ∷ xs) [ suc k ]%= f = x ∷ (xs [ k ]%= f) - -_[_]∷=_ : (xs : List A) → Fin (length xs) → A → List A -xs [ k ]∷= v = xs [ k ]%= const v - -_─_ : (xs : List A) → Fin (length xs) → List A -(x ∷ xs) ─ zero = xs -(x ∷ xs) ─ suc k = x ∷ (xs ─ k) - ------------------------------------------------------------------------- --- Conditional versions of cons and snoc - -infixr 5 _?∷_ -_?∷_ : Maybe A → List A → List A -_?∷_ = maybe′ _∷_ id - -infixl 6 _∷ʳ?_ -_∷ʳ?_ : List A → Maybe A → List A -xs ∷ʳ? x = maybe′ (xs ∷ʳ_) xs x - ------------------------------------------------------------------------- --- Raw algebraic bundles - -module _ (A : Set a) where - ++-rawMagma : RawMagma a _ - ++-rawMagma = record - { Carrier = List A - ; _≈_ = _≡_ - ; _∙_ = _++_ - } - - ++-[]-rawMonoid : RawMonoid a _ - ++-[]-rawMonoid = record - { Carrier = List A - ; _≈_ = _≡_ - ; _∙_ = _++_ - ; ε = [] - } - ------------------------------------------------------------------------- --- DEPRECATED ------------------------------------------------------------------------- --- Please use the new names as continuing support for the old names is --- not guaranteed. - --- Version 1.4 +-- Version 2.0 -infixl 5 _∷ʳ'_ -_∷ʳ'_ : (xs : List A) (x : A) → InitLast (xs ∷ʳ x) -_∷ʳ'_ = InitLast._∷ʳ′_ -{-# WARNING_ON_USAGE _∷ʳ'_ -"Warning: _∷ʳ'_ (ending in an apostrophe) was deprecated in v1.4. -Please use _∷ʳ′_ (ending in a prime) instead." -#-} +infixl 5 _─_ +_─_ = removeAt +{-# WARNING_ON_USAGE _─_ +"Warning: _─_ was deprecated in v2.0. +Please use removeAt instead." +#-} \ No newline at end of file diff --git a/Data.List.Effectful.html b/Data.List.Effectful.html index b9901ade..8f1c3b19 100644 --- a/Data.List.Effectful.html +++ b/Data.List.Effectful.html @@ -20,287 +20,291 @@ open import Function.Base open import Level open import Relation.Binary.PropositionalEquality as P - using (_≡_; _≢_; _≗_; refl) -open P.≡-Reasoning + using (_≡_; _≢_; _≗_; refl) +open P.≡-Reasoning private variable ℓ : Level + A : Set ℓ ------------------------------------------------------------------------- --- List applicative functor +------------------------------------------------------------------------ +-- List applicative functor -functor : RawFunctor {ℓ} List -functor = record { _<$>_ = map } +functor : RawFunctor {ℓ} List +functor = record { _<$>_ = map } -applicative : RawApplicative {ℓ} List -applicative = record - { rawFunctor = functor - ; pure = [_] - ; _<*>_ = ap - } +applicative : RawApplicative {ℓ} List +applicative = record + { rawFunctor = functor + ; pure = [_] + ; _<*>_ = ap + } -empty : RawEmpty {ℓ} List -empty = record { empty = [] } +empty : RawEmpty {ℓ} List +empty = record { empty = [] } -choice : RawChoice {ℓ} List -choice = record { _<|>_ = _++_ } +choice : RawChoice {ℓ} List +choice = record { _<|>_ = _++_ } -applicativeZero : RawApplicativeZero {ℓ} List -applicativeZero = record - { rawApplicative = applicative - ; rawEmpty = empty - } +applicativeZero : RawApplicativeZero {ℓ} List +applicativeZero = record + { rawApplicative = applicative + ; rawEmpty = empty + } -alternative : RawAlternative {ℓ} List -alternative = record - { rawApplicativeZero = applicativeZero - ; rawChoice = choice - } - ------------------------------------------------------------------------- --- List monad +alternative : RawAlternative {ℓ} List +alternative = record + { rawApplicativeZero = applicativeZero + ; rawChoice = choice + } + +------------------------------------------------------------------------ +-- List monad + +monad : ∀ {ℓ} → RawMonad {ℓ} List +monad = record + { rawApplicative = applicative + ; _>>=_ = flip concatMap + } -monad : ∀ {ℓ} → RawMonad {ℓ} List -monad = record - { rawApplicative = applicative - ; _>>=_ = flip concatMap - } - -monadZero : ∀ {ℓ} → RawMonadZero {ℓ} List -monadZero = record - { rawMonad = monad - ; rawEmpty = empty - } +join : List (List A) → List A +join = Join.join monad + +monadZero : ∀ {ℓ} → RawMonadZero {ℓ} List +monadZero = record + { rawMonad = monad + ; rawEmpty = empty + } -monadPlus : ∀ {ℓ} → RawMonadPlus {ℓ} List -monadPlus = record - { rawMonadZero = monadZero - ; rawChoice = choice - } +monadPlus : ∀ {ℓ} → RawMonadPlus {ℓ} List +monadPlus = record + { rawMonadZero = monadZero + ; rawChoice = choice + } ------------------------------------------------------------------------- --- Get access to other monadic functions +------------------------------------------------------------------------ +-- Get access to other monadic functions -module TraversableA {f g F} (App : RawApplicative {f} {g} F) where +module TraversableA {f g F} (App : RawApplicative {f} {g} F) where - open RawApplicative App + open RawApplicative App - sequenceA : ∀ {A} → List (F A) → F (List A) - sequenceA [] = pure [] - sequenceA (x ∷ xs) = _∷_ <$> x <*> sequenceA xs + sequenceA : ∀ {A} → List (F A) → F (List A) + sequenceA [] = pure [] + sequenceA (x ∷ xs) = _∷_ <$> x <*> sequenceA xs - mapA : ∀ {a} {A : Set a} {B} → (A → F B) → List A → F (List B) - mapA f = sequenceA ∘ map f + mapA : ∀ {a} {A : Set a} {B} → (A → F B) → List A → F (List B) + mapA f = sequenceA ∘ map f - forA : ∀ {a} {A : Set a} {B} → List A → (A → F B) → F (List B) - forA = flip mapA + forA : ∀ {a} {A : Set a} {B} → List A → (A → F B) → F (List B) + forA = flip mapA -module TraversableM {m n M} (Mon : RawMonad {m} {n} M) where +module TraversableM {m n M} (Mon : RawMonad {m} {n} M) where - open RawMonad Mon + open RawMonad Mon - open TraversableA rawApplicative public - renaming - ( sequenceA to sequenceM - ; mapA to mapM - ; forA to forM - ) + open TraversableA rawApplicative public + renaming + ( sequenceA to sequenceM + ; mapA to mapM + ; forA to forM + ) ------------------------------------------------------------------------- --- The list monad. - -private - open module LMP {ℓ} = RawMonadPlus (monadPlus {ℓ = ℓ}) - -module MonadProperties where - - left-identity : ∀ {ℓ} {A B : Set ℓ} (x : A) (f : A → List B) → - (pure x >>= f) ≡ f x - left-identity x f = ++-identityʳ (f x) - - right-identity : ∀ {ℓ} {A : Set ℓ} (xs : List A) → - (xs >>= pure) ≡ xs - right-identity [] = refl - right-identity (x ∷ xs) = P.cong (x ∷_) (right-identity xs) - - left-zero : ∀ {ℓ} {A B : Set ℓ} (f : A → List B) → (∅ >>= f) ≡ ∅ - left-zero f = refl - - right-zero : ∀ {ℓ} {A B : Set ℓ} (xs : List A) → - (xs >>= const ∅) ≡ ∅ {A = B} - right-zero [] = refl - right-zero (x ∷ xs) = right-zero xs - - private - - not-left-distributive : - let xs = true ∷ false ∷ []; f = pure; g = pure in - (xs >>= λ x → f x ∣ g x) ≢ ((xs >>= f) ∣ (xs >>= g)) - not-left-distributive () - - right-distributive : ∀ {ℓ} {A B : Set ℓ} - (xs ys : List A) (f : A → List B) → - (xs ∣ ys >>= f) ≡ ((xs >>= f) ∣ (ys >>= f)) - right-distributive [] ys f = refl - right-distributive (x ∷ xs) ys f = begin - f x ∣ (xs ∣ ys >>= f) ≡⟨ P.cong (f x ∣_) $ right-distributive xs ys f ⟩ - f x ∣ ((xs >>= f) ∣ (ys >>= f)) ≡⟨ P.sym $ ++-assoc (f x) _ _ ⟩ - ((f x ∣ (xs >>= f)) ∣ (ys >>= f)) ∎ - - associative : ∀ {ℓ} {A B C : Set ℓ} - (xs : List A) (f : A → List B) (g : B → List C) → - (xs >>= λ x → f x >>= g) ≡ (xs >>= f >>= g) - associative [] f g = refl - associative (x ∷ xs) f g = begin - (f x >>= g) ∣ (xs >>= λ x → f x >>= g) ≡⟨ P.cong ((f x >>= g) ∣_) $ associative xs f g ⟩ - (f x >>= g) ∣ (xs >>= f >>= g) ≡⟨ P.sym $ right-distributive (f x) (xs >>= f) g ⟩ - (f x ∣ (xs >>= f) >>= g) ∎ - - cong : ∀ {ℓ} {A B : Set ℓ} {xs₁ xs₂} {f₁ f₂ : A → List B} → - xs₁ ≡ xs₂ → f₁ ≗ f₂ → (xs₁ >>= f₁) ≡ (xs₂ >>= f₂) - cong {xs₁ = xs} refl f₁≗f₂ = P.cong concat (map-cong f₁≗f₂ xs) - ------------------------------------------------------------------------- --- The applicative functor derived from the list monad. - --- Note that these proofs (almost) show that RawIMonad.rawIApplicative --- is correctly defined. The proofs can be reused if proof components --- are ever added to RawIMonad and RawIApplicative. - -module Applicative where - - private - - module MP = MonadProperties - - -- A variant of flip map. - - pam : ∀ {ℓ} {A B : Set ℓ} → List A → (A → B) → List B - pam xs f = xs >>= pure ∘ f - - -- ∅ is a left zero for _⊛_. - - left-zero : ∀ {ℓ} {A B : Set ℓ} → (xs : List A) → (∅ ⊛ xs) ≡ ∅ {A = B} - left-zero xs = begin - ∅ ⊛ xs ≡⟨⟩ - (∅ >>= pam xs) ≡⟨ MonadProperties.left-zero (pam xs) ⟩ - ∅ ∎ - - -- ∅ is a right zero for _⊛_. - - right-zero : ∀ {ℓ} {A B : Set ℓ} → (fs : List (A → B)) → (fs ⊛ ∅) ≡ ∅ - right-zero {ℓ} fs = begin - fs ⊛ ∅ ≡⟨⟩ - (fs >>= pam ∅) ≡⟨ (MP.cong (refl {x = fs}) λ f → - MP.left-zero (pure ∘ f)) ⟩ - (fs >>= λ _ → ∅) ≡⟨ MP.right-zero fs ⟩ - ∅ ∎ - - unfold-<$> : ∀ {ℓ} {A B : Set ℓ} → (f : A → B) (as : List A) → - (f <$> as) ≡ (pure f ⊛ as) - unfold-<$> f as = P.sym (++-identityʳ (f <$> as)) - - -- _⊛_ unfolds to binds. - unfold-⊛ : ∀ {ℓ} {A B : Set ℓ} → (fs : List (A → B)) (as : List A) → - (fs ⊛ as) ≡ (fs >>= pam as) - unfold-⊛ fs as = begin - fs ⊛ as - ≡˘⟨ concatMap-cong (λ f → P.cong (map f) (concatMap-pure as)) fs ⟩ - concatMap (λ f → map f (concatMap pure as)) fs - ≡⟨ concatMap-cong (λ f → map-concatMap f pure as) fs ⟩ - concatMap (λ f → concatMap (λ x → pure (f x)) as) fs - ≡⟨⟩ - (fs >>= pam as) - ∎ - - -- _⊛_ distributes over _∣_ from the right. - - right-distributive : ∀ {ℓ} {A B : Set ℓ} (fs₁ fs₂ : List (A → B)) xs → - ((fs₁ ∣ fs₂) ⊛ xs) ≡ (fs₁ ⊛ xs ∣ fs₂ ⊛ xs) - right-distributive fs₁ fs₂ xs = begin - (fs₁ ∣ fs₂) ⊛ xs ≡⟨ unfold-⊛ (fs₁ ∣ fs₂) xs ⟩ - (fs₁ ∣ fs₂ >>= pam xs) ≡⟨ MonadProperties.right-distributive fs₁ fs₂ (pam xs) ⟩ - (fs₁ >>= pam xs) ∣ (fs₂ >>= pam xs) ≡˘⟨ P.cong₂ _∣_ (unfold-⊛ fs₁ xs) (unfold-⊛ fs₂ xs) ⟩ - (fs₁ ⊛ xs ∣ fs₂ ⊛ xs) ∎ - - -- _⊛_ does not distribute over _∣_ from the left. - - private - - not-left-distributive : - let fs = id ∷ id ∷ []; xs₁ = true ∷ []; xs₂ = true ∷ false ∷ [] in - (fs ⊛ (xs₁ ∣ xs₂)) ≢ (fs ⊛ xs₁ ∣ fs ⊛ xs₂) - not-left-distributive () - - -- Applicative functor laws. - - identity : ∀ {a} {A : Set a} (xs : List A) → (pure id ⊛ xs) ≡ xs - identity xs = begin - pure id ⊛ xs ≡⟨ unfold-⊛ (pure id) xs ⟩ - (pure id >>= pam xs) ≡⟨ MonadProperties.left-identity id (pam xs) ⟩ - (xs >>= pure) ≡⟨ MonadProperties.right-identity xs ⟩ - xs ∎ - - private - - pam-lemma : ∀ {ℓ} {A B C : Set ℓ} - (xs : List A) (f : A → B) (fs : B → List C) → - (pam xs f >>= fs) ≡ (xs >>= λ x → fs (f x)) - pam-lemma xs f fs = begin - (pam xs f >>= fs) ≡˘⟨ MP.associative xs (pure ∘ f) fs ⟩ - (xs >>= λ x → pure (f x) >>= fs) ≡⟨ MP.cong (refl {x = xs}) (λ x → MP.left-identity (f x) fs) ⟩ - (xs >>= λ x → fs (f x)) ∎ - - composition : ∀ {ℓ} {A B C : Set ℓ} - (fs : List (B → C)) (gs : List (A → B)) xs → - (pure _∘′_ ⊛ fs ⊛ gs ⊛ xs) ≡ (fs ⊛ (gs ⊛ xs)) - composition {ℓ} fs gs xs = begin - pure _∘′_ ⊛ fs ⊛ gs ⊛ xs - ≡⟨ unfold-⊛ (pure _∘′_ ⊛ fs ⊛ gs) xs ⟩ - (pure _∘′_ ⊛ fs ⊛ gs >>= pam xs) - ≡⟨ P.cong (_>>= pam xs) (unfold-⊛ (pure _∘′_ ⊛ fs) gs) ⟩ - (pure _∘′_ ⊛ fs >>= pam gs >>= pam xs) - ≡⟨ P.cong (λ h → h >>= pam gs >>= pam xs) (unfold-⊛ (pure _∘′_) fs) ⟩ - (pure _∘′_ >>= pam fs >>= pam gs >>= pam xs) - ≡⟨ MP.cong (MP.cong (MP.left-identity _∘′_ (pam fs)) - (λ f → refl {x = pam gs f})) - (λ fg → refl {x = pam xs fg}) ⟩ - (pam fs _∘′_ >>= pam gs >>= pam xs) - ≡⟨ MP.cong (pam-lemma fs _∘′_ (pam gs)) (λ _ → refl) ⟩ - ((fs >>= λ f → pam gs (f ∘′_)) >>= pam xs) - ≡˘⟨ MP.associative fs (λ f → pam gs (_∘′_ f)) (pam xs) ⟩ - (fs >>= λ f → pam gs (f ∘′_) >>= pam xs) - ≡⟨ MP.cong (refl {x = fs}) (λ f → pam-lemma gs (f ∘′_) (pam xs)) ⟩ - (fs >>= λ f → gs >>= λ g → pam xs (f ∘′ g)) - ≡⟨ (MP.cong (refl {x = fs}) λ f → - MP.cong (refl {x = gs}) λ g → - P.sym $ pam-lemma xs g (pure ∘ f)) ⟩ - (fs >>= λ f → gs >>= λ g → pam (pam xs g) f) - ≡⟨ MP.cong (refl {x = fs}) (λ f → MP.associative gs (pam xs) (pure ∘ f)) ⟩ - (fs >>= pam (gs >>= pam xs)) - ≡˘⟨ unfold-⊛ fs (gs >>= pam xs) ⟩ - fs ⊛ (gs >>= pam xs) - ≡˘⟨ P.cong (fs ⊛_) (unfold-⊛ gs xs) ⟩ - fs ⊛ (gs ⊛ xs) - ∎ - - homomorphism : ∀ {ℓ} {A B : Set ℓ} (f : A → B) x → - (pure f ⊛ pure x) ≡ pure (f x) - homomorphism f x = begin - pure f ⊛ pure x ≡⟨⟩ - (pure f >>= pam (pure x)) ≡⟨ MP.left-identity f (pam (pure x)) ⟩ - pam (pure x) f ≡⟨ MP.left-identity x (pure ∘ f) ⟩ - pure (f x) ∎ - - interchange : ∀ {ℓ} {A B : Set ℓ} (fs : List (A → B)) {x} → - (fs ⊛ pure x) ≡ (pure (_$′ x) ⊛ fs) - interchange fs {x} = begin - fs ⊛ pure x ≡⟨⟩ - (fs >>= pam (pure x)) ≡⟨ (MP.cong (refl {x = fs}) λ f → - MP.left-identity x (pure ∘ f)) ⟩ - (fs >>= λ f → pure (f x)) ≡⟨⟩ - (pam fs (_$′ x)) ≡⟨ P.sym $ MP.left-identity (_$′ x) (pam fs) ⟩ - (pure (_$′ x) >>= pam fs) ≡˘⟨ unfold-⊛ (pure (_$′ x)) fs ⟩ - pure (_$′ x) ⊛ fs ∎ +------------------------------------------------------------------------ +-- The list monad. + +private + open module LMP {ℓ} = RawMonadPlus (monadPlus {ℓ = ℓ}) + +module MonadProperties where + + left-identity : ∀ {ℓ} {A B : Set ℓ} (x : A) (f : A → List B) → + (pure x >>= f) ≡ f x + left-identity x f = ++-identityʳ (f x) + + right-identity : ∀ {ℓ} {A : Set ℓ} (xs : List A) → + (xs >>= pure) ≡ xs + right-identity [] = refl + right-identity (x ∷ xs) = P.cong (x ∷_) (right-identity xs) + + left-zero : ∀ {ℓ} {A B : Set ℓ} (f : A → List B) → (∅ >>= f) ≡ ∅ + left-zero f = refl + + right-zero : ∀ {ℓ} {A B : Set ℓ} (xs : List A) → + (xs >>= const ∅) ≡ ∅ {A = B} + right-zero [] = refl + right-zero (x ∷ xs) = right-zero xs + + private + + not-left-distributive : + let xs = true ∷ false ∷ []; f = pure; g = pure in + (xs >>= λ x → f x ∣ g x) ≢ ((xs >>= f) ∣ (xs >>= g)) + not-left-distributive () + + right-distributive : ∀ {ℓ} {A B : Set ℓ} + (xs ys : List A) (f : A → List B) → + (xs ∣ ys >>= f) ≡ ((xs >>= f) ∣ (ys >>= f)) + right-distributive [] ys f = refl + right-distributive (x ∷ xs) ys f = begin + f x ∣ (xs ∣ ys >>= f) ≡⟨ P.cong (f x ∣_) $ right-distributive xs ys f ⟩ + f x ∣ ((xs >>= f) ∣ (ys >>= f)) ≡⟨ P.sym $ ++-assoc (f x) _ _ ⟩ + ((f x ∣ (xs >>= f)) ∣ (ys >>= f)) ∎ + + associative : ∀ {ℓ} {A B C : Set ℓ} + (xs : List A) (f : A → List B) (g : B → List C) → + (xs >>= λ x → f x >>= g) ≡ (xs >>= f >>= g) + associative [] f g = refl + associative (x ∷ xs) f g = begin + (f x >>= g) ∣ (xs >>= λ x → f x >>= g) ≡⟨ P.cong ((f x >>= g) ∣_) $ associative xs f g ⟩ + (f x >>= g) ∣ (xs >>= f >>= g) ≡⟨ P.sym $ right-distributive (f x) (xs >>= f) g ⟩ + (f x ∣ (xs >>= f) >>= g) ∎ + + cong : ∀ {ℓ} {A B : Set ℓ} {xs₁ xs₂} {f₁ f₂ : A → List B} → + xs₁ ≡ xs₂ → f₁ ≗ f₂ → (xs₁ >>= f₁) ≡ (xs₂ >>= f₂) + cong {xs₁ = xs} refl f₁≗f₂ = P.cong concat (map-cong f₁≗f₂ xs) + +------------------------------------------------------------------------ +-- The applicative functor derived from the list monad. + +-- Note that these proofs (almost) show that RawIMonad.rawIApplicative +-- is correctly defined. The proofs can be reused if proof components +-- are ever added to RawIMonad and RawIApplicative. + +module Applicative where + + private + + module MP = MonadProperties + + -- A variant of flip map. + + pam : ∀ {ℓ} {A B : Set ℓ} → List A → (A → B) → List B + pam xs f = xs >>= pure ∘ f + + -- ∅ is a left zero for _⊛_. + + left-zero : ∀ {ℓ} {A B : Set ℓ} → (xs : List A) → (∅ ⊛ xs) ≡ ∅ {A = B} + left-zero xs = begin + ∅ ⊛ xs ≡⟨⟩ + (∅ >>= pam xs) ≡⟨ MonadProperties.left-zero (pam xs) ⟩ + ∅ ∎ + + -- ∅ is a right zero for _⊛_. + + right-zero : ∀ {ℓ} {A B : Set ℓ} → (fs : List (A → B)) → (fs ⊛ ∅) ≡ ∅ + right-zero {ℓ} fs = begin + fs ⊛ ∅ ≡⟨⟩ + (fs >>= pam ∅) ≡⟨ (MP.cong (refl {x = fs}) λ f → + MP.left-zero (pure ∘ f)) ⟩ + (fs >>= λ _ → ∅) ≡⟨ MP.right-zero fs ⟩ + ∅ ∎ + + unfold-<$> : ∀ {ℓ} {A B : Set ℓ} → (f : A → B) (as : List A) → + (f <$> as) ≡ (pure f ⊛ as) + unfold-<$> f as = P.sym (++-identityʳ (f <$> as)) + + -- _⊛_ unfolds to binds. + unfold-⊛ : ∀ {ℓ} {A B : Set ℓ} → (fs : List (A → B)) (as : List A) → + (fs ⊛ as) ≡ (fs >>= pam as) + unfold-⊛ fs as = begin + fs ⊛ as + ≡⟨ concatMap-cong (λ f → P.cong (map f) (concatMap-pure as)) fs ⟨ + concatMap (λ f → map f (concatMap pure as)) fs + ≡⟨ concatMap-cong (λ f → map-concatMap f pure as) fs ⟩ + concatMap (λ f → concatMap (λ x → pure (f x)) as) fs + ≡⟨⟩ + (fs >>= pam as) + ∎ + + -- _⊛_ distributes over _∣_ from the right. + + right-distributive : ∀ {ℓ} {A B : Set ℓ} (fs₁ fs₂ : List (A → B)) xs → + ((fs₁ ∣ fs₂) ⊛ xs) ≡ (fs₁ ⊛ xs ∣ fs₂ ⊛ xs) + right-distributive fs₁ fs₂ xs = begin + (fs₁ ∣ fs₂) ⊛ xs ≡⟨ unfold-⊛ (fs₁ ∣ fs₂) xs ⟩ + (fs₁ ∣ fs₂ >>= pam xs) ≡⟨ MonadProperties.right-distributive fs₁ fs₂ (pam xs) ⟩ + (fs₁ >>= pam xs) ∣ (fs₂ >>= pam xs) ≡⟨ P.cong₂ _∣_ (unfold-⊛ fs₁ xs) (unfold-⊛ fs₂ xs) ⟨ + (fs₁ ⊛ xs ∣ fs₂ ⊛ xs) ∎ + + -- _⊛_ does not distribute over _∣_ from the left. + + private + + not-left-distributive : + let fs = id ∷ id ∷ []; xs₁ = true ∷ []; xs₂ = true ∷ false ∷ [] in + (fs ⊛ (xs₁ ∣ xs₂)) ≢ (fs ⊛ xs₁ ∣ fs ⊛ xs₂) + not-left-distributive () + + -- Applicative functor laws. + + identity : ∀ {a} {A : Set a} (xs : List A) → (pure id ⊛ xs) ≡ xs + identity xs = begin + pure id ⊛ xs ≡⟨ unfold-⊛ (pure id) xs ⟩ + (pure id >>= pam xs) ≡⟨ MonadProperties.left-identity id (pam xs) ⟩ + (xs >>= pure) ≡⟨ MonadProperties.right-identity xs ⟩ + xs ∎ + + private + + pam-lemma : ∀ {ℓ} {A B C : Set ℓ} + (xs : List A) (f : A → B) (fs : B → List C) → + (pam xs f >>= fs) ≡ (xs >>= λ x → fs (f x)) + pam-lemma xs f fs = begin + (pam xs f >>= fs) ≡⟨ MP.associative xs (pure ∘ f) fs ⟨ + (xs >>= λ x → pure (f x) >>= fs) ≡⟨ MP.cong (refl {x = xs}) (λ x → MP.left-identity (f x) fs) ⟩ + (xs >>= λ x → fs (f x)) ∎ + + composition : ∀ {ℓ} {A B C : Set ℓ} + (fs : List (B → C)) (gs : List (A → B)) xs → + (pure _∘′_ ⊛ fs ⊛ gs ⊛ xs) ≡ (fs ⊛ (gs ⊛ xs)) + composition {ℓ} fs gs xs = begin + pure _∘′_ ⊛ fs ⊛ gs ⊛ xs + ≡⟨ unfold-⊛ (pure _∘′_ ⊛ fs ⊛ gs) xs ⟩ + (pure _∘′_ ⊛ fs ⊛ gs >>= pam xs) + ≡⟨ P.cong (_>>= pam xs) (unfold-⊛ (pure _∘′_ ⊛ fs) gs) ⟩ + (pure _∘′_ ⊛ fs >>= pam gs >>= pam xs) + ≡⟨ P.cong (λ h → h >>= pam gs >>= pam xs) (unfold-⊛ (pure _∘′_) fs) ⟩ + (pure _∘′_ >>= pam fs >>= pam gs >>= pam xs) + ≡⟨ MP.cong (MP.cong (MP.left-identity _∘′_ (pam fs)) + (λ f → refl {x = pam gs f})) + (λ fg → refl {x = pam xs fg}) ⟩ + (pam fs _∘′_ >>= pam gs >>= pam xs) + ≡⟨ MP.cong (pam-lemma fs _∘′_ (pam gs)) (λ _ → refl) ⟩ + ((fs >>= λ f → pam gs (f ∘′_)) >>= pam xs) + ≡⟨ MP.associative fs (λ f → pam gs (_∘′_ f)) (pam xs) ⟨ + (fs >>= λ f → pam gs (f ∘′_) >>= pam xs) + ≡⟨ MP.cong (refl {x = fs}) (λ f → pam-lemma gs (f ∘′_) (pam xs)) ⟩ + (fs >>= λ f → gs >>= λ g → pam xs (f ∘′ g)) + ≡⟨ (MP.cong (refl {x = fs}) λ f → + MP.cong (refl {x = gs}) λ g → + P.sym $ pam-lemma xs g (pure ∘ f)) ⟩ + (fs >>= λ f → gs >>= λ g → pam (pam xs g) f) + ≡⟨ MP.cong (refl {x = fs}) (λ f → MP.associative gs (pam xs) (pure ∘ f)) ⟩ + (fs >>= pam (gs >>= pam xs)) + ≡⟨ unfold-⊛ fs (gs >>= pam xs) ⟨ + fs ⊛ (gs >>= pam xs) + ≡⟨ P.cong (fs ⊛_) (unfold-⊛ gs xs) ⟨ + fs ⊛ (gs ⊛ xs) + ∎ + + homomorphism : ∀ {ℓ} {A B : Set ℓ} (f : A → B) x → + (pure f ⊛ pure x) ≡ pure (f x) + homomorphism f x = begin + pure f ⊛ pure x ≡⟨⟩ + (pure f >>= pam (pure x)) ≡⟨ MP.left-identity f (pam (pure x)) ⟩ + pam (pure x) f ≡⟨ MP.left-identity x (pure ∘ f) ⟩ + pure (f x) ∎ + + interchange : ∀ {ℓ} {A B : Set ℓ} (fs : List (A → B)) {x} → + (fs ⊛ pure x) ≡ (pure (_$′ x) ⊛ fs) + interchange fs {x} = begin + fs ⊛ pure x ≡⟨⟩ + (fs >>= pam (pure x)) ≡⟨ (MP.cong (refl {x = fs}) λ f → + MP.left-identity x (pure ∘ f)) ⟩ + (fs >>= λ f → pure (f x)) ≡⟨⟩ + (pam fs (_$′ x)) ≡⟨ P.sym $ MP.left-identity (_$′ x) (pam fs) ⟩ + (pure (_$′ x) >>= pam fs) ≡⟨ unfold-⊛ (pure (_$′ x)) fs ⟨ + pure (_$′ x) ⊛ fs ∎ \ No newline at end of file diff --git a/Data.List.Extrema.Core.html b/Data.List.Extrema.Core.html deleted file mode 100644 index 9a82c641..00000000 --- a/Data.List.Extrema.Core.html +++ /dev/null @@ -1,122 +0,0 @@ - -Data.List.Extrema.Core
------------------------------------------------------------------------
--- The Agda standard library
---
--- Core lemmas needed to make list argmin/max functions work
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-open import Relation.Binary using (Trans; TotalOrder; Setoid)
-
-module Data.List.Extrema.Core
-  {b ℓ₁ ℓ₂} (totalOrder : TotalOrder b ℓ₁ ℓ₂) where
-
-open import Algebra.Core
-open import Algebra.Definitions
-import Algebra.Construct.NaturalChoice.Min as Min
-import Algebra.Construct.NaturalChoice.Max as Max
-open import Data.Product using (_×_; _,_)
-open import Data.Sum.Base using (_⊎_; inj₁; inj₂)
-open import Level using (Level)
-open import Relation.Binary.PropositionalEquality using (_≡_)
-
-open import Algebra.Construct.LiftedChoice
-
-open TotalOrder totalOrder renaming (Carrier to B)
-open import Relation.Binary.Construct.NonStrictToStrict _≈_ _≤_
-  using (_<_; <-≤-trans; ≤-<-trans)
-
-------------------------------------------------------------------------
--- Setup
-
--- open NonStrictToStrict totalOrder using (_<_; ≤-<-trans; <-≤-trans)
-
-open Max totalOrder
-open Min totalOrder
-
-private
-
-  variable
-    a : Level
-    A : Set a
-
-  <-transʳ : Trans _≤_ _<_ _<_
-  <-transʳ = ≤-<-trans trans antisym ≤-respˡ-≈
-
-  <-transˡ : Trans _<_ _≤_ _<_
-  <-transˡ = <-≤-trans Eq.sym trans antisym ≤-respʳ-≈
-
-  module _ (f : A → B) where
-
-    lemma₁ : ∀ {x y v} → f x ≤ v → f x ⊓ f y ≈ f y → f y ≤ v
-    lemma₁ fx≤v fx⊓fy≈fy = trans (x⊓y≈y⇒y≤x fx⊓fy≈fy) fx≤v
-
-    lemma₂ : ∀ {x y v} → f y ≤ v → f x ⊓ f y ≈ f x → f x ≤ v
-    lemma₂ fy≤v fx⊓fy≈fx = trans (x⊓y≈x⇒x≤y fx⊓fy≈fx) fy≤v
-
-    lemma₃ : ∀ {x y v} → f x < v → f x ⊓ f y ≈ f y → f y < v
-    lemma₃ fx<v fx⊓fy≈fy = <-transʳ (x⊓y≈y⇒y≤x fx⊓fy≈fy) fx<v
-
-    lemma₄ : ∀ {x y v} → f y < v → f x ⊓ f y ≈ f x → f x < v
-    lemma₄ fx<v fx⊓fy≈fy = <-transʳ (x⊓y≈x⇒x≤y fx⊓fy≈fy) fx<v
-
-------------------------------------------------------------------------
--- Definition of lifted max and min
-
-⊓ᴸ : (A → B) → Op₂ A
-⊓ᴸ = Lift _≈_ _⊓_ ⊓-sel
-
-⊔ᴸ : (A → B) → Op₂ A
-⊔ᴸ = Lift _≈_ _⊔_ ⊔-sel
-
-------------------------------------------------------------------------
--- Properties of ⊓ᴸ
-
-⊓ᴸ-sel : ∀ f → Selective {A = A} _≡_ (⊓ᴸ f)
-⊓ᴸ-sel f = sel-≡ ⊓-isSelectiveMagma f
-
-⊓ᴸ-presᵒ-≤v : ∀ f {v} (x y : A) → f x ≤ v ⊎ f y ≤ v → f (⊓ᴸ f x y) ≤ v
-⊓ᴸ-presᵒ-≤v f = preservesᵒ ⊓-isSelectiveMagma f (lemma₁ f) (lemma₂ f)
-
-⊓ᴸ-presᵒ-<v : ∀ f {v} (x y : A) → f x < v ⊎ f y < v → f (⊓ᴸ f x y) < v
-⊓ᴸ-presᵒ-<v f = preservesᵒ ⊓-isSelectiveMagma f (lemma₃ f) (lemma₄ f)
-
-⊓ᴸ-presᵇ-v≤ : ∀ f {v} {x y : A} → v ≤ f x → v ≤ f y → v ≤ f (⊓ᴸ f x y)
-⊓ᴸ-presᵇ-v≤ f {v} = preservesᵇ ⊓-isSelectiveMagma {P = λ x → v ≤ f x} f
-
-⊓ᴸ-presᵇ-v< : ∀ f {v} {x y : A} → v < f x → v < f y → v < f (⊓ᴸ f x y)
-⊓ᴸ-presᵇ-v< f {v} = preservesᵇ ⊓-isSelectiveMagma {P = λ x → v < f x} f
-
-⊓ᴸ-forcesᵇ-v≤ : ∀ f {v} (x y : A) → v ≤ f (⊓ᴸ f x y) → v ≤ f x × v ≤ f y
-⊓ᴸ-forcesᵇ-v≤ f {v} = forcesᵇ ⊓-isSelectiveMagma f
-  (λ v≤fx fx⊓fy≈fx → trans v≤fx (x⊓y≈x⇒x≤y fx⊓fy≈fx))
-  (λ v≤fy fx⊓fy≈fy → trans v≤fy (x⊓y≈y⇒y≤x fx⊓fy≈fy))
-
-------------------------------------------------------------------------
--- Properties of ⊔ᴸ
-
-⊔ᴸ-sel : ∀ f → Selective {A = A} _≡_ (⊔ᴸ f)
-⊔ᴸ-sel f = sel-≡ ⊔-isSelectiveMagma f
-
-⊔ᴸ-presᵒ-v≤ : ∀ f {v} (x y : A) → v ≤ f x ⊎ v ≤ f y → v ≤ f (⊔ᴸ f x y)
-⊔ᴸ-presᵒ-v≤ f {v} = preservesᵒ ⊔-isSelectiveMagma f
-  (λ v≤fx fx⊔fy≈fy → trans v≤fx (x⊔y≈y⇒x≤y fx⊔fy≈fy))
-  (λ v≤fy fx⊔fy≈fx → trans v≤fy (x⊔y≈x⇒y≤x fx⊔fy≈fx))
-
-⊔ᴸ-presᵒ-v< : ∀ f {v} (x y : A) → v < f x ⊎ v < f y → v < f (⊔ᴸ f x y)
-⊔ᴸ-presᵒ-v< f {v} = preservesᵒ ⊔-isSelectiveMagma f
-  (λ v<fx fx⊔fy≈fy → <-transˡ v<fx (x⊔y≈y⇒x≤y fx⊔fy≈fy))
-  (λ v<fy fx⊔fy≈fx → <-transˡ v<fy (x⊔y≈x⇒y≤x fx⊔fy≈fx))
-
-⊔ᴸ-presᵇ-≤v : ∀ f {v} {x y : A} → f x ≤ v → f y ≤ v → f (⊔ᴸ f x y) ≤ v
-⊔ᴸ-presᵇ-≤v f {v} = preservesᵇ ⊔-isSelectiveMagma {P = λ x → f x ≤ v} f
-
-⊔ᴸ-presᵇ-<v : ∀ f {v} {x y : A} → f x < v → f y < v → f (⊔ᴸ f x y) < v
-⊔ᴸ-presᵇ-<v f {v} = preservesᵇ ⊔-isSelectiveMagma {P = λ x → f x < v} f
-
-⊔ᴸ-forcesᵇ-≤v : ∀ f {v} (x y : A) → f (⊔ᴸ f x y) ≤ v → f x ≤ v × f y ≤ v
-⊔ᴸ-forcesᵇ-≤v f {v} = forcesᵇ ⊔-isSelectiveMagma f
-  (λ fx≤v fx⊔fy≈fx → trans (x⊔y≈x⇒y≤x fx⊔fy≈fx) fx≤v)
-  (λ fy≤v fx⊔fy≈fy → trans (x⊔y≈y⇒x≤y fx⊔fy≈fy) fy≤v)
-
\ No newline at end of file diff --git a/Data.List.Extrema.html b/Data.List.Extrema.html deleted file mode 100644 index 798878df..00000000 --- a/Data.List.Extrema.html +++ /dev/null @@ -1,249 +0,0 @@ - -Data.List.Extrema
------------------------------------------------------------------------
--- The Agda standard library
---
--- Finding the maximum/minimum values in a list
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-open import Relation.Binary using (TotalOrder; Setoid)
-
-module Data.List.Extrema
-  {b ℓ₁ ℓ₂} (totalOrder : TotalOrder b ℓ₁ ℓ₂) where
-
-import Algebra.Construct.NaturalChoice.Min as Min
-import Algebra.Construct.NaturalChoice.Max as Max
-open import Data.List.Base using (List; foldr)
-open import Data.List.Relation.Unary.Any as Any using (Any; here; there)
-open import Data.List.Relation.Unary.All using (All; []; _∷_; lookup; map; tabulate)
-open import Data.List.Membership.Propositional using (_∈_; lose)
-open import Data.List.Membership.Propositional.Properties
-  using (foldr-selective)
-open import Data.List.Relation.Binary.Subset.Propositional using (_⊆_; _⊇_)
-open import Data.List.Properties
-open import Data.Sum.Base using (_⊎_; inj₁; inj₂)
-open import Function.Base using (id; flip; _on_; _∘_)
-open import Level using (Level)
-open import Relation.Unary using (Pred)
-import Relation.Binary.Construct.NonStrictToStrict as NonStrictToStrict
-open import Relation.Binary.PropositionalEquality.Core
-  using (_≡_; sym; subst) renaming (refl to ≡-refl)
-import Relation.Binary.Construct.On as On
-
-------------------------------------------------------------------------------
--- Setup
-
-open TotalOrder totalOrder renaming (Carrier to B)
-open NonStrictToStrict _≈_ _≤_ using (_<_)
-open import Data.List.Extrema.Core totalOrder
-  renaming (⊓ᴸ to ⊓-lift; ⊔ᴸ to ⊔-lift)
-
-private
-  variable
-    a p : Level
-    A : Set a
-
-------------------------------------------------------------------------------
--- Functions
-
-argmin : (A → B) → A → List A → A
-argmin f = foldr (⊓-lift f)
-
-argmax : (A → B) → A → List A → A
-argmax f = foldr (⊔-lift f)
-
-min : B → List B → B
-min = argmin id
-
-max : B → List B → B
-max = argmax id
-
-------------------------------------------------------------------------------
--- Properties of argmin
-
-module _ {f : A → B} where
-
-  f[argmin]≤v⁺ : ∀ {v} ⊤ xs → (f ⊤ ≤ v) ⊎ (Any (λ x → f x ≤ v) xs) →
-                f (argmin f ⊤ xs) ≤ v
-  f[argmin]≤v⁺ = foldr-preservesᵒ (⊓ᴸ-presᵒ-≤v f)
-
-  f[argmin]<v⁺ : ∀ {v} ⊤ xs → (f ⊤ < v) ⊎ (Any (λ x → f x < v) xs) →
-                f (argmin f ⊤ xs) < v
-  f[argmin]<v⁺ = foldr-preservesᵒ (⊓ᴸ-presᵒ-<v f)
-
-  v≤f[argmin]⁺ : ∀ {v ⊤ xs} → v ≤ f ⊤ → All (λ x → v ≤ f x) xs →
-                v ≤ f (argmin f ⊤ xs)
-  v≤f[argmin]⁺ = foldr-preservesᵇ (⊓ᴸ-presᵇ-v≤ f)
-
-  v<f[argmin]⁺ : ∀ {v ⊤ xs} → v < f ⊤ → All (λ x → v < f x) xs →
-                v < f (argmin f ⊤ xs)
-  v<f[argmin]⁺ = foldr-preservesᵇ (⊓ᴸ-presᵇ-v< f)
-
-  f[argmin]≤f[⊤] : ∀ ⊤ xs → f (argmin f ⊤ xs) ≤ f ⊤
-  f[argmin]≤f[⊤] ⊤ xs = f[argmin]≤v⁺ ⊤ xs (inj₁ refl)
-
-  f[argmin]≤f[xs] : ∀ ⊤ xs → All (λ x → f (argmin f ⊤ xs) ≤ f x) xs
-  f[argmin]≤f[xs] ⊤ xs = foldr-forcesᵇ (⊓ᴸ-forcesᵇ-v≤ f) ⊤ xs refl
-
-  f[argmin]≈f[v]⁺ : ∀ {v ⊤ xs} → v ∈ xs → All (λ x → f v ≤ f x) xs → f v ≤ f ⊤ →
-                    f (argmin f ⊤ xs) ≈ f v
-  f[argmin]≈f[v]⁺ v∈xs fv≤fxs fv≤f⊤ = antisym
-    (f[argmin]≤v⁺ _ _ (inj₂ (lose v∈xs refl)))
-    (v≤f[argmin]⁺ fv≤f⊤ fv≤fxs)
-
-argmin[xs]≤argmin[ys]⁺ : ∀ {f g : A → B} ⊤₁ {⊤₂} xs {ys : List A} →
-                        (f ⊤₁ ≤ g ⊤₂) ⊎ Any (λ x → f x ≤ g ⊤₂) xs →
-                        All (λ y → (f ⊤₁ ≤ g y) ⊎ Any (λ x → f x ≤ g y) xs) ys →
-                        f (argmin f ⊤₁ xs) ≤ g (argmin g ⊤₂ ys)
-argmin[xs]≤argmin[ys]⁺ ⊤₁ xs xs≤⊤₂ xs≤ys =
-  v≤f[argmin]⁺ (f[argmin]≤v⁺ ⊤₁ _ xs≤⊤₂) (map (f[argmin]≤v⁺ ⊤₁ xs) xs≤ys)
-
-argmin[xs]<argmin[ys]⁺ : ∀ {f g : A → B} ⊤₁ {⊤₂} xs {ys : List A} →
-                        (f ⊤₁ < g ⊤₂) ⊎ Any (λ x → f x < g ⊤₂) xs →
-                        All (λ y → (f ⊤₁ < g y) ⊎ Any (λ x → f x < g y) xs) ys →
-                        f (argmin f ⊤₁ xs) < g (argmin g ⊤₂ ys)
-argmin[xs]<argmin[ys]⁺ ⊤₁ xs xs<⊤₂ xs<ys =
-  v<f[argmin]⁺ (f[argmin]<v⁺ ⊤₁ _ xs<⊤₂) (map (f[argmin]<v⁺ ⊤₁ xs) xs<ys)
-
-argmin-sel : ∀ (f : A → B) ⊤ xs → (argmin f ⊤ xs ≡ ⊤) ⊎ (argmin f ⊤ xs ∈ xs)
-argmin-sel f = foldr-selective (⊓ᴸ-sel f)
-
-argmin-all : ∀ (f : A → B) {⊤ xs} {P : Pred A p} →
-             P ⊤ → All P xs → P (argmin f ⊤ xs)
-argmin-all f {⊤} {xs} {P = P}  p⊤ pxs with argmin-sel f ⊤ xs
-... | inj₁ argmin≡⊤  = subst P (sym argmin≡⊤) p⊤
-... | inj₂ argmin∈xs = lookup pxs argmin∈xs
-
-------------------------------------------------------------------------------
--- Properties of argmax
-
-module _ {f : A → B} where
-
-  v≤f[argmax]⁺ : ∀ {v} ⊥ xs → (v ≤ f ⊥) ⊎ (Any (λ x → v ≤ f x) xs) →
-                v ≤ f (argmax f ⊥ xs)
-  v≤f[argmax]⁺ = foldr-preservesᵒ (⊔ᴸ-presᵒ-v≤ f)
-
-  v<f[argmax]⁺ : ∀ {v} ⊥ xs → (v < f ⊥) ⊎ (Any (λ x → v < f x) xs) →
-                v < f (argmax f ⊥ xs)
-  v<f[argmax]⁺ = foldr-preservesᵒ (⊔ᴸ-presᵒ-v< f)
-
-  f[argmax]≤v⁺ : ∀ {v ⊥ xs} → f ⊥ ≤ v → All (λ x → f x ≤ v) xs →
-                f (argmax f ⊥ xs) ≤ v
-  f[argmax]≤v⁺ = foldr-preservesᵇ (⊔ᴸ-presᵇ-≤v f)
-
-  f[argmax]<v⁺ : ∀ {v ⊥ xs} → f ⊥ < v → All (λ x → f x < v) xs →
-                f (argmax f ⊥ xs) < v
-  f[argmax]<v⁺ = foldr-preservesᵇ (⊔ᴸ-presᵇ-<v f)
-
-  f[⊥]≤f[argmax] : ∀ ⊥ xs → f ⊥ ≤ f (argmax f ⊥ xs)
-  f[⊥]≤f[argmax] ⊥ xs = v≤f[argmax]⁺ ⊥ xs (inj₁ refl)
-
-  f[xs]≤f[argmax] : ∀ ⊥ xs → All (λ x → f x ≤ f (argmax f ⊥ xs)) xs
-  f[xs]≤f[argmax] ⊥ xs = foldr-forcesᵇ (⊔ᴸ-forcesᵇ-≤v f) ⊥ xs refl
-
-  f[argmax]≈f[v]⁺ : ∀ {v ⊥ xs} → v ∈ xs → All (λ x → f x ≤ f v) xs → f ⊥ ≤ f v →
-                    f (argmax f ⊥ xs) ≈ f v
-  f[argmax]≈f[v]⁺ v∈xs fxs≤fv f⊥≤fv = antisym
-    (f[argmax]≤v⁺ f⊥≤fv fxs≤fv)
-    (v≤f[argmax]⁺ _ _ (inj₂ (lose v∈xs refl)))
-
-argmax[xs]≤argmax[ys]⁺ : ∀ {f g : A → B} {⊥₁} ⊥₂ {xs : List A} ys →
-                         (f ⊥₁ ≤ g ⊥₂) ⊎ Any (λ y → f ⊥₁ ≤ g y) ys →
-                         All (λ x → (f x ≤ g ⊥₂) ⊎ Any (λ y → f x ≤ g y) ys) xs →
-                         f (argmax f ⊥₁ xs) ≤ g (argmax g ⊥₂ ys)
-argmax[xs]≤argmax[ys]⁺ ⊥₂ ys ⊥₁≤ys xs≤ys =
-  f[argmax]≤v⁺ (v≤f[argmax]⁺ ⊥₂ _ ⊥₁≤ys) (map (v≤f[argmax]⁺ ⊥₂ ys) xs≤ys)
-
-argmax[xs]<argmax[ys]⁺ : ∀ {f g : A → B} {⊥₁} ⊥₂ {xs : List A} ys →
-                         (f ⊥₁ < g ⊥₂) ⊎ Any (λ y → f ⊥₁ < g y) ys →
-                         All (λ x → (f x < g ⊥₂) ⊎ Any (λ y → f x < g y) ys) xs →
-                         f (argmax f ⊥₁ xs) < g (argmax g ⊥₂ ys)
-argmax[xs]<argmax[ys]⁺ ⊥₂ ys ⊥₁<ys xs<ys =
-  f[argmax]<v⁺ (v<f[argmax]⁺ ⊥₂ _ ⊥₁<ys) (map (v<f[argmax]⁺ ⊥₂ ys) xs<ys)
-
-argmax-sel : ∀ (f : A → B) ⊥ xs → (argmax f ⊥ xs ≡ ⊥) ⊎ (argmax f ⊥ xs ∈ xs)
-argmax-sel f = foldr-selective (⊔ᴸ-sel f)
-
-argmax-all : ∀ (f : A → B) {P : Pred A p} {⊥ xs} →
-             P ⊥ → All P xs → P (argmax f ⊥ xs)
-argmax-all f {P = P} {⊥} {xs} p⊥ pxs with argmax-sel f ⊥ xs
-... | inj₁ argmax≡⊥  = subst P (sym argmax≡⊥) p⊥
-... | inj₂ argmax∈xs = lookup pxs argmax∈xs
-
-------------------------------------------------------------------------------
--- Properties of min
-
-min≤v⁺ : ∀ {v} ⊤ xs → ⊤ ≤ v ⊎ Any (_≤ v) xs → min ⊤ xs ≤ v
-min≤v⁺ = f[argmin]≤v⁺
-
-min<v⁺ : ∀ {v} ⊤ xs → ⊤ < v ⊎ Any (_< v) xs → min ⊤ xs < v
-min<v⁺ = f[argmin]<v⁺
-
-v≤min⁺ : ∀ {v ⊤ xs} → v ≤ ⊤ → All (v ≤_) xs → v ≤ min ⊤ xs
-v≤min⁺ = v≤f[argmin]⁺
-
-v<min⁺ : ∀ {v ⊤ xs} → v < ⊤ → All (v <_) xs → v < min ⊤ xs
-v<min⁺ = v<f[argmin]⁺
-
-min≤⊤ : ∀ ⊤ xs → min ⊤ xs ≤ ⊤
-min≤⊤ = f[argmin]≤f[⊤]
-
-min≤xs : ∀ ⊥ xs → All (min ⊥ xs ≤_) xs
-min≤xs = f[argmin]≤f[xs]
-
-min≈v⁺ : ∀ {v ⊤ xs} → v ∈ xs → All (v ≤_) xs → v ≤ ⊤ → min ⊤ xs ≈ v
-min≈v⁺ = f[argmin]≈f[v]⁺
-
-min[xs]≤min[ys]⁺ : ∀ ⊤₁ {⊤₂} xs {ys} → (⊤₁ ≤ ⊤₂) ⊎ Any (_≤ ⊤₂) xs →
-                   All (λ y → (⊤₁ ≤ y) ⊎ Any (λ x → x ≤ y) xs) ys →
-                   min ⊤₁ xs ≤ min ⊤₂ ys
-min[xs]≤min[ys]⁺ = argmin[xs]≤argmin[ys]⁺
-
-min[xs]<min[ys]⁺ : ∀ ⊤₁ {⊤₂} xs {ys} → (⊤₁ < ⊤₂) ⊎ Any (_< ⊤₂) xs →
-                   All (λ y → (⊤₁ < y) ⊎ Any (λ x → x < y) xs) ys →
-                   min ⊤₁ xs < min ⊤₂ ys
-min[xs]<min[ys]⁺ = argmin[xs]<argmin[ys]⁺
-
-min-mono-⊆ : ∀ {⊥₁ ⊥₂ xs ys} → ⊥₁ ≤ ⊥₂ → xs ⊇ ys → min ⊥₁ xs ≤ min ⊥₂ ys
-min-mono-⊆ ⊥₁≤⊥₂ ys⊆xs = min[xs]≤min[ys]⁺ _ _ (inj₁ ⊥₁≤⊥₂)
-  (tabulate (inj₂ ∘ Any.map (λ {≡-refl → refl}) ∘ ys⊆xs))
-
-------------------------------------------------------------------------------
--- Properties of max
-
-max≤v⁺ : ∀ {v ⊥ xs} → ⊥ ≤ v → All (_≤ v) xs → max ⊥ xs ≤ v
-max≤v⁺ = f[argmax]≤v⁺
-
-max<v⁺ : ∀ {v ⊥ xs} → ⊥ < v → All (_< v) xs → max ⊥ xs < v
-max<v⁺ = f[argmax]<v⁺
-
-v≤max⁺ : ∀ {v} ⊥ xs → v ≤ ⊥ ⊎ Any (v ≤_) xs → v ≤ max ⊥ xs
-v≤max⁺ = v≤f[argmax]⁺
-
-v<max⁺ : ∀ {v} ⊥ xs → v < ⊥ ⊎ Any (v <_) xs → v < max ⊥ xs
-v<max⁺ = v<f[argmax]⁺
-
-⊥≤max : ∀ ⊥ xs → ⊥ ≤ max ⊥ xs
-⊥≤max = f[⊥]≤f[argmax]
-
-xs≤max : ∀ ⊥ xs → All (_≤ max ⊥ xs) xs
-xs≤max = f[xs]≤f[argmax]
-
-max≈v⁺ : ∀ {v ⊤ xs} → v ∈ xs → All (_≤ v) xs → ⊤ ≤ v → max ⊤ xs ≈ v
-max≈v⁺ = f[argmax]≈f[v]⁺
-
-max[xs]≤max[ys]⁺ : ∀ {⊥₁} ⊥₂ {xs} ys → ⊥₁ ≤ ⊥₂ ⊎ Any (⊥₁ ≤_) ys →
-                   All (λ x → x ≤ ⊥₂ ⊎ Any (x ≤_) ys) xs →
-                   max ⊥₁ xs ≤ max ⊥₂ ys
-max[xs]≤max[ys]⁺ = argmax[xs]≤argmax[ys]⁺
-
-max[xs]<max[ys]⁺ : ∀ {⊥₁} ⊥₂ {xs} ys → ⊥₁ < ⊥₂ ⊎ Any (⊥₁ <_) ys →
-                   All (λ x → x < ⊥₂ ⊎ Any (x <_) ys) xs →
-                   max ⊥₁ xs < max ⊥₂ ys
-max[xs]<max[ys]⁺ = argmax[xs]<argmax[ys]⁺
-
-max-mono-⊆ : ∀ {⊥₁ ⊥₂ xs ys} → ⊥₁ ≤ ⊥₂ → xs ⊆ ys → max ⊥₁ xs ≤ max ⊥₂ ys
-max-mono-⊆ ⊥₁≤⊥₂ xs⊆ys = max[xs]≤max[ys]⁺ _ _ (inj₁ ⊥₁≤⊥₂)
-  (tabulate (inj₂ ∘ Any.map (λ {≡-refl → refl}) ∘ xs⊆ys))
-
\ No newline at end of file diff --git a/Data.List.Membership.DecPropositional.html b/Data.List.Membership.DecPropositional.html deleted file mode 100644 index 940b7d92..00000000 --- a/Data.List.Membership.DecPropositional.html +++ /dev/null @@ -1,22 +0,0 @@ - -Data.List.Membership.DecPropositional
------------------------------------------------------------------------
--- The Agda standard library
---
--- Decidable propositional membership over lists
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-open import Relation.Binary using (Decidable)
-open import Relation.Binary.PropositionalEquality using (_≡_; decSetoid)
-
-module Data.List.Membership.DecPropositional
-  {a} {A : Set a} (_≟_ : Decidable (_≡_ {A = A})) where
-
-------------------------------------------------------------------------
--- Re-export contents of propositional membership
-
-open import Data.List.Membership.Propositional {A = A} public
-open import Data.List.Membership.DecSetoid (decSetoid _≟_) public
-  using (_∈?_; _∉?_)
-
\ No newline at end of file diff --git a/Data.List.Membership.DecSetoid.html b/Data.List.Membership.DecSetoid.html deleted file mode 100644 index 6cc4770a..00000000 --- a/Data.List.Membership.DecSetoid.html +++ /dev/null @@ -1,33 +0,0 @@ - -Data.List.Membership.DecSetoid
------------------------------------------------------------------------
--- The Agda standard library
---
--- Decidable setoid membership over lists
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-open import Relation.Binary using (Decidable; DecSetoid)
-open import Relation.Nullary.Decidable using (¬?)
-
-module Data.List.Membership.DecSetoid {a ℓ} (DS : DecSetoid a ℓ) where
-
-open import Data.List.Relation.Unary.Any using (any?)
-open DecSetoid DS
-
-------------------------------------------------------------------------
--- Re-export contents of propositional membership
-
-open import Data.List.Membership.Setoid (DecSetoid.setoid DS) public
-
-------------------------------------------------------------------------
--- Other operations
-
-infix 4 _∈?_ _∉?_
-
-_∈?_ : Decidable _∈_
-x ∈? xs = any? (x ≟_) xs
-
-_∉?_ : Decidable _∉_
-x ∉? xs = ¬? (x ∈? xs)
-
\ No newline at end of file diff --git a/Data.List.Membership.Propositional.Properties.Core.html b/Data.List.Membership.Propositional.Properties.Core.html index 4fbad24b..de9f65db 100644 --- a/Data.List.Membership.Propositional.Properties.Core.html +++ b/Data.List.Membership.Propositional.Properties.Core.html @@ -14,75 +14,75 @@ module Data.List.Membership.Propositional.Properties.Core where open import Function.Base using (flip; id; _∘_) -open import Function.Inverse using (_↔_; inverse) -open import Data.List.Base using (List) -open import Data.List.Relation.Unary.Any as Any using (Any; here; there) -open import Data.List.Membership.Propositional -open import Data.Product as Prod - using (_,_; proj₁; proj₂; uncurry′; ∃; _×_) -open import Level using (Level) -open import Relation.Binary.PropositionalEquality as P - using (_≡_; refl) -open import Relation.Unary using (Pred; _⊆_) - -private - variable - a p q : Level - A : Set a - ------------------------------------------------------------------------- --- Lemmas relating map and find. - -map∘find : ∀ {P : Pred A p} {xs} - (p : Any P xs) → let p′ = find p in - {f : _≡_ (proj₁ p′) ⊆ P} → - f refl ≡ proj₂ (proj₂ p′) → - Any.map f (proj₁ (proj₂ p′)) ≡ p -map∘find (here p) hyp = P.cong here hyp -map∘find (there p) hyp = P.cong there (map∘find p hyp) - -find∘map : ∀ {P : Pred A p} {Q : Pred A q} - {xs : List A} (p : Any P xs) (f : P ⊆ Q) → - find (Any.map f p) ≡ Prod.map id (Prod.map id f) (find p) -find∘map (here p) f = refl -find∘map (there p) f rewrite find∘map p f = refl - ------------------------------------------------------------------------- --- find satisfies a simple equality when the predicate is a --- propositional equality. - -find-∈ : ∀ {x : A} {xs : List A} (x∈xs : x ∈ xs) → - find x∈xs ≡ (x , x∈xs , refl) -find-∈ (here refl) = refl -find-∈ (there x∈xs) rewrite find-∈ x∈xs = refl - ------------------------------------------------------------------------- --- find and lose are inverses (more or less). - -lose∘find : ∀ {P : Pred A p} {xs : List A} - (p : Any P xs) → - uncurry′ lose (proj₂ (find p)) ≡ p -lose∘find p = map∘find p P.refl - -find∘lose : ∀ (P : Pred A p) {x xs} - (x∈xs : x ∈ xs) (pp : P x) → - find {P = P} (lose x∈xs pp) ≡ (x , x∈xs , pp) -find∘lose P x∈xs p - rewrite find∘map x∈xs (flip (P.subst P) p) - | find-∈ x∈xs - = refl - ------------------------------------------------------------------------- --- Any can be expressed using _∈_ - -module _ {P : Pred A p} where - - ∃∈-Any : ∀ {xs} → (∃ λ x → x ∈ xs × P x) → Any P xs - ∃∈-Any = uncurry′ lose ∘ proj₂ - - Any↔ : ∀ {xs} → (∃ λ x → x ∈ xs × P x) ↔ Any P xs - Any↔ = inverse ∃∈-Any find from∘to lose∘find - where - from∘to : ∀ v → find (∃∈-Any v) ≡ v - from∘to p = find∘lose _ (proj₁ (proj₂ p)) (proj₂ (proj₂ p)) +open import Function.Bundles +open import Data.List.Base using (List) +open import Data.List.Relation.Unary.Any as Any using (Any; here; there) +open import Data.List.Membership.Propositional +open import Data.Product.Base as Prod + using (_,_; proj₁; proj₂; uncurry′; ∃; _×_) +open import Level using (Level) +open import Relation.Binary.PropositionalEquality.Core as P + using (_≡_; refl) +open import Relation.Unary using (Pred; _⊆_) + +private + variable + a p q : Level + A : Set a + +------------------------------------------------------------------------ +-- Lemmas relating map and find. + +map∘find : ∀ {P : Pred A p} {xs} + (p : Any P xs) → let p′ = find p in + {f : _≡_ (proj₁ p′) ⊆ P} → + f refl ≡ proj₂ (proj₂ p′) → + Any.map f (proj₁ (proj₂ p′)) ≡ p +map∘find (here p) hyp = P.cong here hyp +map∘find (there p) hyp = P.cong there (map∘find p hyp) + +find∘map : ∀ {P : Pred A p} {Q : Pred A q} + {xs : List A} (p : Any P xs) (f : P ⊆ Q) → + find (Any.map f p) ≡ Prod.map id (Prod.map id f) (find p) +find∘map (here p) f = refl +find∘map (there p) f rewrite find∘map p f = refl + +------------------------------------------------------------------------ +-- find satisfies a simple equality when the predicate is a +-- propositional equality. + +find-∈ : ∀ {x : A} {xs : List A} (x∈xs : x ∈ xs) → + find x∈xs ≡ (x , x∈xs , refl) +find-∈ (here refl) = refl +find-∈ (there x∈xs) rewrite find-∈ x∈xs = refl + +------------------------------------------------------------------------ +-- find and lose are inverses (more or less). + +lose∘find : ∀ {P : Pred A p} {xs : List A} + (p : Any P xs) → + uncurry′ lose (proj₂ (find p)) ≡ p +lose∘find p = map∘find p P.refl + +find∘lose : ∀ (P : Pred A p) {x xs} + (x∈xs : x ∈ xs) (pp : P x) → + find {P = P} (lose x∈xs pp) ≡ (x , x∈xs , pp) +find∘lose P x∈xs p + rewrite find∘map x∈xs (flip (P.subst P) p) + | find-∈ x∈xs + = refl + +------------------------------------------------------------------------ +-- Any can be expressed using _∈_ + +module _ {P : Pred A p} where + + ∃∈-Any : ∀ {xs} → (∃ λ x → x ∈ xs × P x) → Any P xs + ∃∈-Any = uncurry′ lose ∘ proj₂ + + Any↔ : ∀ {xs} → (∃ λ x → x ∈ xs × P x) ↔ Any P xs + Any↔ = mk↔ₛ′ ∃∈-Any find lose∘find from∘to + where + from∘to : ∀ v → find (∃∈-Any v) ≡ v + from∘to p = find∘lose _ (proj₁ (proj₂ p)) (proj₂ (proj₂ p)) \ No newline at end of file diff --git a/Data.List.Membership.Propositional.Properties.html b/Data.List.Membership.Propositional.Properties.html index bff84dd9..803acc90 100644 --- a/Data.List.Membership.Propositional.Properties.html +++ b/Data.List.Membership.Propositional.Properties.html @@ -9,392 +9,395 @@ module Data.List.Membership.Propositional.Properties where -open import Algebra using (Op₂; Selective) -open import Effect.Monad using (RawMonad) -open import Data.Bool.Base using (Bool; false; true; T) -open import Data.Fin.Base using (Fin) +open import Algebra using (Op₂; Selective) +open import Effect.Monad using (RawMonad) +open import Data.Bool.Base using (Bool; false; true; T) +open import Data.Fin.Base using (Fin) open import Data.List.Base as List -open import Data.List.Relation.Unary.Any as Any using (Any; here; there) +open import Data.List.Relation.Unary.Any as Any using (Any; here; there) open import Data.List.Relation.Unary.Any.Properties open import Data.List.Membership.Propositional import Data.List.Membership.Setoid.Properties as Membershipₛ open import Data.List.Relation.Binary.Equality.Propositional - using (_≋_; ≡⇒≋; ≋⇒≡) -open import Data.List.Effectful using (monad) -open import Data.Nat.Base using (ℕ; zero; suc; pred; s≤s; _≤_; _<_; _≤ᵇ_) + using (_≋_; ≡⇒≋; ≋⇒≡) +open import Data.List.Effectful using (monad) +open import Data.Nat.Base using (ℕ; zero; suc; pred; s≤s; _≤_; _<_; _≤ᵇ_) open import Data.Nat.Properties -open import Data.Product hiding (map) -open import Data.Product.Function.NonDependent.Propositional using (_×-cong_) -import Data.Product.Function.Dependent.Propositional as Σ -open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂) -open import Function.Base -open import Function.Equality using (_⟨$⟩_) -open import Function.Equivalence using (module Equivalence) -open import Function.Injection using (Injection; Injective; _↣_) -open import Function.Inverse as Inv using (_↔_; module Inverse) -import Function.Related as Related -open import Function.Related.TypeIsomorphisms -open import Level using (Level) -open import Relation.Binary as B hiding (Decidable) -open import Relation.Binary.PropositionalEquality as P - using (_≡_; _≢_; refl; sym; trans; cong; subst; →-to-⟶; _≗_) -import Relation.Binary.Properties.DecTotalOrder as DTOProperties -open import Relation.Unary using (_⟨×⟩_; Decidable) -import Relation.Nullary.Reflects as Reflects -open import Relation.Nullary.Reflects using (invert) -open import Relation.Nullary using (¬_; Dec; does; yes; no; _because_) -open import Relation.Nullary.Negation using (contradiction) -open import Relation.Nullary.Decidable using (excluded-middle) +open import Data.Product.Base hiding (map) +open import Data.Product.Properties using (×-≡,≡↔≡) +open import Data.Product.Function.NonDependent.Propositional using (_×-cong_) +import Data.Product.Function.Dependent.Propositional as Σ +open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂) +open import Function.Base +open import Function.Definitions +import Function.Related.Propositional as Related +open import Function.Bundles +open import Function.Related.TypeIsomorphisms +open import Function.Construct.Identity using (↔-id) +open import Level using (Level) +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Definitions as B hiding (Decidable) +open import Relation.Binary.PropositionalEquality as P + using (_≡_; _≢_; refl; sym; trans; cong; subst; →-to-⟶; _≗_) +import Relation.Binary.Properties.DecTotalOrder as DTOProperties +open import Relation.Unary using (_⟨×⟩_; Decidable) +import Relation.Nullary.Reflects as Reflects +open import Relation.Nullary.Reflects using (invert) +open import Relation.Nullary using (¬_; Dec; does; yes; no; _because_) +open import Relation.Nullary.Negation using (contradiction) +open import Relation.Nullary.Decidable using (¬¬-excluded-middle) -private - open module ListMonad {ℓ} = RawMonad (monad {ℓ = ℓ}) +private + open module ListMonad {ℓ} = RawMonad (monad {ℓ = ℓ}) - variable - ℓ : Level - A B C : Set ℓ - ------------------------------------------------------------------------- --- Publicly re-export properties from Core - -open import Data.List.Membership.Propositional.Properties.Core public + variable + ℓ : Level + A B C : Set ℓ + +------------------------------------------------------------------------ +-- Publicly re-export properties from Core + +open import Data.List.Membership.Propositional.Properties.Core public + +------------------------------------------------------------------------ +-- Equality ------------------------------------------------------------------------- --- Equality +∈-resp-≋ : ∀ {x : A} → (x ∈_) Respects _≋_ +∈-resp-≋ = Membershipₛ.∈-resp-≋ (P.setoid _) + +∉-resp-≋ : ∀ {x : A} → (x ∉_) Respects _≋_ +∉-resp-≋ = Membershipₛ.∉-resp-≋ (P.setoid _) + +------------------------------------------------------------------------ +-- mapWith∈ + +mapWith∈-cong : ∀ (xs : List A) → (f g : ∀ {x} → x ∈ xs → B) → + (∀ {x} → (x∈xs : x ∈ xs) → f x∈xs ≡ g x∈xs) → + mapWith∈ xs f ≡ mapWith∈ xs g +mapWith∈-cong [] f g cong = refl +mapWith∈-cong (x ∷ xs) f g cong = P.cong₂ _∷_ (cong (here refl)) + (mapWith∈-cong xs (f ∘ there) (g ∘ there) (cong ∘ there)) -∈-resp-≋ : ∀ {x : A} → (x ∈_) Respects _≋_ -∈-resp-≋ = Membershipₛ.∈-resp-≋ (P.setoid _) - -∉-resp-≋ : ∀ {x : A} → (x ∉_) Respects _≋_ -∉-resp-≋ = Membershipₛ.∉-resp-≋ (P.setoid _) - ------------------------------------------------------------------------- --- mapWith∈ +mapWith∈≗map : ∀ (f : A → B) xs → mapWith∈ xs (λ {x} _ → f x) ≡ map f xs +mapWith∈≗map f xs = + ≋⇒≡ (Membershipₛ.mapWith∈≗map (P.setoid _) (P.setoid _) f xs) + +mapWith∈-id : (xs : List A) → mapWith∈ xs (λ {x} _ → x) ≡ xs +mapWith∈-id = Membershipₛ.mapWith∈-id (P.setoid _) + +map-mapWith∈ : (xs : List A) (f : ∀ {x} → x ∈ xs → B) (g : B → C) → + map g (mapWith∈ xs f) ≡ mapWith∈ xs (g ∘′ f) +map-mapWith∈ = Membershipₛ.map-mapWith∈ (P.setoid _) -mapWith∈-cong : ∀ (xs : List A) → (f g : ∀ {x} → x ∈ xs → B) → - (∀ {x} → (x∈xs : x ∈ xs) → f x∈xs ≡ g x∈xs) → - mapWith∈ xs f ≡ mapWith∈ xs g -mapWith∈-cong [] f g cong = refl -mapWith∈-cong (x ∷ xs) f g cong = P.cong₂ _∷_ (cong (here refl)) - (mapWith∈-cong xs (f ∘ there) (g ∘ there) (cong ∘ there)) +------------------------------------------------------------------------ +-- map -mapWith∈≗map : ∀ (f : A → B) xs → mapWith∈ xs (λ {x} _ → f x) ≡ map f xs -mapWith∈≗map f xs = - ≋⇒≡ (Membershipₛ.mapWith∈≗map (P.setoid _) (P.setoid _) f xs) - -mapWith∈-id : (xs : List A) → mapWith∈ xs (λ {x} _ → x) ≡ xs -mapWith∈-id = Membershipₛ.mapWith∈-id (P.setoid _) - -map-mapWith∈ : (xs : List A) (f : ∀ {x} → x ∈ xs → B) (g : B → C) → - map g (mapWith∈ xs f) ≡ mapWith∈ xs (g ∘′ f) -map-mapWith∈ = Membershipₛ.map-mapWith∈ (P.setoid _) +module _ (f : A → B) where ------------------------------------------------------------------------- --- map + ∈-map⁺ : ∀ {x xs} → x ∈ xs → f x ∈ map f xs + ∈-map⁺ = Membershipₛ.∈-map⁺ (P.setoid A) (P.setoid B) (P.cong f) -module _ (f : A → B) where + ∈-map⁻ : ∀ {y xs} → y ∈ map f xs → ∃ λ x → x ∈ xs × y ≡ f x + ∈-map⁻ = Membershipₛ.∈-map⁻ (P.setoid A) (P.setoid B) - ∈-map⁺ : ∀ {x xs} → x ∈ xs → f x ∈ map f xs - ∈-map⁺ = Membershipₛ.∈-map⁺ (P.setoid A) (P.setoid B) (P.cong f) + map-∈↔ : ∀ {y xs} → (∃ λ x → x ∈ xs × y ≡ f x) ↔ y ∈ map f xs + map-∈↔ {y} {xs} = + (∃ λ x → x ∈ xs × y ≡ f x) ↔⟨ Any↔ ⟩ + Any (λ x → y ≡ f x) xs ↔⟨ map↔ ⟩ + y ∈ List.map f xs ∎ + where open Related.EquationalReasoning - ∈-map⁻ : ∀ {y xs} → y ∈ map f xs → ∃ λ x → x ∈ xs × y ≡ f x - ∈-map⁻ = Membershipₛ.∈-map⁻ (P.setoid A) (P.setoid B) +------------------------------------------------------------------------ +-- _++_ - map-∈↔ : ∀ {y xs} → (∃ λ x → x ∈ xs × y ≡ f x) ↔ y ∈ map f xs - map-∈↔ {y} {xs} = - (∃ λ x → x ∈ xs × y ≡ f x) ↔⟨ Any↔ ⟩ - Any (λ x → y ≡ f x) xs ↔⟨ map↔ ⟩ - y ∈ List.map f xs ∎ - where open Related.EquationalReasoning +module _ {v : A} where ------------------------------------------------------------------------- --- _++_ + ∈-++⁺ˡ : ∀ {xs ys} → v ∈ xs → v ∈ xs ++ ys + ∈-++⁺ˡ = Membershipₛ.∈-++⁺ˡ (P.setoid A) -module _ {v : A} where + ∈-++⁺ʳ : ∀ xs {ys} → v ∈ ys → v ∈ xs ++ ys + ∈-++⁺ʳ = Membershipₛ.∈-++⁺ʳ (P.setoid A) - ∈-++⁺ˡ : ∀ {xs ys} → v ∈ xs → v ∈ xs ++ ys - ∈-++⁺ˡ = Membershipₛ.∈-++⁺ˡ (P.setoid A) + ∈-++⁻ : ∀ xs {ys} → v ∈ xs ++ ys → (v ∈ xs) ⊎ (v ∈ ys) + ∈-++⁻ = Membershipₛ.∈-++⁻ (P.setoid A) - ∈-++⁺ʳ : ∀ xs {ys} → v ∈ ys → v ∈ xs ++ ys - ∈-++⁺ʳ = Membershipₛ.∈-++⁺ʳ (P.setoid A) + ∈-insert : ∀ xs {ys} → v ∈ xs ++ [ v ] ++ ys + ∈-insert xs = Membershipₛ.∈-insert (P.setoid A) xs refl - ∈-++⁻ : ∀ xs {ys} → v ∈ xs ++ ys → (v ∈ xs) ⊎ (v ∈ ys) - ∈-++⁻ = Membershipₛ.∈-++⁻ (P.setoid A) + ∈-∃++ : ∀ {xs} → v ∈ xs → ∃₂ λ ys zs → xs ≡ ys ++ [ v ] ++ zs + ∈-∃++ v∈xs with Membershipₛ.∈-∃++ (P.setoid A) v∈xs + ... | ys , zs , _ , refl , eq = ys , zs , ≋⇒≡ eq - ∈-insert : ∀ xs {ys} → v ∈ xs ++ [ v ] ++ ys - ∈-insert xs = Membershipₛ.∈-insert (P.setoid A) xs refl +------------------------------------------------------------------------ +-- concat - ∈-∃++ : ∀ {xs} → v ∈ xs → ∃₂ λ ys zs → xs ≡ ys ++ [ v ] ++ zs - ∈-∃++ v∈xs with Membershipₛ.∈-∃++ (P.setoid A) v∈xs - ... | ys , zs , _ , refl , eq = ys , zs , ≋⇒≡ eq +module _ {v : A} where ------------------------------------------------------------------------- --- concat + ∈-concat⁺ : ∀ {xss} → Any (v ∈_) xss → v ∈ concat xss + ∈-concat⁺ = Membershipₛ.∈-concat⁺ (P.setoid A) -module _ {v : A} where + ∈-concat⁻ : ∀ xss → v ∈ concat xss → Any (v ∈_) xss + ∈-concat⁻ = Membershipₛ.∈-concat⁻ (P.setoid A) - ∈-concat⁺ : ∀ {xss} → Any (v ∈_) xss → v ∈ concat xss - ∈-concat⁺ = Membershipₛ.∈-concat⁺ (P.setoid A) + ∈-concat⁺′ : ∀ {vs xss} → v ∈ vs → vs ∈ xss → v ∈ concat xss + ∈-concat⁺′ v∈vs vs∈xss = + Membershipₛ.∈-concat⁺′ (P.setoid A) v∈vs (Any.map ≡⇒≋ vs∈xss) - ∈-concat⁻ : ∀ xss → v ∈ concat xss → Any (v ∈_) xss - ∈-concat⁻ = Membershipₛ.∈-concat⁻ (P.setoid A) + ∈-concat⁻′ : ∀ xss → v ∈ concat xss → ∃ λ xs → v ∈ xs × xs ∈ xss + ∈-concat⁻′ xss v∈c with Membershipₛ.∈-concat⁻′ (P.setoid A) xss v∈c + ... | xs , v∈xs , xs∈xss = xs , v∈xs , Any.map ≋⇒≡ xs∈xss - ∈-concat⁺′ : ∀ {vs xss} → v ∈ vs → vs ∈ xss → v ∈ concat xss - ∈-concat⁺′ v∈vs vs∈xss = - Membershipₛ.∈-concat⁺′ (P.setoid A) v∈vs (Any.map ≡⇒≋ vs∈xss) + concat-∈↔ : ∀ {xss : List (List A)} → + (∃ λ xs → v ∈ xs × xs ∈ xss) ↔ v ∈ concat xss + concat-∈↔ {xss} = + (∃ λ xs → v ∈ xs × xs ∈ xss) ↔⟨ Σ.cong (↔-id _) $ ×-comm _ _ ⟩ + (∃ λ xs → xs ∈ xss × v ∈ xs) ↔⟨ Any↔ ⟩ + Any (Any (v ≡_)) xss ↔⟨ concat↔ ⟩ + v ∈ concat xss ∎ + where open Related.EquationalReasoning - ∈-concat⁻′ : ∀ xss → v ∈ concat xss → ∃ λ xs → v ∈ xs × xs ∈ xss - ∈-concat⁻′ xss v∈c with Membershipₛ.∈-concat⁻′ (P.setoid A) xss v∈c - ... | xs , v∈xs , xs∈xss = xs , v∈xs , Any.map ≋⇒≡ xs∈xss +------------------------------------------------------------------------ +-- cartesianProductWith - concat-∈↔ : ∀ {xss : List (List A)} → - (∃ λ xs → v ∈ xs × xs ∈ xss) ↔ v ∈ concat xss - concat-∈↔ {xss} = - (∃ λ xs → v ∈ xs × xs ∈ xss) ↔⟨ Σ.cong Inv.id $ ×-comm _ _ ⟩ - (∃ λ xs → xs ∈ xss × v ∈ xs) ↔⟨ Any↔ ⟩ - Any (Any (v ≡_)) xss ↔⟨ concat↔ ⟩ - v ∈ concat xss ∎ - where open Related.EquationalReasoning +module _ (f : A → B → C) where ------------------------------------------------------------------------- --- cartesianProductWith + ∈-cartesianProductWith⁺ : ∀ {xs ys a b} → a ∈ xs → b ∈ ys → + f a b ∈ cartesianProductWith f xs ys + ∈-cartesianProductWith⁺ = Membershipₛ.∈-cartesianProductWith⁺ + (P.setoid A) (P.setoid B) (P.setoid C) (P.cong₂ f) -module _ (f : A → B → C) where + ∈-cartesianProductWith⁻ : ∀ xs ys {v} → v ∈ cartesianProductWith f xs ys → + ∃₂ λ a b → a ∈ xs × b ∈ ys × v ≡ f a b + ∈-cartesianProductWith⁻ = Membershipₛ.∈-cartesianProductWith⁻ + (P.setoid A) (P.setoid B) (P.setoid C) f - ∈-cartesianProductWith⁺ : ∀ {xs ys a b} → a ∈ xs → b ∈ ys → - f a b ∈ cartesianProductWith f xs ys - ∈-cartesianProductWith⁺ = Membershipₛ.∈-cartesianProductWith⁺ - (P.setoid A) (P.setoid B) (P.setoid C) (P.cong₂ f) +------------------------------------------------------------------------ +-- cartesianProduct - ∈-cartesianProductWith⁻ : ∀ xs ys {v} → v ∈ cartesianProductWith f xs ys → - ∃₂ λ a b → a ∈ xs × b ∈ ys × v ≡ f a b - ∈-cartesianProductWith⁻ = Membershipₛ.∈-cartesianProductWith⁻ - (P.setoid A) (P.setoid B) (P.setoid C) f +∈-cartesianProduct⁺ : ∀ {x : A} {y : B} {xs ys} → x ∈ xs → y ∈ ys → + (x , y) ∈ cartesianProduct xs ys +∈-cartesianProduct⁺ = ∈-cartesianProductWith⁺ _,_ ------------------------------------------------------------------------- --- cartesianProduct +∈-cartesianProduct⁻ : ∀ xs ys {xy@(x , y) : A × B} → + xy ∈ cartesianProduct xs ys → x ∈ xs × y ∈ ys +∈-cartesianProduct⁻ xs ys xy∈p[xs,ys] with ∈-cartesianProductWith⁻ _,_ xs ys xy∈p[xs,ys] +... | (x , y , x∈xs , y∈ys , refl) = x∈xs , y∈ys -∈-cartesianProduct⁺ : ∀ {x : A} {y : B} {xs ys} → x ∈ xs → y ∈ ys → - (x , y) ∈ cartesianProduct xs ys -∈-cartesianProduct⁺ = ∈-cartesianProductWith⁺ _,_ +------------------------------------------------------------------------ +-- applyUpTo -∈-cartesianProduct⁻ : ∀ xs ys {xy@(x , y) : A × B} → - xy ∈ cartesianProduct xs ys → x ∈ xs × y ∈ ys -∈-cartesianProduct⁻ xs ys xy∈p[xs,ys] with ∈-cartesianProductWith⁻ _,_ xs ys xy∈p[xs,ys] -... | (x , y , x∈xs , y∈ys , refl) = x∈xs , y∈ys +module _ (f : ℕ → A) where ------------------------------------------------------------------------- --- applyUpTo + ∈-applyUpTo⁺ : ∀ {i n} → i < n → f i ∈ applyUpTo f n + ∈-applyUpTo⁺ = Membershipₛ.∈-applyUpTo⁺ (P.setoid _) f -module _ (f : ℕ → A) where + ∈-applyUpTo⁻ : ∀ {v n} → v ∈ applyUpTo f n → + ∃ λ i → i < n × v ≡ f i + ∈-applyUpTo⁻ = Membershipₛ.∈-applyUpTo⁻ (P.setoid _) f - ∈-applyUpTo⁺ : ∀ {i n} → i < n → f i ∈ applyUpTo f n - ∈-applyUpTo⁺ = Membershipₛ.∈-applyUpTo⁺ (P.setoid _) f +------------------------------------------------------------------------ +-- upTo - ∈-applyUpTo⁻ : ∀ {v n} → v ∈ applyUpTo f n → - ∃ λ i → i < n × v ≡ f i - ∈-applyUpTo⁻ = Membershipₛ.∈-applyUpTo⁻ (P.setoid _) f +∈-upTo⁺ : ∀ {n i} → i < n → i ∈ upTo n +∈-upTo⁺ = ∈-applyUpTo⁺ id ------------------------------------------------------------------------- --- upTo +∈-upTo⁻ : ∀ {n i} → i ∈ upTo n → i < n +∈-upTo⁻ p with ∈-applyUpTo⁻ id p +... | _ , i<n , refl = i<n -∈-upTo⁺ : ∀ {n i} → i < n → i ∈ upTo n -∈-upTo⁺ = ∈-applyUpTo⁺ id +------------------------------------------------------------------------ +-- applyDownFrom -∈-upTo⁻ : ∀ {n i} → i ∈ upTo n → i < n -∈-upTo⁻ p with ∈-applyUpTo⁻ id p -... | _ , i<n , refl = i<n +module _ (f : ℕ → A) where ------------------------------------------------------------------------- --- applyDownFrom + ∈-applyDownFrom⁺ : ∀ {i n} → i < n → f i ∈ applyDownFrom f n + ∈-applyDownFrom⁺ = Membershipₛ.∈-applyDownFrom⁺ (P.setoid _) f -module _ (f : ℕ → A) where + ∈-applyDownFrom⁻ : ∀ {v n} → v ∈ applyDownFrom f n → + ∃ λ i → i < n × v ≡ f i + ∈-applyDownFrom⁻ = Membershipₛ.∈-applyDownFrom⁻ (P.setoid _) f - ∈-applyDownFrom⁺ : ∀ {i n} → i < n → f i ∈ applyDownFrom f n - ∈-applyDownFrom⁺ = Membershipₛ.∈-applyDownFrom⁺ (P.setoid _) f +------------------------------------------------------------------------ +-- downFrom - ∈-applyDownFrom⁻ : ∀ {v n} → v ∈ applyDownFrom f n → - ∃ λ i → i < n × v ≡ f i - ∈-applyDownFrom⁻ = Membershipₛ.∈-applyDownFrom⁻ (P.setoid _) f +∈-downFrom⁺ : ∀ {n i} → i < n → i ∈ downFrom n +∈-downFrom⁺ i<n = ∈-applyDownFrom⁺ id i<n ------------------------------------------------------------------------- --- downFrom +∈-downFrom⁻ : ∀ {n i} → i ∈ downFrom n → i < n +∈-downFrom⁻ p with ∈-applyDownFrom⁻ id p +... | _ , i<n , refl = i<n -∈-downFrom⁺ : ∀ {n i} → i < n → i ∈ downFrom n -∈-downFrom⁺ i<n = ∈-applyDownFrom⁺ id i<n +------------------------------------------------------------------------ +-- tabulate -∈-downFrom⁻ : ∀ {n i} → i ∈ downFrom n → i < n -∈-downFrom⁻ p with ∈-applyDownFrom⁻ id p -... | _ , i<n , refl = i<n +module _ {n} {f : Fin n → A} where ------------------------------------------------------------------------- --- tabulate + ∈-tabulate⁺ : ∀ i → f i ∈ tabulate f + ∈-tabulate⁺ = Membershipₛ.∈-tabulate⁺ (P.setoid _) -module _ {n} {f : Fin n → A} where + ∈-tabulate⁻ : ∀ {v} → v ∈ tabulate f → ∃ λ i → v ≡ f i + ∈-tabulate⁻ = Membershipₛ.∈-tabulate⁻ (P.setoid _) - ∈-tabulate⁺ : ∀ i → f i ∈ tabulate f - ∈-tabulate⁺ = Membershipₛ.∈-tabulate⁺ (P.setoid _) +------------------------------------------------------------------------ +-- filter - ∈-tabulate⁻ : ∀ {v} → v ∈ tabulate f → ∃ λ i → v ≡ f i - ∈-tabulate⁻ = Membershipₛ.∈-tabulate⁻ (P.setoid _) +module _ {p} {P : A → Set p} (P? : Decidable P) where ------------------------------------------------------------------------- --- filter + ∈-filter⁺ : ∀ {x xs} → x ∈ xs → P x → x ∈ filter P? xs + ∈-filter⁺ = Membershipₛ.∈-filter⁺ (P.setoid A) P? (P.subst P) -module _ {p} {P : A → Set p} (P? : Decidable P) where + ∈-filter⁻ : ∀ {v xs} → v ∈ filter P? xs → v ∈ xs × P v + ∈-filter⁻ = Membershipₛ.∈-filter⁻ (P.setoid A) P? (P.subst P) - ∈-filter⁺ : ∀ {x xs} → x ∈ xs → P x → x ∈ filter P? xs - ∈-filter⁺ = Membershipₛ.∈-filter⁺ (P.setoid A) P? (P.subst P) +------------------------------------------------------------------------ +-- derun and deduplicate - ∈-filter⁻ : ∀ {v xs} → v ∈ filter P? xs → v ∈ xs × P v - ∈-filter⁻ = Membershipₛ.∈-filter⁻ (P.setoid A) P? (P.subst P) +module _ {r} {R : Rel A r} (R? : B.Decidable R) where ------------------------------------------------------------------------- --- derun and deduplicate + ∈-derun⁻ : ∀ xs {z} → z ∈ derun R? xs → z ∈ xs + ∈-derun⁻ xs z∈derun[R,xs] = Membershipₛ.∈-derun⁻ (P.setoid A) R? xs z∈derun[R,xs] -module _ {r} {R : Rel A r} (R? : B.Decidable R) where + ∈-deduplicate⁻ : ∀ xs {z} → z ∈ deduplicate R? xs → z ∈ xs + ∈-deduplicate⁻ xs z∈dedup[R,xs] = Membershipₛ.∈-deduplicate⁻ (P.setoid A) R? xs z∈dedup[R,xs] - ∈-derun⁻ : ∀ xs {z} → z ∈ derun R? xs → z ∈ xs - ∈-derun⁻ xs z∈derun[R,xs] = Membershipₛ.∈-derun⁻ (P.setoid A) R? xs z∈derun[R,xs] +module _ (_≈?_ : B.Decidable {A = A} _≡_) where - ∈-deduplicate⁻ : ∀ xs {z} → z ∈ deduplicate R? xs → z ∈ xs - ∈-deduplicate⁻ xs z∈dedup[R,xs] = Membershipₛ.∈-deduplicate⁻ (P.setoid A) R? xs z∈dedup[R,xs] + ∈-derun⁺ : ∀ {xs z} → z ∈ xs → z ∈ derun _≈?_ xs + ∈-derun⁺ z∈xs = Membershipₛ.∈-derun⁺ (P.setoid A) _≈?_ (flip trans) z∈xs -module _ (_≈?_ : B.Decidable {A = A} _≡_) where + ∈-deduplicate⁺ : ∀ {xs z} → z ∈ xs → z ∈ deduplicate _≈?_ xs + ∈-deduplicate⁺ z∈xs = Membershipₛ.∈-deduplicate⁺ (P.setoid A) _≈?_ (λ c≡b a≡b → trans a≡b (sym c≡b)) z∈xs - ∈-derun⁺ : ∀ {xs z} → z ∈ xs → z ∈ derun _≈?_ xs - ∈-derun⁺ z∈xs = Membershipₛ.∈-derun⁺ (P.setoid A) _≈?_ (flip trans) z∈xs +------------------------------------------------------------------------ +-- _>>=_ - ∈-deduplicate⁺ : ∀ {xs z} → z ∈ xs → z ∈ deduplicate _≈?_ xs - ∈-deduplicate⁺ z∈xs = Membershipₛ.∈-deduplicate⁺ (P.setoid A) _≈?_ (λ c≡b a≡b → trans a≡b (sym c≡b)) z∈xs +>>=-∈↔ : ∀ {xs} {f : A → List B} {y} → + (∃ λ x → x ∈ xs × y ∈ f x) ↔ y ∈ (xs >>= f) +>>=-∈↔ {xs = xs} {f} {y} = + (∃ λ x → x ∈ xs × y ∈ f x) ↔⟨ Any↔ ⟩ + Any (Any (y ≡_) ∘ f) xs ↔⟨ >>=↔ ⟩ + y ∈ (xs >>= f) ∎ + where open Related.EquationalReasoning ------------------------------------------------------------------------- --- _>>=_ +------------------------------------------------------------------------ +-- _⊛_ ->>=-∈↔ : ∀ {xs} {f : A → List B} {y} → - (∃ λ x → x ∈ xs × y ∈ f x) ↔ y ∈ (xs >>= f) ->>=-∈↔ {xs = xs} {f} {y} = - (∃ λ x → x ∈ xs × y ∈ f x) ↔⟨ Any↔ ⟩ - Any (Any (y ≡_) ∘ f) xs ↔⟨ >>=↔ ⟩ - y ∈ (xs >>= f) ∎ - where open Related.EquationalReasoning +⊛-∈↔ : ∀ (fs : List (A → B)) {xs y} → + (∃₂ λ f x → f ∈ fs × x ∈ xs × y ≡ f x) ↔ y ∈ (fs ⊛ xs) +⊛-∈↔ fs {xs} {y} = + (∃₂ λ f x → f ∈ fs × x ∈ xs × y ≡ f x) ↔⟨ Σ.cong (↔-id _) (∃∃↔∃∃ _) ⟩ + (∃ λ f → f ∈ fs × ∃ λ x → x ∈ xs × y ≡ f x) ↔⟨ Σ.cong (↔-id _) (↔-id _ ⟨ _×-cong_ ⟩ Any↔) ⟩ + (∃ λ f → f ∈ fs × Any (_≡_ y ∘ f) xs) ↔⟨ Any↔ ⟩ + Any (λ f → Any (_≡_ y ∘ f) xs) fs ↔⟨ ⊛↔ ⟩ + y ∈ (fs ⊛ xs) ∎ + where open Related.EquationalReasoning ------------------------------------------------------------------------- --- _⊛_ +------------------------------------------------------------------------ +-- _⊗_ -⊛-∈↔ : ∀ (fs : List (A → B)) {xs y} → - (∃₂ λ f x → f ∈ fs × x ∈ xs × y ≡ f x) ↔ y ∈ (fs ⊛ xs) -⊛-∈↔ fs {xs} {y} = - (∃₂ λ f x → f ∈ fs × x ∈ xs × y ≡ f x) ↔⟨ Σ.cong Inv.id (∃∃↔∃∃ _) ⟩ - (∃ λ f → f ∈ fs × ∃ λ x → x ∈ xs × y ≡ f x) ↔⟨ Σ.cong Inv.id ((_ ∎) ⟨ _×-cong_ ⟩ Any↔) ⟩ - (∃ λ f → f ∈ fs × Any (_≡_ y ∘ f) xs) ↔⟨ Any↔ ⟩ - Any (λ f → Any (_≡_ y ∘ f) xs) fs ↔⟨ ⊛↔ ⟩ - y ∈ (fs ⊛ xs) ∎ - where open Related.EquationalReasoning +⊗-∈↔ : ∀ {xs ys} {x : A} {y : B} → + (x ∈ xs × y ∈ ys) ↔ (x , y) ∈ (xs ⊗ ys) +⊗-∈↔ {xs = xs} {ys} {x} {y} = + (x ∈ xs × y ∈ ys) ↔⟨ ⊗↔′ ⟩ + Any (x ≡_ ⟨×⟩ y ≡_) (xs ⊗ ys) ↔⟨ Any-cong (λ _ → ×-≡,≡↔≡) (↔-id _) ⟩ + (x , y) ∈ (xs ⊗ ys) ∎ + where + open Related.EquationalReasoning ------------------------------------------------------------------------- --- _⊗_ +------------------------------------------------------------------------ +-- length -⊗-∈↔ : ∀ {xs ys} {x : A} {y : B} → - (x ∈ xs × y ∈ ys) ↔ (x , y) ∈ (xs ⊗ ys) -⊗-∈↔ {xs = xs} {ys} {x} {y} = - (x ∈ xs × y ∈ ys) ↔⟨ ⊗↔′ ⟩ - Any (x ≡_ ⟨×⟩ y ≡_) (xs ⊗ ys) ↔⟨ Any-cong ×-≡×≡↔≡,≡ (_ ∎) ⟩ - (x , y) ∈ (xs ⊗ ys) ∎ - where - open Related.EquationalReasoning +∈-length : ∀ {x : A} {xs} → x ∈ xs → 1 ≤ length xs +∈-length = Membershipₛ.∈-length (P.setoid _) ------------------------------------------------------------------------- --- length +------------------------------------------------------------------------ +-- lookup -∈-length : ∀ {x : A} {xs} → x ∈ xs → 1 ≤ length xs -∈-length = Membershipₛ.∈-length (P.setoid _) +∈-lookup : ∀ {xs : List A} i → lookup xs i ∈ xs +∈-lookup {xs = xs} i = Membershipₛ.∈-lookup (P.setoid _) xs i ------------------------------------------------------------------------- --- lookup +------------------------------------------------------------------------ +-- foldr -∈-lookup : ∀ {xs : List A} i → lookup xs i ∈ xs -∈-lookup {xs = xs} i = Membershipₛ.∈-lookup (P.setoid _) xs i +module _ {_•_ : Op₂ A} where ------------------------------------------------------------------------- --- foldr + foldr-selective : Selective _≡_ _•_ → ∀ e xs → + (foldr _•_ e xs ≡ e) ⊎ (foldr _•_ e xs ∈ xs) + foldr-selective = Membershipₛ.foldr-selective (P.setoid A) -module _ {_•_ : Op₂ A} where +------------------------------------------------------------------------ +-- allFin - foldr-selective : Selective _≡_ _•_ → ∀ e xs → - (foldr _•_ e xs ≡ e) ⊎ (foldr _•_ e xs ∈ xs) - foldr-selective = Membershipₛ.foldr-selective (P.setoid A) +∈-allFin : ∀ {n} (k : Fin n) → k ∈ allFin n +∈-allFin = ∈-tabulate⁺ ------------------------------------------------------------------------- --- allFin +------------------------------------------------------------------------ +-- inits -∈-allFin : ∀ {n} (k : Fin n) → k ∈ allFin n -∈-allFin = ∈-tabulate⁺ +[]∈inits : ∀ {a} {A : Set a} (as : List A) → [] ∈ inits as +[]∈inits [] = here refl +[]∈inits (a ∷ as) = here refl ------------------------------------------------------------------------- --- inits +------------------------------------------------------------------------ +-- Other properties -[]∈inits : ∀ {a} {A : Set a} (as : List A) → [] ∈ inits as -[]∈inits [] = here refl -[]∈inits (a ∷ as) = here refl - ------------------------------------------------------------------------- --- Other properties - --- Only a finite number of distinct elements can be members of a --- given list. - -finite : (f : ℕ ↣ A) → ∀ xs → ¬ (∀ i → Injection.to f ⟨$⟩ i ∈ xs) -finite inj [] fᵢ∈[] = ¬Any[] (fᵢ∈[] 0) -finite inj (x ∷ xs) fᵢ∈x∷xs = excluded-middle helper - where - open Injection inj renaming (injective to f-inj) - - f : ℕ → _ - f = to ⟨$⟩_ - - not-x : ∀ {i} → f i ≢ x → f i ∈ xs - not-x {i} fᵢ≢x with fᵢ∈x∷xs i - ... | here fᵢ≡x = contradiction fᵢ≡x fᵢ≢x - ... | there fᵢ∈xs = fᵢ∈xs - - helper : ¬ Dec (∃ λ i → f i ≡ x) - helper (no fᵢ≢x) = finite inj xs (λ i → not-x (fᵢ≢x ∘ _,_ i)) - helper (yes (i , fᵢ≡x)) = finite f′-inj xs f′ⱼ∈xs - where - f′ : ℕ → _ - f′ j with does (i ≤? j) - ... | true = f (suc j) - ... | false = f j - - ∈-if-not-i : ∀ {j} → i ≢ j → f j ∈ xs - ∈-if-not-i i≢j = not-x (i≢j ∘ f-inj ∘ trans fᵢ≡x ∘ sym) - - lemma : ∀ {k j} → i ≤ j → ¬ (i ≤ k) → suc j ≢ k - lemma i≤j i≰1+j refl = i≰1+j (m≤n⇒m≤1+n i≤j) - - f′ⱼ∈xs : ∀ j → f′ j ∈ xs - f′ⱼ∈xs j with i ≤ᵇ j | Reflects.invert (≤ᵇ-reflects-≤ i j) - ... | true | p = ∈-if-not-i (<⇒≢ (s≤s p)) - ... | false | p = ∈-if-not-i (<⇒≢ (≰⇒> p) ∘ sym) - - f′-injective′ : Injective {B = P.setoid _} (→-to-⟶ f′) - f′-injective′ {j} {k} eq with i ≤ᵇ j | Reflects.invert (≤ᵇ-reflects-≤ i j) - | i ≤ᵇ k | Reflects.invert (≤ᵇ-reflects-≤ i k) - ... | true | p | true | q = P.cong pred (f-inj eq) - ... | true | p | false | q = contradiction (f-inj eq) (lemma p q) - ... | false | p | true | q = contradiction (f-inj eq) (lemma q p ∘ sym) - ... | false | p | false | q = f-inj eq - - f′-inj = record - { to = →-to-⟶ f′ - ; injective = f′-injective′ - } - ------------------------------------------------------------------------- --- Different members - -there-injective-≢∈ : ∀ {xs} {x y z : A} {x∈xs : x ∈ xs} {y∈xs : y ∈ xs} → - there {x = z} x∈xs ≢∈ there y∈xs → - x∈xs ≢∈ y∈xs -there-injective-≢∈ neq refl eq = neq refl (P.cong there eq) +-- Only a finite number of distinct elements can be members of a +-- given list. + +finite : (inj : ℕ ↣ A) → ∀ xs → ¬ (∀ i → Injection.to inj i ∈ xs) +finite inj [] fᵢ∈[] = ¬Any[] (fᵢ∈[] 0) +finite inj (x ∷ xs) fᵢ∈x∷xs = ¬¬-excluded-middle helper + where + open Injection inj renaming (injective to f-inj) + + f : ℕ → _ + f = to + + not-x : ∀ {i} → f i ≢ x → f i ∈ xs + not-x {i} fᵢ≢x with fᵢ∈x∷xs i + ... | here fᵢ≡x = contradiction fᵢ≡x fᵢ≢x + ... | there fᵢ∈xs = fᵢ∈xs + + helper : ¬ Dec (∃ λ i → f i ≡ x) + helper (no fᵢ≢x) = finite inj xs (λ i → not-x (fᵢ≢x ∘ _,_ i)) + helper (yes (i , fᵢ≡x)) = finite f′-inj xs f′ⱼ∈xs + where + f′ : ℕ → _ + f′ j with does (i ≤? j) + ... | true = f (suc j) + ... | false = f j + + ∈-if-not-i : ∀ {j} → i ≢ j → f j ∈ xs + ∈-if-not-i i≢j = not-x (i≢j ∘ f-inj ∘ trans fᵢ≡x ∘ sym) + + lemma : ∀ {k j} → i ≤ j → ¬ (i ≤ k) → suc j ≢ k + lemma i≤j i≰1+j refl = i≰1+j (m≤n⇒m≤1+n i≤j) + + f′ⱼ∈xs : ∀ j → f′ j ∈ xs + f′ⱼ∈xs j with i ≤ᵇ j | Reflects.invert (≤ᵇ-reflects-≤ i j) + ... | true | p = ∈-if-not-i (<⇒≢ (s≤s p)) + ... | false | p = ∈-if-not-i (<⇒≢ (≰⇒> p) ∘ sym) + + f′-injective′ : Injective _≡_ _≡_ f′ + f′-injective′ {j} {k} eq with i ≤ᵇ j | Reflects.invert (≤ᵇ-reflects-≤ i j) + | i ≤ᵇ k | Reflects.invert (≤ᵇ-reflects-≤ i k) + ... | true | p | true | q = P.cong pred (f-inj eq) + ... | true | p | false | q = contradiction (f-inj eq) (lemma p q) + ... | false | p | true | q = contradiction (f-inj eq) (lemma q p ∘ sym) + ... | false | p | false | q = f-inj eq + + f′-inj : ℕ ↣ _ + f′-inj = record + { to = f′ + ; cong = P.cong f′ + ; injective = f′-injective′ + } + +------------------------------------------------------------------------ +-- Different members + +there-injective-≢∈ : ∀ {xs} {x y z : A} {x∈xs : x ∈ xs} {y∈xs : y ∈ xs} → + there {x = z} x∈xs ≢∈ there y∈xs → + x∈xs ≢∈ y∈xs +there-injective-≢∈ neq refl eq = neq refl (P.cong there eq) \ No newline at end of file diff --git a/Data.List.Membership.Propositional.html b/Data.List.Membership.Propositional.html index 34209776..4d46f084 100644 --- a/Data.List.Membership.Propositional.html +++ b/Data.List.Membership.Propositional.html @@ -10,25 +10,28 @@ module Data.List.Membership.Propositional {a} {A : Set a} where -open import Data.List.Relation.Unary.Any using (Any) -open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; setoid; subst) +open import Data.List.Relation.Unary.Any using (Any) +open import Relation.Binary.PropositionalEquality.Core using (_≡_; _≢_; subst) +open import Relation.Binary.PropositionalEquality.Properties using (setoid) -import Data.List.Membership.Setoid as SetoidMembership +import Data.List.Membership.Setoid as SetoidMembership ------------------------------------------------------------------------- --- Re-export contents of setoid membership +------------------------------------------------------------------------ +-- Re-export contents of setoid membership -open SetoidMembership (setoid A) public hiding (lose) +open SetoidMembership (setoid A) public hiding (lose) ------------------------------------------------------------------------- --- Different members +------------------------------------------------------------------------ +-- Different members -_≢∈_ : ∀ {x y : A} {xs} → x ∈ xs → y ∈ xs → Set _ -_≢∈_ x∈xs y∈xs = ∀ x≡y → subst (_∈ _) x≡y x∈xs ≢ y∈xs +infix 4 _≢∈_ ------------------------------------------------------------------------- --- Other operations +_≢∈_ : ∀ {x y : A} {xs} → x ∈ xs → y ∈ xs → Set _ +_≢∈_ x∈xs y∈xs = ∀ x≡y → subst (_∈ _) x≡y x∈xs ≢ y∈xs -lose : ∀ {p} {P : A → Set p} {x xs} → x ∈ xs → P x → Any P xs -lose = SetoidMembership.lose (setoid A) (subst _) +------------------------------------------------------------------------ +-- Other operations + +lose : ∀ {p} {P : A → Set p} {x xs} → x ∈ xs → P x → Any P xs +lose = SetoidMembership.lose (setoid A) (subst _) \ No newline at end of file diff --git a/Data.List.Membership.Setoid.Properties.html b/Data.List.Membership.Setoid.Properties.html index de1b5bf5..d28b55dd 100644 --- a/Data.List.Membership.Setoid.Properties.html +++ b/Data.List.Membership.Setoid.Properties.html @@ -9,417 +9,427 @@ module Data.List.Membership.Setoid.Properties where -open import Algebra using (Op₂; Selective) +open import Algebra using (Op₂; Selective) open import Data.Bool.Base using (true; false) -open import Data.Fin.Base using (Fin; zero; suc) -open import Data.List.Base -open import Data.List.Relation.Unary.Any as Any using (Any; here; there) -open import Data.List.Relation.Unary.All as All using (All) -import Data.List.Relation.Unary.Any.Properties as Any -import Data.List.Membership.Setoid as Membership -import Data.List.Relation.Binary.Equality.Setoid as Equality -import Data.List.Relation.Unary.Unique.Setoid as Unique -open import Data.Nat.Base using (suc; z≤n; s≤s; _≤_; _<_) -open import Data.Nat.Properties using (≤-trans; n≤1+n) -open import Data.Product as Prod using (∃; _×_; _,_ ; ∃₂; proj₁; proj₂) -open import Data.Product.Relation.Binary.Pointwise.NonDependent using (_×ₛ_) -open import Data.Sum.Base using (_⊎_; inj₁; inj₂; [_,_]′) -open import Function.Base using (_$_; flip; _∘_; _∘′_; id) -open import Function.Inverse using (_↔_) -open import Level using (Level) -open import Relation.Binary as B hiding (Decidable) -open import Relation.Binary.PropositionalEquality as P using (_≡_) -open import Relation.Unary as U using (Decidable; Pred) -open import Relation.Nullary using (¬_; does; _because_; yes; no) -open import Relation.Nullary.Reflects using (invert) -open import Relation.Nullary.Negation using (contradiction) -open import Relation.Nullary.Decidable using (¬?) -open Setoid using (Carrier) - -private - variable - c c₁ c₂ c₃ p ℓ ℓ₁ ℓ₂ ℓ₃ : Level - ------------------------------------------------------------------------- --- Equality properties - -module _ (S : Setoid c ℓ) where - - open Setoid S - open Equality S - open Membership S - - -- _∈_ respects the underlying equality - - ∈-resp-≈ : ∀ {xs} → (_∈ xs) Respects _≈_ - ∈-resp-≈ x≈y x∈xs = Any.map (trans (sym x≈y)) x∈xs - - ∉-resp-≈ : ∀ {xs} → (_∉ xs) Respects _≈_ - ∉-resp-≈ v≈w v∉xs w∈xs = v∉xs (∈-resp-≈ (sym v≈w) w∈xs) - - ∈-resp-≋ : ∀ {x} → (x ∈_) Respects _≋_ - ∈-resp-≋ = Any.lift-resp (flip trans) - - ∉-resp-≋ : ∀ {x} → (x ∉_) Respects _≋_ - ∉-resp-≋ xs≋ys v∉xs v∈ys = v∉xs (∈-resp-≋ (≋-sym xs≋ys) v∈ys) - ------------------------------------------------------------------------- --- Irrelevance - -module _ (S : Setoid c ℓ) where - - open Setoid S - open Unique S - open Membership S - - private - ∉×∈⇒≉ : ∀ {x y xs} → All (y ≉_) xs → x ∈ xs → x ≉ y - ∉×∈⇒≉ = All.lookupWith λ y≉z x≈z x≈y → y≉z (trans (sym x≈y) x≈z) - - unique⇒irrelevant : B.Irrelevant _≈_ → ∀ {xs} → Unique xs → U.Irrelevant (_∈ xs) - unique⇒irrelevant ≈-irr _ (here p) (here q) = - P.cong here (≈-irr p q) - unique⇒irrelevant ≈-irr (_ ∷ u) (there p) (there q) = - P.cong there (unique⇒irrelevant ≈-irr u p q) - unique⇒irrelevant ≈-irr (≉s ∷ _) (here p) (there q) = - contradiction p (∉×∈⇒≉ ≉s q) - unique⇒irrelevant ≈-irr (≉s ∷ _) (there p) (here q) = - contradiction q (∉×∈⇒≉ ≉s p) - ------------------------------------------------------------------------- --- mapWith∈ - -module _ (S₁ : Setoid c₁ ℓ₁) (S₂ : Setoid c₂ ℓ₂) where - - open Setoid S₁ renaming (Carrier to A₁; _≈_ to _≈₁_; refl to refl₁) - open Setoid S₂ renaming (Carrier to A₂; _≈_ to _≈₂_; refl to refl₂) - open Equality S₁ using ([]; _∷_) renaming (_≋_ to _≋₁_) - open Equality S₂ using () renaming (_≋_ to _≋₂_) - open Membership S₁ - - mapWith∈-cong : ∀ {xs ys} → xs ≋₁ ys → - (f : ∀ {x} → x ∈ xs → A₂) → - (g : ∀ {y} → y ∈ ys → A₂) → - (∀ {x y} → x ≈₁ y → (x∈xs : x ∈ xs) (y∈ys : y ∈ ys) → - f x∈xs ≈₂ g y∈ys) → - mapWith∈ xs f ≋₂ mapWith∈ ys g - mapWith∈-cong [] f g cong = [] - mapWith∈-cong (x≈y ∷ xs≋ys) f g cong = - cong x≈y (here refl₁) (here refl₁) ∷ - mapWith∈-cong xs≋ys (f ∘ there) (g ∘ there) - (λ x≈y x∈xs y∈ys → cong x≈y (there x∈xs) (there y∈ys)) - - mapWith∈≗map : ∀ f xs → mapWith∈ xs (λ {x} _ → f x) ≋₂ map f xs - mapWith∈≗map f [] = [] - mapWith∈≗map f (x ∷ xs) = refl₂ ∷ mapWith∈≗map f xs - - -module _ (S : Setoid c ℓ) where - - open Setoid S - open Membership S +open import Data.Fin.Base using (Fin; zero; suc) +open import Data.Fin.Properties using (suc-injective) +open import Data.List.Base hiding (find) +open import Data.List.Relation.Unary.Any as Any using (Any; here; there) +open import Data.List.Relation.Unary.All as All using (All) +import Data.List.Relation.Unary.Any.Properties as Any +import Data.List.Membership.Setoid as Membership +import Data.List.Relation.Binary.Equality.Setoid as Equality +import Data.List.Relation.Unary.Unique.Setoid as Unique +open import Data.Nat.Base using (suc; z≤n; s≤s; _≤_; _<_) +open import Data.Nat.Properties using (≤-trans; n≤1+n) +open import Data.Product.Base as Prod using (∃; _×_; _,_ ; ∃₂; proj₁; proj₂) +open import Data.Product.Relation.Binary.Pointwise.NonDependent using (_×ₛ_) +open import Data.Sum.Base using (_⊎_; inj₁; inj₂; [_,_]′) +open import Function.Base using (_$_; flip; _∘_; _∘′_; id) +open import Function.Bundles using (_↔_) +open import Level using (Level) +open import Relation.Binary.Core using (Rel; _Preserves₂_⟶_⟶_; _Preserves_⟶_) +open import Relation.Binary.Definitions as B hiding (Decidable) +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Binary.PropositionalEquality.Core as P using (_≡_) +open import Relation.Unary as U using (Decidable; Pred) +open import Relation.Nullary using (¬_; does; _because_; yes; no) +open import Relation.Nullary.Reflects using (invert) +open import Relation.Nullary.Negation using (contradiction) +open import Relation.Nullary.Decidable using (¬?) +open Setoid using (Carrier) + +private + variable + c c₁ c₂ c₃ p ℓ ℓ₁ ℓ₂ ℓ₃ : Level + +------------------------------------------------------------------------ +-- Equality properties + +module _ (S : Setoid c ℓ) where + + open Setoid S + open Equality S + open Membership S + + -- _∈_ respects the underlying equality + + ∈-resp-≈ : ∀ {xs} → (_∈ xs) Respects _≈_ + ∈-resp-≈ x≈y x∈xs = Any.map (trans (sym x≈y)) x∈xs + + ∉-resp-≈ : ∀ {xs} → (_∉ xs) Respects _≈_ + ∉-resp-≈ v≈w v∉xs w∈xs = v∉xs (∈-resp-≈ (sym v≈w) w∈xs) + + ∈-resp-≋ : ∀ {x} → (x ∈_) Respects _≋_ + ∈-resp-≋ = Any.lift-resp (flip trans) + + ∉-resp-≋ : ∀ {x} → (x ∉_) Respects _≋_ + ∉-resp-≋ xs≋ys v∉xs v∈ys = v∉xs (∈-resp-≋ (≋-sym xs≋ys) v∈ys) + + -- index is injective in its first argument. + + index-injective : ∀ {x₁ x₂ xs} (x₁∈xs : x₁ ∈ xs) (x₂∈xs : x₂ ∈ xs) → + Any.index x₁∈xs ≡ Any.index x₂∈xs → x₁ ≈ x₂ + index-injective (here x₁≈x) (here x₂≈x) _ = trans x₁≈x (sym x₂≈x) + index-injective (there x₁∈xs) (there x₂∈xs) eq = index-injective x₁∈xs x₂∈xs (suc-injective eq) + +------------------------------------------------------------------------ +-- Irrelevance + +module _ (S : Setoid c ℓ) where + + open Setoid S + open Unique S + open Membership S + + private + ∉×∈⇒≉ : ∀ {x y xs} → All (y ≉_) xs → x ∈ xs → x ≉ y + ∉×∈⇒≉ = All.lookupWith λ y≉z x≈z x≈y → y≉z (trans (sym x≈y) x≈z) + + unique⇒irrelevant : B.Irrelevant _≈_ → ∀ {xs} → Unique xs → U.Irrelevant (_∈ xs) + unique⇒irrelevant ≈-irr _ (here p) (here q) = + P.cong here (≈-irr p q) + unique⇒irrelevant ≈-irr (_ ∷ u) (there p) (there q) = + P.cong there (unique⇒irrelevant ≈-irr u p q) + unique⇒irrelevant ≈-irr (≉s ∷ _) (here p) (there q) = + contradiction p (∉×∈⇒≉ ≉s q) + unique⇒irrelevant ≈-irr (≉s ∷ _) (there p) (here q) = + contradiction q (∉×∈⇒≉ ≉s p) + +------------------------------------------------------------------------ +-- mapWith∈ + +module _ (S₁ : Setoid c₁ ℓ₁) (S₂ : Setoid c₂ ℓ₂) where + + open Setoid S₁ renaming (Carrier to A₁; _≈_ to _≈₁_; refl to refl₁) + open Setoid S₂ renaming (Carrier to A₂; _≈_ to _≈₂_; refl to refl₂) + open Equality S₁ using ([]; _∷_) renaming (_≋_ to _≋₁_) + open Equality S₂ using () renaming (_≋_ to _≋₂_) + open Membership S₁ + + mapWith∈-cong : ∀ {xs ys} → xs ≋₁ ys → + (f : ∀ {x} → x ∈ xs → A₂) → + (g : ∀ {y} → y ∈ ys → A₂) → + (∀ {x y} → x ≈₁ y → (x∈xs : x ∈ xs) (y∈ys : y ∈ ys) → + f x∈xs ≈₂ g y∈ys) → + mapWith∈ xs f ≋₂ mapWith∈ ys g + mapWith∈-cong [] f g cong = [] + mapWith∈-cong (x≈y ∷ xs≋ys) f g cong = + cong x≈y (here refl₁) (here refl₁) ∷ + mapWith∈-cong xs≋ys (f ∘ there) (g ∘ there) + (λ x≈y x∈xs y∈ys → cong x≈y (there x∈xs) (there y∈ys)) + + mapWith∈≗map : ∀ f xs → mapWith∈ xs (λ {x} _ → f x) ≋₂ map f xs + mapWith∈≗map f [] = [] + mapWith∈≗map f (x ∷ xs) = refl₂ ∷ mapWith∈≗map f xs - length-mapWith∈ : ∀ {a} {A : Set a} xs {f : ∀ {x} → x ∈ xs → A} → - length (mapWith∈ xs f) ≡ length xs - length-mapWith∈ [] = P.refl - length-mapWith∈ (x ∷ xs) = P.cong suc (length-mapWith∈ xs) - mapWith∈-id : ∀ xs → mapWith∈ xs (λ {x} _ → x) ≡ xs - mapWith∈-id [] = P.refl - mapWith∈-id (x ∷ xs) = P.cong (x ∷_) (mapWith∈-id xs) +module _ (S : Setoid c ℓ) where - map-mapWith∈ : ∀ {a b} {A : Set a} {B : Set b} → - ∀ xs (f : ∀ {x} → x ∈ xs → A) (g : A → B) → - map g (mapWith∈ xs f) ≡ mapWith∈ xs (g ∘′ f) - map-mapWith∈ [] f g = P.refl - map-mapWith∈ (x ∷ xs) f g = P.cong (_ ∷_) (map-mapWith∈ xs (f ∘ there) g) + open Setoid S + open Membership S ------------------------------------------------------------------------- --- map + length-mapWith∈ : ∀ {a} {A : Set a} xs {f : ∀ {x} → x ∈ xs → A} → + length (mapWith∈ xs f) ≡ length xs + length-mapWith∈ [] = P.refl + length-mapWith∈ (x ∷ xs) = P.cong suc (length-mapWith∈ xs) -module _ (S₁ : Setoid c₁ ℓ₁) (S₂ : Setoid c₂ ℓ₂) where + mapWith∈-id : ∀ xs → mapWith∈ xs (λ {x} _ → x) ≡ xs + mapWith∈-id [] = P.refl + mapWith∈-id (x ∷ xs) = P.cong (x ∷_) (mapWith∈-id xs) - open Setoid S₁ renaming (Carrier to A₁; _≈_ to _≈₁_; refl to refl₁) - open Setoid S₂ renaming (Carrier to A₂; _≈_ to _≈₂_) - private module M₁ = Membership S₁; open M₁ using (find) renaming (_∈_ to _∈₁_) - private module M₂ = Membership S₂; open M₂ using () renaming (_∈_ to _∈₂_) + map-mapWith∈ : ∀ {a b} {A : Set a} {B : Set b} → + ∀ xs (f : ∀ {x} → x ∈ xs → A) (g : A → B) → + map g (mapWith∈ xs f) ≡ mapWith∈ xs (g ∘′ f) + map-mapWith∈ [] f g = P.refl + map-mapWith∈ (x ∷ xs) f g = P.cong (_ ∷_) (map-mapWith∈ xs (f ∘ there) g) - ∈-map⁺ : ∀ {f} → f Preserves _≈₁_ ⟶ _≈₂_ → ∀ {v xs} → - v ∈₁ xs → f v ∈₂ map f xs - ∈-map⁺ pres x∈xs = Any.map⁺ (Any.map pres x∈xs) +------------------------------------------------------------------------ +-- map - ∈-map⁻ : ∀ {v xs f} → v ∈₂ map f xs → - ∃ λ x → x ∈₁ xs × v ≈₂ f x - ∈-map⁻ x∈map = find (Any.map⁻ x∈map) +module _ (S₁ : Setoid c₁ ℓ₁) (S₂ : Setoid c₂ ℓ₂) where - map-∷= : ∀ {f} (f≈ : f Preserves _≈₁_ ⟶ _≈₂_) - {xs x v} → (x∈xs : x ∈₁ xs) → - map f (x∈xs M₁.∷= v) ≡ ∈-map⁺ f≈ x∈xs M₂.∷= f v - map-∷= f≈ (here x≈y) = P.refl - map-∷= f≈ (there x∈xs) = P.cong (_ ∷_) (map-∷= f≈ x∈xs) + open Setoid S₁ renaming (Carrier to A₁; _≈_ to _≈₁_; refl to refl₁) + open Setoid S₂ renaming (Carrier to A₂; _≈_ to _≈₂_) + private module M₁ = Membership S₁; open M₁ using (find) renaming (_∈_ to _∈₁_) + private module M₂ = Membership S₂; open M₂ using () renaming (_∈_ to _∈₂_) ------------------------------------------------------------------------- --- _++_ + ∈-map⁺ : ∀ {f} → f Preserves _≈₁_ ⟶ _≈₂_ → ∀ {v xs} → + v ∈₁ xs → f v ∈₂ map f xs + ∈-map⁺ pres x∈xs = Any.map⁺ (Any.map pres x∈xs) -module _ (S : Setoid c ℓ) where + ∈-map⁻ : ∀ {v xs f} → v ∈₂ map f xs → + ∃ λ x → x ∈₁ xs × v ≈₂ f x + ∈-map⁻ x∈map = find (Any.map⁻ x∈map) - open Membership S using (_∈_) - open Setoid S - open Equality S using (_≋_; _∷_; ≋-refl) + map-∷= : ∀ {f} (f≈ : f Preserves _≈₁_ ⟶ _≈₂_) + {xs x v} → (x∈xs : x ∈₁ xs) → + map f (x∈xs M₁.∷= v) ≡ ∈-map⁺ f≈ x∈xs M₂.∷= f v + map-∷= f≈ (here x≈y) = P.refl + map-∷= f≈ (there x∈xs) = P.cong (_ ∷_) (map-∷= f≈ x∈xs) - ∈-++⁺ˡ : ∀ {v xs ys} → v ∈ xs → v ∈ xs ++ ys - ∈-++⁺ˡ = Any.++⁺ˡ +------------------------------------------------------------------------ +-- _++_ - ∈-++⁺ʳ : ∀ {v} xs {ys} → v ∈ ys → v ∈ xs ++ ys - ∈-++⁺ʳ = Any.++⁺ʳ - - ∈-++⁻ : ∀ {v} xs {ys} → v ∈ xs ++ ys → (v ∈ xs) ⊎ (v ∈ ys) - ∈-++⁻ = Any.++⁻ +module _ (S : Setoid c ℓ) where - ∈-++⁺∘++⁻ : ∀ {v} xs {ys} (p : v ∈ xs ++ ys) → - [ ∈-++⁺ˡ , ∈-++⁺ʳ xs ]′ (∈-++⁻ xs p) ≡ p - ∈-++⁺∘++⁻ = Any.++⁺∘++⁻ + open Membership S using (_∈_) + open Setoid S + open Equality S using (_≋_; _∷_; ≋-refl) - ∈-++⁻∘++⁺ : ∀ {v} xs {ys} (p : v ∈ xs ⊎ v ∈ ys) → - ∈-++⁻ xs ([ ∈-++⁺ˡ , ∈-++⁺ʳ xs ]′ p) ≡ p - ∈-++⁻∘++⁺ = Any.++⁻∘++⁺ + ∈-++⁺ˡ : ∀ {v xs ys} → v ∈ xs → v ∈ xs ++ ys + ∈-++⁺ˡ = Any.++⁺ˡ - ∈-++↔ : ∀ {v xs ys} → (v ∈ xs ⊎ v ∈ ys) ↔ v ∈ xs ++ ys - ∈-++↔ = Any.++↔ + ∈-++⁺ʳ : ∀ {v} xs {ys} → v ∈ ys → v ∈ xs ++ ys + ∈-++⁺ʳ = Any.++⁺ʳ + + ∈-++⁻ : ∀ {v} xs {ys} → v ∈ xs ++ ys → (v ∈ xs) ⊎ (v ∈ ys) + ∈-++⁻ = Any.++⁻ - ∈-++-comm : ∀ {v} xs ys → v ∈ xs ++ ys → v ∈ ys ++ xs - ∈-++-comm = Any.++-comm + ∈-++⁺∘++⁻ : ∀ {v} xs {ys} (p : v ∈ xs ++ ys) → + [ ∈-++⁺ˡ , ∈-++⁺ʳ xs ]′ (∈-++⁻ xs p) ≡ p + ∈-++⁺∘++⁻ = Any.++⁺∘++⁻ - ∈-++-comm∘++-comm : ∀ {v} xs {ys} (p : v ∈ xs ++ ys) → - ∈-++-comm ys xs (∈-++-comm xs ys p) ≡ p - ∈-++-comm∘++-comm = Any.++-comm∘++-comm + ∈-++⁻∘++⁺ : ∀ {v} xs {ys} (p : v ∈ xs ⊎ v ∈ ys) → + ∈-++⁻ xs ([ ∈-++⁺ˡ , ∈-++⁺ʳ xs ]′ p) ≡ p + ∈-++⁻∘++⁺ = Any.++⁻∘++⁺ - ∈-++↔++ : ∀ {v} xs ys → v ∈ xs ++ ys ↔ v ∈ ys ++ xs - ∈-++↔++ = Any.++↔++ + ∈-++↔ : ∀ {v xs ys} → (v ∈ xs ⊎ v ∈ ys) ↔ v ∈ xs ++ ys + ∈-++↔ = Any.++↔ - ∈-insert : ∀ xs {ys v w} → v ≈ w → v ∈ xs ++ [ w ] ++ ys - ∈-insert xs = Any.++-insert xs + ∈-++-comm : ∀ {v} xs ys → v ∈ xs ++ ys → v ∈ ys ++ xs + ∈-++-comm = Any.++-comm - ∈-∃++ : ∀ {v xs} → v ∈ xs → ∃₂ λ ys zs → ∃ λ w → - v ≈ w × xs ≋ ys ++ [ w ] ++ zs - ∈-∃++ (here px) = [] , _ , _ , px , ≋-refl - ∈-∃++ (there {d} v∈xs) with ∈-∃++ v∈xs - ... | hs , _ , _ , v≈v′ , eq = d ∷ hs , _ , _ , v≈v′ , refl ∷ eq + ∈-++-comm∘++-comm : ∀ {v} xs {ys} (p : v ∈ xs ++ ys) → + ∈-++-comm ys xs (∈-++-comm xs ys p) ≡ p + ∈-++-comm∘++-comm = Any.++-comm∘++-comm ------------------------------------------------------------------------- --- concat + ∈-++↔++ : ∀ {v} xs ys → v ∈ xs ++ ys ↔ v ∈ ys ++ xs + ∈-++↔++ = Any.++↔++ -module _ (S : Setoid c ℓ) where + ∈-insert : ∀ xs {ys v w} → v ≈ w → v ∈ xs ++ [ w ] ++ ys + ∈-insert xs = Any.++-insert xs - open Setoid S using (_≈_) - open Membership S using (_∈_) - open Equality S using (≋-setoid) - open Membership ≋-setoid using (find) renaming (_∈_ to _∈ₗ_) + ∈-∃++ : ∀ {v xs} → v ∈ xs → ∃₂ λ ys zs → ∃ λ w → + v ≈ w × xs ≋ ys ++ [ w ] ++ zs + ∈-∃++ (here px) = [] , _ , _ , px , ≋-refl + ∈-∃++ (there {d} v∈xs) with ∈-∃++ v∈xs + ... | hs , _ , _ , v≈v′ , eq = d ∷ hs , _ , _ , v≈v′ , refl ∷ eq - ∈-concat⁺ : ∀ {v xss} → Any (v ∈_) xss → v ∈ concat xss - ∈-concat⁺ = Any.concat⁺ +------------------------------------------------------------------------ +-- concat - ∈-concat⁻ : ∀ {v} xss → v ∈ concat xss → Any (v ∈_) xss - ∈-concat⁻ = Any.concat⁻ +module _ (S : Setoid c ℓ) where - ∈-concat⁺′ : ∀ {v vs xss} → v ∈ vs → vs ∈ₗ xss → v ∈ concat xss - ∈-concat⁺′ v∈vs = ∈-concat⁺ ∘ Any.map (flip (∈-resp-≋ S) v∈vs) + open Setoid S using (_≈_) + open Membership S using (_∈_) + open Equality S using (≋-setoid) + open Membership ≋-setoid using (find) renaming (_∈_ to _∈ₗ_) - ∈-concat⁻′ : ∀ {v} xss → v ∈ concat xss → ∃ λ xs → v ∈ xs × xs ∈ₗ xss - ∈-concat⁻′ xss v∈c[xss] with find (∈-concat⁻ xss v∈c[xss]) - ... | xs , t , s = xs , s , t + ∈-concat⁺ : ∀ {v xss} → Any (v ∈_) xss → v ∈ concat xss + ∈-concat⁺ = Any.concat⁺ ------------------------------------------------------------------------- --- cartesianProductWith + ∈-concat⁻ : ∀ {v} xss → v ∈ concat xss → Any (v ∈_) xss + ∈-concat⁻ = Any.concat⁻ -module _ (S₁ : Setoid c₁ ℓ₁) (S₂ : Setoid c₂ ℓ₂) (S₃ : Setoid c₃ ℓ₃) where + ∈-concat⁺′ : ∀ {v vs xss} → v ∈ vs → vs ∈ₗ xss → v ∈ concat xss + ∈-concat⁺′ v∈vs = ∈-concat⁺ ∘ Any.map (flip (∈-resp-≋ S) v∈vs) - open Setoid S₁ renaming (_≈_ to _≈₁_; refl to refl₁) - open Setoid S₂ renaming (_≈_ to _≈₂_) - open Setoid S₃ renaming (_≈_ to _≈₃_) - open Membership S₁ renaming (_∈_ to _∈₁_) - open Membership S₂ renaming (_∈_ to _∈₂_) - open Membership S₃ renaming (_∈_ to _∈₃_) + ∈-concat⁻′ : ∀ {v} xss → v ∈ concat xss → ∃ λ xs → v ∈ xs × xs ∈ₗ xss + ∈-concat⁻′ xss v∈c[xss] with find (∈-concat⁻ xss v∈c[xss]) + ... | xs , t , s = xs , s , t - ∈-cartesianProductWith⁺ : ∀ {f} → f Preserves₂ _≈₁_ ⟶ _≈₂_ ⟶ _≈₃_ → - ∀ {xs ys a b} → a ∈₁ xs → b ∈₂ ys → - f a b ∈₃ cartesianProductWith f xs ys - ∈-cartesianProductWith⁺ pres = Any.cartesianProductWith⁺ _ pres +------------------------------------------------------------------------ +-- cartesianProductWith - ∈-cartesianProductWith⁻ : ∀ f xs ys {v} → v ∈₃ cartesianProductWith f xs ys → - ∃₂ λ a b → a ∈₁ xs × b ∈₂ ys × v ≈₃ f a b - ∈-cartesianProductWith⁻ f (x ∷ xs) ys v∈c with ∈-++⁻ S₃ (map (f x) ys) v∈c - ∈-cartesianProductWith⁻ f (x ∷ xs) ys v∈c | inj₁ v∈map with ∈-map⁻ S₂ S₃ v∈map - ... | (b , b∈ys , v≈fxb) = x , b , here refl₁ , b∈ys , v≈fxb - ∈-cartesianProductWith⁻ f (x ∷ xs) ys v∈c | inj₂ v∈com with ∈-cartesianProductWith⁻ f xs ys v∈com - ... | (a , b , a∈xs , b∈ys , v≈fab) = a , b , there a∈xs , b∈ys , v≈fab +module _ (S₁ : Setoid c₁ ℓ₁) (S₂ : Setoid c₂ ℓ₂) (S₃ : Setoid c₃ ℓ₃) where ------------------------------------------------------------------------- --- cartesianProduct + open Setoid S₁ renaming (_≈_ to _≈₁_; refl to refl₁) + open Setoid S₂ renaming (_≈_ to _≈₂_) + open Setoid S₃ renaming (_≈_ to _≈₃_) + open Membership S₁ renaming (_∈_ to _∈₁_) + open Membership S₂ renaming (_∈_ to _∈₂_) + open Membership S₃ renaming (_∈_ to _∈₃_) -module _ (S₁ : Setoid c₁ ℓ₁) (S₂ : Setoid c₂ ℓ₂) where + ∈-cartesianProductWith⁺ : ∀ {f} → f Preserves₂ _≈₁_ ⟶ _≈₂_ ⟶ _≈₃_ → + ∀ {xs ys a b} → a ∈₁ xs → b ∈₂ ys → + f a b ∈₃ cartesianProductWith f xs ys + ∈-cartesianProductWith⁺ pres = Any.cartesianProductWith⁺ _ pres - open Setoid S₁ renaming (Carrier to A) - open Setoid S₂ renaming (Carrier to B) - open Membership S₁ renaming (_∈_ to _∈₁_) - open Membership S₂ renaming (_∈_ to _∈₂_) - open Membership (S₁ ×ₛ S₂) renaming (_∈_ to _∈₁₂_) + ∈-cartesianProductWith⁻ : ∀ f xs ys {v} → v ∈₃ cartesianProductWith f xs ys → + ∃₂ λ a b → a ∈₁ xs × b ∈₂ ys × v ≈₃ f a b + ∈-cartesianProductWith⁻ f (x ∷ xs) ys v∈c with ∈-++⁻ S₃ (map (f x) ys) v∈c + ∈-cartesianProductWith⁻ f (x ∷ xs) ys v∈c | inj₁ v∈map with ∈-map⁻ S₂ S₃ v∈map + ... | (b , b∈ys , v≈fxb) = x , b , here refl₁ , b∈ys , v≈fxb + ∈-cartesianProductWith⁻ f (x ∷ xs) ys v∈c | inj₂ v∈com with ∈-cartesianProductWith⁻ f xs ys v∈com + ... | (a , b , a∈xs , b∈ys , v≈fab) = a , b , there a∈xs , b∈ys , v≈fab - ∈-cartesianProduct⁺ : ∀ {x y xs ys} → x ∈₁ xs → y ∈₂ ys → - (x , y) ∈₁₂ cartesianProduct xs ys - ∈-cartesianProduct⁺ = Any.cartesianProduct⁺ +------------------------------------------------------------------------ +-- cartesianProduct - ∈-cartesianProduct⁻ : ∀ xs ys {xy@(x , y) : A × B} → - xy ∈₁₂ cartesianProduct xs ys → - x ∈₁ xs × y ∈₂ ys - ∈-cartesianProduct⁻ xs ys = Any.cartesianProduct⁻ xs ys +module _ (S₁ : Setoid c₁ ℓ₁) (S₂ : Setoid c₂ ℓ₂) where ------------------------------------------------------------------------- --- applyUpTo + open Setoid S₁ renaming (Carrier to A) + open Setoid S₂ renaming (Carrier to B) + open Membership S₁ renaming (_∈_ to _∈₁_) + open Membership S₂ renaming (_∈_ to _∈₂_) + open Membership (S₁ ×ₛ S₂) renaming (_∈_ to _∈₁₂_) -module _ (S : Setoid c ℓ) where + ∈-cartesianProduct⁺ : ∀ {x y xs ys} → x ∈₁ xs → y ∈₂ ys → + (x , y) ∈₁₂ cartesianProduct xs ys + ∈-cartesianProduct⁺ = Any.cartesianProduct⁺ - open Setoid S using (_≈_; refl) - open Membership S using (_∈_) + ∈-cartesianProduct⁻ : ∀ xs ys {xy@(x , y) : A × B} → + xy ∈₁₂ cartesianProduct xs ys → + x ∈₁ xs × y ∈₂ ys + ∈-cartesianProduct⁻ xs ys = Any.cartesianProduct⁻ xs ys - ∈-applyUpTo⁺ : ∀ f {i n} → i < n → f i ∈ applyUpTo f n - ∈-applyUpTo⁺ f = Any.applyUpTo⁺ f refl +------------------------------------------------------------------------ +-- applyUpTo - ∈-applyUpTo⁻ : ∀ {v} f {n} → v ∈ applyUpTo f n → - ∃ λ i → i < n × v ≈ f i - ∈-applyUpTo⁻ = Any.applyUpTo⁻ +module _ (S : Setoid c ℓ) where ------------------------------------------------------------------------- --- applyDownFrom + open Setoid S using (_≈_; refl) + open Membership S using (_∈_) - ∈-applyDownFrom⁺ : ∀ f {i n} → i < n → f i ∈ applyDownFrom f n - ∈-applyDownFrom⁺ f = Any.applyDownFrom⁺ f refl + ∈-applyUpTo⁺ : ∀ f {i n} → i < n → f i ∈ applyUpTo f n + ∈-applyUpTo⁺ f = Any.applyUpTo⁺ f refl - ∈-applyDownFrom⁻ : ∀ {v} f {n} → v ∈ applyDownFrom f n → - ∃ λ i → i < n × v ≈ f i - ∈-applyDownFrom⁻ = Any.applyDownFrom⁻ + ∈-applyUpTo⁻ : ∀ {v} f {n} → v ∈ applyUpTo f n → + ∃ λ i → i < n × v ≈ f i + ∈-applyUpTo⁻ = Any.applyUpTo⁻ ------------------------------------------------------------------------- --- tabulate +------------------------------------------------------------------------ +-- applyDownFrom -module _ (S : Setoid c ℓ) where + ∈-applyDownFrom⁺ : ∀ f {i n} → i < n → f i ∈ applyDownFrom f n + ∈-applyDownFrom⁺ f = Any.applyDownFrom⁺ f refl - open Setoid S using (_≈_; refl) renaming (Carrier to A) - open Membership S using (_∈_) + ∈-applyDownFrom⁻ : ∀ {v} f {n} → v ∈ applyDownFrom f n → + ∃ λ i → i < n × v ≈ f i + ∈-applyDownFrom⁻ = Any.applyDownFrom⁻ - ∈-tabulate⁺ : ∀ {n} {f : Fin n → A} i → f i ∈ tabulate f - ∈-tabulate⁺ i = Any.tabulate⁺ i refl +------------------------------------------------------------------------ +-- tabulate - ∈-tabulate⁻ : ∀ {n} {f : Fin n → A} {v} → - v ∈ tabulate f → ∃ λ i → v ≈ f i - ∈-tabulate⁻ = Any.tabulate⁻ +module _ (S : Setoid c ℓ) where ------------------------------------------------------------------------- --- filter + open Setoid S using (_≈_; refl) renaming (Carrier to A) + open Membership S using (_∈_) -module _ (S : Setoid c ℓ) {P : Pred (Carrier S) p} - (P? : Decidable P) (resp : P Respects (Setoid._≈_ S)) where + ∈-tabulate⁺ : ∀ {n} {f : Fin n → A} i → f i ∈ tabulate f + ∈-tabulate⁺ i = Any.tabulate⁺ i refl - open Setoid S using (_≈_; sym) - open Membership S using (_∈_) + ∈-tabulate⁻ : ∀ {n} {f : Fin n → A} {v} → + v ∈ tabulate f → ∃ λ i → v ≈ f i + ∈-tabulate⁻ = Any.tabulate⁻ - ∈-filter⁺ : ∀ {v xs} → v ∈ xs → P v → v ∈ filter P? xs - ∈-filter⁺ {xs = x ∷ _} (here v≈x) Pv with P? x - ... | true because _ = here v≈x - ... | false because [¬Px] = contradiction (resp v≈x Pv) (invert [¬Px]) - ∈-filter⁺ {xs = x ∷ _} (there v∈xs) Pv with does (P? x) - ... | true = there (∈-filter⁺ v∈xs Pv) - ... | false = ∈-filter⁺ v∈xs Pv +------------------------------------------------------------------------ +-- filter - ∈-filter⁻ : ∀ {v xs} → v ∈ filter P? xs → v ∈ xs × P v - ∈-filter⁻ {xs = x ∷ xs} v∈f[x∷xs] with P? x - ... | false because _ = Prod.map there id (∈-filter⁻ v∈f[x∷xs]) - ... | true because [Px] with v∈f[x∷xs] - ... | here v≈x = here v≈x , resp (sym v≈x) (invert [Px]) - ... | there v∈fxs = Prod.map there id (∈-filter⁻ v∈fxs) +module _ (S : Setoid c ℓ) {P : Pred (Carrier S) p} + (P? : Decidable P) (resp : P Respects (Setoid._≈_ S)) where ------------------------------------------------------------------------- --- derun and deduplicate + open Setoid S using (_≈_; sym) + open Membership S using (_∈_) -module _ (S : Setoid c ℓ) {R : Rel (Carrier S) ℓ₂} (R? : B.Decidable R) where + ∈-filter⁺ : ∀ {v xs} → v ∈ xs → P v → v ∈ filter P? xs + ∈-filter⁺ {xs = x ∷ _} (here v≈x) Pv with P? x + ... | true because _ = here v≈x + ... | false because [¬Px] = contradiction (resp v≈x Pv) (invert [¬Px]) + ∈-filter⁺ {xs = x ∷ _} (there v∈xs) Pv with does (P? x) + ... | true = there (∈-filter⁺ v∈xs Pv) + ... | false = ∈-filter⁺ v∈xs Pv - open Setoid S using (_≈_) - open Membership S using (_∈_) + ∈-filter⁻ : ∀ {v xs} → v ∈ filter P? xs → v ∈ xs × P v + ∈-filter⁻ {xs = x ∷ xs} v∈f[x∷xs] with P? x + ... | false because _ = Prod.map there id (∈-filter⁻ v∈f[x∷xs]) + ... | true because [Px] with v∈f[x∷xs] + ... | here v≈x = here v≈x , resp (sym v≈x) (invert [Px]) + ... | there v∈fxs = Prod.map there id (∈-filter⁻ v∈fxs) - ∈-derun⁺ : _≈_ Respectsʳ R → ∀ {xs z} → z ∈ xs → z ∈ derun R? xs - ∈-derun⁺ ≈-resp-R z∈xs = Any.derun⁺ R? ≈-resp-R z∈xs +------------------------------------------------------------------------ +-- derun and deduplicate - ∈-deduplicate⁺ : _≈_ Respectsʳ (flip R) → ∀ {xs z} → - z ∈ xs → z ∈ deduplicate R? xs - ∈-deduplicate⁺ ≈-resp-R z∈xs = Any.deduplicate⁺ R? ≈-resp-R z∈xs +module _ (S : Setoid c ℓ) {R : Rel (Carrier S) ℓ₂} (R? : B.Decidable R) where - ∈-derun⁻ : ∀ xs {z} → z ∈ derun R? xs → z ∈ xs - ∈-derun⁻ xs z∈derun[R,xs] = Any.derun⁻ R? z∈derun[R,xs] + open Setoid S using (_≈_) + open Membership S using (_∈_) - ∈-deduplicate⁻ : ∀ xs {z} → z ∈ deduplicate R? xs → z ∈ xs - ∈-deduplicate⁻ xs z∈dedup[R,xs] = Any.deduplicate⁻ R? z∈dedup[R,xs] + ∈-derun⁺ : _≈_ Respectsʳ R → ∀ {xs z} → z ∈ xs → z ∈ derun R? xs + ∈-derun⁺ ≈-resp-R z∈xs = Any.derun⁺ R? ≈-resp-R z∈xs ------------------------------------------------------------------------- --- length + ∈-deduplicate⁺ : _≈_ Respectsʳ (flip R) → ∀ {xs z} → + z ∈ xs → z ∈ deduplicate R? xs + ∈-deduplicate⁺ ≈-resp-R z∈xs = Any.deduplicate⁺ R? ≈-resp-R z∈xs -module _ (S : Setoid c ℓ) where + ∈-derun⁻ : ∀ xs {z} → z ∈ derun R? xs → z ∈ xs + ∈-derun⁻ xs z∈derun[R,xs] = Any.derun⁻ R? z∈derun[R,xs] - open Membership S using (_∈_) + ∈-deduplicate⁻ : ∀ xs {z} → z ∈ deduplicate R? xs → z ∈ xs + ∈-deduplicate⁻ xs z∈dedup[R,xs] = Any.deduplicate⁻ R? z∈dedup[R,xs] - ∈-length : ∀ {x xs} → x ∈ xs → 1 ≤ length xs - ∈-length (here px) = s≤s z≤n - ∈-length (there x∈xs) = ≤-trans (∈-length x∈xs) (n≤1+n _) +------------------------------------------------------------------------ +-- length ------------------------------------------------------------------------- --- lookup +module _ (S : Setoid c ℓ) where -module _ (S : Setoid c ℓ) where + open Membership S using (_∈_) - open Setoid S using (refl) - open Membership S using (_∈_) + ∈-length : ∀ {x xs} → x ∈ xs → 1 ≤ length xs + ∈-length (here px) = s≤s z≤n + ∈-length (there x∈xs) = ≤-trans (∈-length x∈xs) (n≤1+n _) - ∈-lookup : ∀ xs i → lookup xs i ∈ xs - ∈-lookup (x ∷ xs) zero = here refl - ∈-lookup (x ∷ xs) (suc i) = there (∈-lookup xs i) +------------------------------------------------------------------------ +-- lookup ------------------------------------------------------------------------- --- foldr +module _ (S : Setoid c ℓ) where -module _ (S : Setoid c ℓ) {_•_ : Op₂ (Carrier S)} where + open Setoid S using (refl) + open Membership S using (_∈_) - open Setoid S using (_≈_; refl; sym; trans) - open Membership S using (_∈_) + ∈-lookup : ∀ xs i → lookup xs i ∈ xs + ∈-lookup (x ∷ xs) zero = here refl + ∈-lookup (x ∷ xs) (suc i) = there (∈-lookup xs i) - foldr-selective : Selective _≈_ _•_ → ∀ e xs → - (foldr _•_ e xs ≈ e) ⊎ (foldr _•_ e xs ∈ xs) - foldr-selective •-sel i [] = inj₁ refl - foldr-selective •-sel i (x ∷ xs) with •-sel x (foldr _•_ i xs) - ... | inj₁ x•f≈x = inj₂ (here x•f≈x) - ... | inj₂ x•f≈f with foldr-selective •-sel i xs - ... | inj₁ f≈i = inj₁ (trans x•f≈f f≈i) - ... | inj₂ f∈xs = inj₂ (∈-resp-≈ S (sym x•f≈f) (there f∈xs)) +------------------------------------------------------------------------ +-- foldr ------------------------------------------------------------------------- --- _∷=_ +module _ (S : Setoid c ℓ) {_•_ : Op₂ (Carrier S)} where -module _ (S : Setoid c ℓ) where + open Setoid S using (_≈_; refl; sym; trans) + open Membership S using (_∈_) - open Setoid S - open Membership S + foldr-selective : Selective _≈_ _•_ → ∀ e xs → + (foldr _•_ e xs ≈ e) ⊎ (foldr _•_ e xs ∈ xs) + foldr-selective •-sel i [] = inj₁ refl + foldr-selective •-sel i (x ∷ xs) with •-sel x (foldr _•_ i xs) + ... | inj₁ x•f≈x = inj₂ (here x•f≈x) + ... | inj₂ x•f≈f with foldr-selective •-sel i xs + ... | inj₁ f≈i = inj₁ (trans x•f≈f f≈i) + ... | inj₂ f∈xs = inj₂ (∈-resp-≈ S (sym x•f≈f) (there f∈xs)) - ∈-∷=⁺-updated : ∀ {xs x v} (x∈xs : x ∈ xs) → v ∈ (x∈xs ∷= v) - ∈-∷=⁺-updated (here px) = here refl - ∈-∷=⁺-updated (there pxs) = there (∈-∷=⁺-updated pxs) +------------------------------------------------------------------------ +-- _∷=_ - ∈-∷=⁺-untouched : ∀ {xs x y v} (x∈xs : x ∈ xs) → (¬ x ≈ y) → y ∈ xs → y ∈ (x∈xs ∷= v) - ∈-∷=⁺-untouched (here x≈z) x≉y (here y≈z) = contradiction (trans x≈z (sym y≈z)) x≉y - ∈-∷=⁺-untouched (here x≈z) x≉y (there y∈xs) = there y∈xs - ∈-∷=⁺-untouched (there x∈xs) x≉y (here y≈z) = here y≈z - ∈-∷=⁺-untouched (there x∈xs) x≉y (there y∈xs) = there (∈-∷=⁺-untouched x∈xs x≉y y∈xs) +module _ (S : Setoid c ℓ) where - ∈-∷=⁻ : ∀ {xs x y v} (x∈xs : x ∈ xs) → (¬ y ≈ v) → y ∈ (x∈xs ∷= v) → y ∈ xs - ∈-∷=⁻ (here x≈z) y≉v (here y≈v) = contradiction y≈v y≉v - ∈-∷=⁻ (here x≈z) y≉v (there y∈) = there y∈ - ∈-∷=⁻ (there x∈xs) y≉v (here y≈z) = here y≈z - ∈-∷=⁻ (there x∈xs) y≉v (there y∈) = there (∈-∷=⁻ x∈xs y≉v y∈) + open Setoid S + open Membership S + + ∈-∷=⁺-updated : ∀ {xs x v} (x∈xs : x ∈ xs) → v ∈ (x∈xs ∷= v) + ∈-∷=⁺-updated (here px) = here refl + ∈-∷=⁺-updated (there pxs) = there (∈-∷=⁺-updated pxs) + + ∈-∷=⁺-untouched : ∀ {xs x y v} (x∈xs : x ∈ xs) → (¬ x ≈ y) → y ∈ xs → y ∈ (x∈xs ∷= v) + ∈-∷=⁺-untouched (here x≈z) x≉y (here y≈z) = contradiction (trans x≈z (sym y≈z)) x≉y + ∈-∷=⁺-untouched (here x≈z) x≉y (there y∈xs) = there y∈xs + ∈-∷=⁺-untouched (there x∈xs) x≉y (here y≈z) = here y≈z + ∈-∷=⁺-untouched (there x∈xs) x≉y (there y∈xs) = there (∈-∷=⁺-untouched x∈xs x≉y y∈xs) + + ∈-∷=⁻ : ∀ {xs x y v} (x∈xs : x ∈ xs) → (¬ y ≈ v) → y ∈ (x∈xs ∷= v) → y ∈ xs + ∈-∷=⁻ (here x≈z) y≉v (here y≈v) = contradiction y≈v y≉v + ∈-∷=⁻ (here x≈z) y≉v (there y∈) = there y∈ + ∈-∷=⁻ (there x∈xs) y≉v (here y≈z) = here y≈z + ∈-∷=⁻ (there x∈xs) y≉v (there y∈) = there (∈-∷=⁻ x∈xs y≉v y∈) \ No newline at end of file diff --git a/Data.List.Membership.Setoid.html b/Data.List.Membership.Setoid.html index 6e7189e1..b65f6149 100644 --- a/Data.List.Membership.Setoid.html +++ b/Data.List.Membership.Setoid.html @@ -7,50 +7,52 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Binary.Definitions using (_Respects_) -module Data.List.Membership.Setoid {c ℓ} (S : Setoid c ℓ) where +module Data.List.Membership.Setoid {c ℓ} (S : Setoid c ℓ) where -open import Function.Base using (_∘_; id; flip) -open import Data.List.Base as List using (List; []; _∷_; length; lookup) -open import Data.List.Relation.Unary.Any - using (Any; index; map; here; there) -open import Data.Product as Prod using (∃; _×_; _,_) -open import Relation.Unary using (Pred) -open import Relation.Nullary.Negation using (¬_) +open import Function.Base using (_∘_; id; flip) +open import Data.List.Base as List using (List; []; _∷_; length; lookup) +open import Data.List.Relation.Unary.Any as Any + using (Any; index; map; here; there) +open import Data.Product.Base as Prod using (∃; _×_; _,_) +open import Relation.Unary using (Pred) +open import Relation.Nullary.Negation using (¬_) -open Setoid S renaming (Carrier to A) +open Setoid S renaming (Carrier to A) ------------------------------------------------------------------------- --- Definitions +------------------------------------------------------------------------ +-- Definitions -infix 4 _∈_ _∉_ +infix 4 _∈_ _∉_ -_∈_ : A → List A → Set _ -x ∈ xs = Any (x ≈_) xs +_∈_ : A → List A → Set _ +x ∈ xs = Any (x ≈_) xs -_∉_ : A → List A → Set _ -x ∉ xs = ¬ x ∈ xs +_∉_ : A → List A → Set _ +x ∉ xs = ¬ x ∈ xs ------------------------------------------------------------------------- --- Operations +------------------------------------------------------------------------ +-- Operations -open Data.List.Relation.Unary.Any using (_∷=_; _─_) public +_∷=_ = Any._∷=_ {A = A} +_─_ = Any._─_ {A = A} -mapWith∈ : ∀ {b} {B : Set b} - (xs : List A) → (∀ {x} → x ∈ xs → B) → List B -mapWith∈ [] f = [] -mapWith∈ (x ∷ xs) f = f (here refl) ∷ mapWith∈ xs (f ∘ there) +mapWith∈ : ∀ {b} {B : Set b} + (xs : List A) → (∀ {x} → x ∈ xs → B) → List B +mapWith∈ [] f = [] +mapWith∈ (x ∷ xs) f = f (here refl) ∷ mapWith∈ xs (f ∘ there) ------------------------------------------------------------------------- --- Finding and losing witnesses +------------------------------------------------------------------------ +-- Finding and losing witnesses -module _ {p} {P : Pred A p} where +module _ {p} {P : Pred A p} where - find : ∀ {xs} → Any P xs → ∃ λ x → x ∈ xs × P x - find (here px) = (_ , here refl , px) - find (there pxs) = Prod.map id (Prod.map there id) (find pxs) + find : ∀ {xs} → Any P xs → ∃ λ x → x ∈ xs × P x + find (here px) = (_ , here refl , px) + find (there pxs) = Prod.map id (Prod.map there id) (find pxs) - lose : P Respects _≈_ → ∀ {x xs} → x ∈ xs → P x → Any P xs - lose resp x∈xs px = map (flip resp px) x∈xs + lose : P Respects _≈_ → ∀ {x xs} → x ∈ xs → P x → Any P xs + lose resp x∈xs px = map (flip resp px) x∈xs \ No newline at end of file diff --git a/Data.List.NonEmpty.Base.html b/Data.List.NonEmpty.Base.html index 38e11618..62d5e8f9 100644 --- a/Data.List.NonEmpty.Base.html +++ b/Data.List.NonEmpty.Base.html @@ -10,319 +10,318 @@ module Data.List.NonEmpty.Base where open import Level using (Level) -open import Data.Bool.Base using (Bool; false; true; not; T) -open import Data.Bool.Properties using (T?) -open import Data.List.Base as List using (List; []; _∷_) -open import Data.Maybe.Base using (Maybe ; nothing; just) -open import Data.Nat.Base as ℕ -open import Data.Product as Prod using (∃; _×_; proj₁; proj₂; _,_; -,_) -open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂) -open import Data.These.Base as These using (These; this; that; these) -open import Data.Vec.Base as Vec using (Vec; []; _∷_) -open import Function.Base -open import Relation.Binary.PropositionalEquality.Core - using (_≡_; _≢_; refl) -open import Relation.Unary using (Pred; Decidable; U; ∅) -open import Relation.Unary.Properties using (U?; ∅?) -open import Relation.Nullary.Decidable using (does) +open import Data.Bool.Base using (Bool; false; true) +open import Data.List.Base as List using (List; []; _∷_) +open import Data.Maybe.Base using (Maybe ; nothing; just) +open import Data.Nat.Base as ℕ +open import Data.Product.Base as Prod using (∃; _×_; proj₁; proj₂; _,_; -,_) +open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂) +open import Data.These.Base as These using (These; this; that; these) +open import Data.Vec.Base as Vec using (Vec; []; _∷_) +open import Function.Base +open import Relation.Binary.PropositionalEquality.Core + using (_≡_; _≢_; refl) +open import Relation.Unary using (Pred; Decidable; U; ∅) +open import Relation.Unary.Properties using (U?; ∅?) +open import Relation.Nullary.Decidable using (does) -private - variable - a p : Level - A B C : Set a +private + variable + a p : Level + A B C : Set a ------------------------------------------------------------------------- --- Definition +------------------------------------------------------------------------ +-- Definition -infixr 5 _∷_ +infixr 5 _∷_ -record List⁺ (A : Set a) : Set a where - constructor _∷_ - field - head : A - tail : List A +record List⁺ (A : Set a) : Set a where + constructor _∷_ + field + head : A + tail : List A -open List⁺ public +open List⁺ public ------------------------------------------------------------------------- --- Basic combinators +------------------------------------------------------------------------ +-- Basic combinators -uncons : List⁺ A → A × List A -uncons (hd ∷ tl) = hd , tl +uncons : List⁺ A → A × List A +uncons (hd ∷ tl) = hd , tl -[_] : A → List⁺ A -[ x ] = x ∷ [] +[_] : A → List⁺ A +[ x ] = x ∷ [] -infixr 5 _∷⁺_ +infixr 5 _∷⁺_ -_∷⁺_ : A → List⁺ A → List⁺ A -x ∷⁺ y ∷ xs = x ∷ y ∷ xs +_∷⁺_ : A → List⁺ A → List⁺ A +x ∷⁺ y ∷ xs = x ∷ y ∷ xs -length : List⁺ A → ℕ -length (x ∷ xs) = suc (List.length xs) +length : List⁺ A → ℕ +length (x ∷ xs) = suc (List.length xs) ------------------------------------------------------------------------- --- Conversion +------------------------------------------------------------------------ +-- Conversion -toList : List⁺ A → List A -toList (x ∷ xs) = x ∷ xs +toList : List⁺ A → List A +toList (x ∷ xs) = x ∷ xs -fromList : List A → Maybe (List⁺ A) -fromList [] = nothing -fromList (x ∷ xs) = just (x ∷ xs) +fromList : List A → Maybe (List⁺ A) +fromList [] = nothing +fromList (x ∷ xs) = just (x ∷ xs) -fromVec : ∀ {n} → Vec A (suc n) → List⁺ A -fromVec (x ∷ xs) = x ∷ Vec.toList xs +fromVec : ∀ {n} → Vec A (suc n) → List⁺ A +fromVec (x ∷ xs) = x ∷ Vec.toList xs -toVec : (xs : List⁺ A) → Vec A (length xs) -toVec (x ∷ xs) = x ∷ Vec.fromList xs +toVec : (xs : List⁺ A) → Vec A (length xs) +toVec (x ∷ xs) = x ∷ Vec.fromList xs -lift : (∀ {m} → Vec A (suc m) → ∃ λ n → Vec B (suc n)) → - List⁺ A → List⁺ B -lift f xs = fromVec (proj₂ (f (toVec xs))) +lift : (∀ {m} → Vec A (suc m) → ∃ λ n → Vec B (suc n)) → + List⁺ A → List⁺ B +lift f xs = fromVec (proj₂ (f (toVec xs))) ------------------------------------------------------------------------- --- Other operations +------------------------------------------------------------------------ +-- Other operations -map : (A → B) → List⁺ A → List⁺ B -map f (x ∷ xs) = (f x ∷ List.map f xs) +map : (A → B) → List⁺ A → List⁺ B +map f (x ∷ xs) = (f x ∷ List.map f xs) -replicate : ∀ n → n ≢ 0 → A → List⁺ A -replicate n n≢0 a = a ∷ List.replicate (pred n) a +replicate : ∀ n → n ≢ 0 → A → List⁺ A +replicate n n≢0 a = a ∷ List.replicate (pred n) a --- when dropping more than the size of the length of the list, the --- last element remains -drop+ : ℕ → List⁺ A → List⁺ A -drop+ zero xs = xs -drop+ (suc n) (x ∷ []) = x ∷ [] -drop+ (suc n) (x ∷ y ∷ xs) = drop+ n (y ∷ xs) +-- when dropping more than the size of the length of the list, the +-- last element remains +drop+ : ℕ → List⁺ A → List⁺ A +drop+ zero xs = xs +drop+ (suc n) (x ∷ []) = x ∷ [] +drop+ (suc n) (x ∷ y ∷ xs) = drop+ n (y ∷ xs) --- Right fold. Note that s is only applied to the last element (see --- the examples below). +-- Right fold. Note that s is only applied to the last element (see +-- the examples below). -foldr : (A → B → B) → (A → B) → List⁺ A → B -foldr {A = A} {B = B} c s (x ∷ xs) = foldr′ x xs - where - foldr′ : A → List A → B - foldr′ x [] = s x - foldr′ x (y ∷ xs) = c x (foldr′ y xs) +foldr : (A → B → B) → (A → B) → List⁺ A → B +foldr {A = A} {B = B} c s (x ∷ xs) = foldr′ x xs + where + foldr′ : A → List A → B + foldr′ x [] = s x + foldr′ x (y ∷ xs) = c x (foldr′ y xs) --- Right fold. +-- Right fold. -foldr₁ : (A → A → A) → List⁺ A → A -foldr₁ f = foldr f id +foldr₁ : (A → A → A) → List⁺ A → A +foldr₁ f = foldr f id --- Left fold. Note that s is only applied to the first element (see --- the examples below). +-- Left fold. Note that s is only applied to the first element (see +-- the examples below). -foldl : (B → A → B) → (A → B) → List⁺ A → B -foldl c s (x ∷ xs) = List.foldl c (s x) xs +foldl : (B → A → B) → (A → B) → List⁺ A → B +foldl c s (x ∷ xs) = List.foldl c (s x) xs --- Left fold. +-- Left fold. -foldl₁ : (A → A → A) → List⁺ A → A -foldl₁ f = foldl f id +foldl₁ : (A → A → A) → List⁺ A → A +foldl₁ f = foldl f id --- Append (several variants). +-- Append (several variants). -infixr 5 _⁺++⁺_ _++⁺_ _⁺++_ +infixr 5 _⁺++⁺_ _++⁺_ _⁺++_ -_⁺++⁺_ : List⁺ A → List⁺ A → List⁺ A -(x ∷ xs) ⁺++⁺ (y ∷ ys) = x ∷ (xs List.++ y ∷ ys) +_⁺++⁺_ : List⁺ A → List⁺ A → List⁺ A +(x ∷ xs) ⁺++⁺ (y ∷ ys) = x ∷ (xs List.++ y ∷ ys) -_⁺++_ : List⁺ A → List A → List⁺ A -(x ∷ xs) ⁺++ ys = x ∷ (xs List.++ ys) +_⁺++_ : List⁺ A → List A → List⁺ A +(x ∷ xs) ⁺++ ys = x ∷ (xs List.++ ys) -_++⁺_ : List A → List⁺ A → List⁺ A -xs ++⁺ ys = List.foldr _∷⁺_ ys xs +_++⁺_ : List A → List⁺ A → List⁺ A +xs ++⁺ ys = List.foldr _∷⁺_ ys xs -concat : List⁺ (List⁺ A) → List⁺ A -concat (xs ∷ xss) = xs ⁺++ List.concat (List.map toList xss) +concat : List⁺ (List⁺ A) → List⁺ A +concat (xs ∷ xss) = xs ⁺++ List.concat (List.map toList xss) -concatMap : (A → List⁺ B) → List⁺ A → List⁺ B -concatMap f = concat ∘′ map f +concatMap : (A → List⁺ B) → List⁺ A → List⁺ B +concatMap f = concat ∘′ map f -ap : List⁺ (A → B) → List⁺ A → List⁺ B -ap fs as = concatMap (λ f → map f as) fs +ap : List⁺ (A → B) → List⁺ A → List⁺ B +ap fs as = concatMap (λ f → map f as) fs --- Reverse +-- Reverse -reverse : List⁺ A → List⁺ A -reverse = lift (-,_ ∘′ Vec.reverse) +reverse : List⁺ A → List⁺ A +reverse = lift (-,_ ∘′ Vec.reverse) --- Align and Zip +-- Align and Zip -alignWith : (These A B → C) → List⁺ A → List⁺ B → List⁺ C -alignWith f (a ∷ as) (b ∷ bs) = f (these a b) ∷ List.alignWith f as bs +alignWith : (These A B → C) → List⁺ A → List⁺ B → List⁺ C +alignWith f (a ∷ as) (b ∷ bs) = f (these a b) ∷ List.alignWith f as bs -zipWith : (A → B → C) → List⁺ A → List⁺ B → List⁺ C -zipWith f (a ∷ as) (b ∷ bs) = f a b ∷ List.zipWith f as bs +zipWith : (A → B → C) → List⁺ A → List⁺ B → List⁺ C +zipWith f (a ∷ as) (b ∷ bs) = f a b ∷ List.zipWith f as bs -unalignWith : (A → These B C) → List⁺ A → These (List⁺ B) (List⁺ C) -unalignWith f = foldr (These.alignWith mcons mcons ∘′ f) - (These.map [_] [_] ∘′ f) +unalignWith : (A → These B C) → List⁺ A → These (List⁺ B) (List⁺ C) +unalignWith f = foldr (These.alignWith mcons mcons ∘′ f) + (These.map [_] [_] ∘′ f) - where mcons : ∀ {e} {E : Set e} → These E (List⁺ E) → List⁺ E - mcons = These.fold [_] id _∷⁺_ + where mcons : ∀ {e} {E : Set e} → These E (List⁺ E) → List⁺ E + mcons = These.fold [_] id _∷⁺_ -unzipWith : (A → B × C) → List⁺ A → List⁺ B × List⁺ C -unzipWith f (a ∷ as) = Prod.zip _∷_ _∷_ (f a) (List.unzipWith f as) +unzipWith : (A → B × C) → List⁺ A → List⁺ B × List⁺ C +unzipWith f (a ∷ as) = Prod.zip _∷_ _∷_ (f a) (List.unzipWith f as) -align : List⁺ A → List⁺ B → List⁺ (These A B) -align = alignWith id +align : List⁺ A → List⁺ B → List⁺ (These A B) +align = alignWith id -zip : List⁺ A → List⁺ B → List⁺ (A × B) -zip = zipWith _,_ +zip : List⁺ A → List⁺ B → List⁺ (A × B) +zip = zipWith _,_ -unalign : List⁺ (These A B) → These (List⁺ A) (List⁺ B) -unalign = unalignWith id +unalign : List⁺ (These A B) → These (List⁺ A) (List⁺ B) +unalign = unalignWith id -unzip : List⁺ (A × B) → List⁺ A × List⁺ B -unzip = unzipWith id +unzip : List⁺ (A × B) → List⁺ A × List⁺ B +unzip = unzipWith id --- Snoc. +-- Snoc. -infixl 5 _∷ʳ_ _⁺∷ʳ_ +infixl 5 _∷ʳ_ _⁺∷ʳ_ -_∷ʳ_ : List A → A → List⁺ A -[] ∷ʳ y = [ y ] -(x ∷ xs) ∷ʳ y = x ∷ (xs List.∷ʳ y) +_∷ʳ_ : List A → A → List⁺ A +[] ∷ʳ y = [ y ] +(x ∷ xs) ∷ʳ y = x ∷ (xs List.∷ʳ y) -_⁺∷ʳ_ : List⁺ A → A → List⁺ A -xs ⁺∷ʳ x = toList xs ∷ʳ x +_⁺∷ʳ_ : List⁺ A → A → List⁺ A +xs ⁺∷ʳ x = toList xs ∷ʳ x --- A snoc-view of non-empty lists. +-- A snoc-view of non-empty lists. -infixl 5 _∷ʳ′_ +infixl 5 _∷ʳ′_ -data SnocView {A : Set a} : List⁺ A → Set a where - _∷ʳ′_ : (xs : List A) (x : A) → SnocView (xs ∷ʳ x) +data SnocView {A : Set a} : List⁺ A → Set a where + _∷ʳ′_ : (xs : List A) (x : A) → SnocView (xs ∷ʳ x) -snocView : (xs : List⁺ A) → SnocView xs -snocView (x ∷ xs) with List.initLast xs -snocView (x ∷ .[]) | [] = [] ∷ʳ′ x -snocView (x ∷ .(xs List.∷ʳ y)) | xs List.∷ʳ′ y = (x ∷ xs) ∷ʳ′ y +snocView : (xs : List⁺ A) → SnocView xs +snocView (x ∷ xs) with List.initLast xs +snocView (x ∷ .[]) | [] = [] ∷ʳ′ x +snocView (x ∷ .(xs List.∷ʳ y)) | xs List.∷ʳ′ y = (x ∷ xs) ∷ʳ′ y --- The last element in the list. +-- The last element in the list. -last : List⁺ A → A -last xs with snocView xs -last .(ys ∷ʳ y) | ys ∷ʳ′ y = y +last : List⁺ A → A +last xs with snocView xs +last .(ys ∷ʳ y) | ys ∷ʳ′ y = y --- Groups all contiguous elements for which the predicate returns the --- same result into lists. The left sums are the ones for which the --- predicate holds, the right ones are the ones for which it doesn't. -groupSeqsᵇ : (A → Bool) → List A → List (List⁺ A ⊎ List⁺ A) -groupSeqsᵇ p [] = [] -groupSeqsᵇ p (x ∷ xs) with p x | groupSeqsᵇ p xs -... | true | inj₁ xs′ ∷ xss = inj₁ (x ∷⁺ xs′) ∷ xss -... | true | xss = inj₁ [ x ] ∷ xss -... | false | inj₂ xs′ ∷ xss = inj₂ (x ∷⁺ xs′) ∷ xss -... | false | xss = inj₂ [ x ] ∷ xss +-- Groups all contiguous elements for which the predicate returns the +-- same result into lists. The left sums are the ones for which the +-- predicate holds, the right ones are the ones for which it doesn't. +groupSeqsᵇ : (A → Bool) → List A → List (List⁺ A ⊎ List⁺ A) +groupSeqsᵇ p [] = [] +groupSeqsᵇ p (x ∷ xs) with p x | groupSeqsᵇ p xs +... | true | inj₁ xs′ ∷ xss = inj₁ (x ∷⁺ xs′) ∷ xss +... | true | xss = inj₁ [ x ] ∷ xss +... | false | inj₂ xs′ ∷ xss = inj₂ (x ∷⁺ xs′) ∷ xss +... | false | xss = inj₂ [ x ] ∷ xss --- Groups all contiguous elements /not/ satisfying the predicate into --- lists. Elements satisfying the predicate are dropped. -wordsByᵇ : (A → Bool) → List A → List (List⁺ A) -wordsByᵇ p = List.mapMaybe Sum.[ const nothing , just ] ∘ groupSeqsᵇ p +-- Groups all contiguous elements /not/ satisfying the predicate into +-- lists. Elements satisfying the predicate are dropped. +wordsByᵇ : (A → Bool) → List A → List (List⁺ A) +wordsByᵇ p = List.mapMaybe Sum.[ const nothing , just ] ∘ groupSeqsᵇ p -groupSeqs : {P : Pred A p} → Decidable P → List A → List (List⁺ A ⊎ List⁺ A) -groupSeqs P? = groupSeqsᵇ (does ∘ P?) +groupSeqs : {P : Pred A p} → Decidable P → List A → List (List⁺ A ⊎ List⁺ A) +groupSeqs P? = groupSeqsᵇ (does ∘ P?) -wordsBy : {P : Pred A p} → Decidable P → List A → List (List⁺ A) -wordsBy P? = wordsByᵇ (does ∘ P?) +wordsBy : {P : Pred A p} → Decidable P → List A → List (List⁺ A) +wordsBy P? = wordsByᵇ (does ∘ P?) --- Inverse operation for groupSequences. -ungroupSeqs : List (List⁺ A ⊎ List⁺ A) → List A -ungroupSeqs = List.concat ∘ List.map Sum.[ toList , toList ] +-- Inverse operation for groupSequences. +ungroupSeqs : List (List⁺ A ⊎ List⁺ A) → List A +ungroupSeqs = List.concat ∘ List.map Sum.[ toList , toList ] ------------------------------------------------------------------------- --- Examples +------------------------------------------------------------------------ +-- Examples --- Note that these examples are simple unit tests, because the type --- checker verifies them. +-- Note that these examples are simple unit tests, because the type +-- checker verifies them. -private - module Examples {A B : Set} - (_⊕_ : A → B → B) - (_⊗_ : B → A → B) - (_⊙_ : A → A → A) - (f : A → B) - (a b c : A) - where +private + module Examples {A B : Set} + (_⊕_ : A → B → B) + (_⊗_ : B → A → B) + (_⊙_ : A → A → A) + (f : A → B) + (a b c : A) + where - hd : head (a ∷⁺ b ∷⁺ [ c ]) ≡ a - hd = refl + hd : head (a ∷⁺ b ∷⁺ [ c ]) ≡ a + hd = refl - tl : tail (a ∷⁺ b ∷⁺ [ c ]) ≡ b ∷ c ∷ [] - tl = refl + tl : tail (a ∷⁺ b ∷⁺ [ c ]) ≡ b ∷ c ∷ [] + tl = refl - mp : map f (a ∷⁺ b ∷⁺ [ c ]) ≡ f a ∷⁺ f b ∷⁺ [ f c ] - mp = refl + mp : map f (a ∷⁺ b ∷⁺ [ c ]) ≡ f a ∷⁺ f b ∷⁺ [ f c ] + mp = refl - right : foldr _⊕_ f (a ∷⁺ b ∷⁺ [ c ]) ≡ (a ⊕ (b ⊕ f c)) - right = refl + right : foldr _⊕_ f (a ∷⁺ b ∷⁺ [ c ]) ≡ (a ⊕ (b ⊕ f c)) + right = refl - right₁ : foldr₁ _⊙_ (a ∷⁺ b ∷⁺ [ c ]) ≡ (a ⊙ (b ⊙ c)) - right₁ = refl + right₁ : foldr₁ _⊙_ (a ∷⁺ b ∷⁺ [ c ]) ≡ (a ⊙ (b ⊙ c)) + right₁ = refl - left : foldl _⊗_ f (a ∷⁺ b ∷⁺ [ c ]) ≡ ((f a ⊗ b) ⊗ c) - left = refl + left : foldl _⊗_ f (a ∷⁺ b ∷⁺ [ c ]) ≡ ((f a ⊗ b) ⊗ c) + left = refl - left₁ : foldl₁ _⊙_ (a ∷⁺ b ∷⁺ [ c ]) ≡ ((a ⊙ b) ⊙ c) - left₁ = refl + left₁ : foldl₁ _⊙_ (a ∷⁺ b ∷⁺ [ c ]) ≡ ((a ⊙ b) ⊙ c) + left₁ = refl - ⁺app⁺ : (a ∷⁺ b ∷⁺ [ c ]) ⁺++⁺ (b ∷⁺ [ c ]) ≡ - a ∷⁺ b ∷⁺ c ∷⁺ b ∷⁺ [ c ] - ⁺app⁺ = refl + ⁺app⁺ : (a ∷⁺ b ∷⁺ [ c ]) ⁺++⁺ (b ∷⁺ [ c ]) ≡ + a ∷⁺ b ∷⁺ c ∷⁺ b ∷⁺ [ c ] + ⁺app⁺ = refl - ⁺app : (a ∷⁺ b ∷⁺ [ c ]) ⁺++ (b ∷ c ∷ []) ≡ - a ∷⁺ b ∷⁺ c ∷⁺ b ∷⁺ [ c ] - ⁺app = refl + ⁺app : (a ∷⁺ b ∷⁺ [ c ]) ⁺++ (b ∷ c ∷ []) ≡ + a ∷⁺ b ∷⁺ c ∷⁺ b ∷⁺ [ c ] + ⁺app = refl - app⁺ : (a ∷ b ∷ c ∷ []) ++⁺ (b ∷⁺ [ c ]) ≡ - a ∷⁺ b ∷⁺ c ∷⁺ b ∷⁺ [ c ] - app⁺ = refl + app⁺ : (a ∷ b ∷ c ∷ []) ++⁺ (b ∷⁺ [ c ]) ≡ + a ∷⁺ b ∷⁺ c ∷⁺ b ∷⁺ [ c ] + app⁺ = refl - conc : concat ((a ∷⁺ b ∷⁺ [ c ]) ∷⁺ [ b ∷⁺ [ c ] ]) ≡ - a ∷⁺ b ∷⁺ c ∷⁺ b ∷⁺ [ c ] - conc = refl + conc : concat ((a ∷⁺ b ∷⁺ [ c ]) ∷⁺ [ b ∷⁺ [ c ] ]) ≡ + a ∷⁺ b ∷⁺ c ∷⁺ b ∷⁺ [ c ] + conc = refl - rev : reverse (a ∷⁺ b ∷⁺ [ c ]) ≡ c ∷⁺ b ∷⁺ [ a ] - rev = refl + rev : reverse (a ∷⁺ b ∷⁺ [ c ]) ≡ c ∷⁺ b ∷⁺ [ a ] + rev = refl - snoc : (a ∷ b ∷ c ∷ []) ∷ʳ a ≡ a ∷⁺ b ∷⁺ c ∷⁺ [ a ] - snoc = refl + snoc : (a ∷ b ∷ c ∷ []) ∷ʳ a ≡ a ∷⁺ b ∷⁺ c ∷⁺ [ a ] + snoc = refl - snoc⁺ : (a ∷⁺ b ∷⁺ [ c ]) ⁺∷ʳ a ≡ a ∷⁺ b ∷⁺ c ∷⁺ [ a ] - snoc⁺ = refl - - groupSeqs-true : groupSeqs U? (a ∷ b ∷ c ∷ []) ≡ - inj₁ (a ∷⁺ b ∷⁺ [ c ]) ∷ [] - groupSeqs-true = refl - - groupSeqs-false : groupSeqs ∅? (a ∷ b ∷ c ∷ []) ≡ - inj₂ (a ∷⁺ b ∷⁺ [ c ]) ∷ [] - groupSeqs-false = refl - - groupSeqs-≡1 : groupSeqsᵇ (ℕ._≡ᵇ 1) (1 ∷ 2 ∷ 3 ∷ 1 ∷ 1 ∷ 2 ∷ 1 ∷ []) ≡ - inj₁ [ 1 ] ∷ - inj₂ (2 ∷⁺ [ 3 ]) ∷ - inj₁ (1 ∷⁺ [ 1 ]) ∷ - inj₂ [ 2 ] ∷ - inj₁ [ 1 ] ∷ - [] - groupSeqs-≡1 = refl - - wordsBy-true : wordsByᵇ (const true) (a ∷ b ∷ c ∷ []) ≡ [] - wordsBy-true = refl + snoc⁺ : (a ∷⁺ b ∷⁺ [ c ]) ⁺∷ʳ a ≡ a ∷⁺ b ∷⁺ c ∷⁺ [ a ] + snoc⁺ = refl + + groupSeqs-true : groupSeqs U? (a ∷ b ∷ c ∷ []) ≡ + inj₁ (a ∷⁺ b ∷⁺ [ c ]) ∷ [] + groupSeqs-true = refl + + groupSeqs-false : groupSeqs ∅? (a ∷ b ∷ c ∷ []) ≡ + inj₂ (a ∷⁺ b ∷⁺ [ c ]) ∷ [] + groupSeqs-false = refl + + groupSeqs-≡1 : groupSeqsᵇ (ℕ._≡ᵇ 1) (1 ∷ 2 ∷ 3 ∷ 1 ∷ 1 ∷ 2 ∷ 1 ∷ []) ≡ + inj₁ [ 1 ] ∷ + inj₂ (2 ∷⁺ [ 3 ]) ∷ + inj₁ (1 ∷⁺ [ 1 ]) ∷ + inj₂ [ 2 ] ∷ + inj₁ [ 1 ] ∷ + [] + groupSeqs-≡1 = refl + + wordsBy-true : wordsByᵇ (const true) (a ∷ b ∷ c ∷ []) ≡ [] + wordsBy-true = refl - wordsBy-false : wordsByᵇ (const false) (a ∷ b ∷ c ∷ []) ≡ - (a ∷⁺ b ∷⁺ [ c ]) ∷ [] - wordsBy-false = refl + wordsBy-false : wordsByᵇ (const false) (a ∷ b ∷ c ∷ []) ≡ + (a ∷⁺ b ∷⁺ [ c ]) ∷ [] + wordsBy-false = refl - wordsBy-≡1 : wordsByᵇ (ℕ._≡ᵇ 1) (1 ∷ 2 ∷ 3 ∷ 1 ∷ 1 ∷ 2 ∷ 1 ∷ []) ≡ - (2 ∷⁺ [ 3 ]) ∷ - [ 2 ] ∷ - [] - wordsBy-≡1 = refl + wordsBy-≡1 : wordsByᵇ (ℕ._≡ᵇ 1) (1 ∷ 2 ∷ 3 ∷ 1 ∷ 1 ∷ 2 ∷ 1 ∷ []) ≡ + (2 ∷⁺ [ 3 ]) ∷ + [ 2 ] ∷ + [] + wordsBy-≡1 = refl \ No newline at end of file diff --git a/Data.List.NonEmpty.html b/Data.List.NonEmpty.html deleted file mode 100644 index 78f574ed..00000000 --- a/Data.List.NonEmpty.html +++ /dev/null @@ -1,56 +0,0 @@ - -Data.List.NonEmpty
------------------------------------------------------------------------
--- The Agda standard library
---
--- Non-empty lists
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-module Data.List.NonEmpty where
-
-open import Level using (Level)
-open import Effect.Monad
-open import Data.Bool.Base using (Bool; false; true; not; T)
-open import Data.Bool.Properties
-open import Data.List.Base as List using (List; []; _∷_)
-open import Data.Maybe.Base using (Maybe ; nothing; just)
-open import Data.Nat.Base as ℕ
-open import Data.Product as Prod using (∃; _×_; proj₁; proj₂; _,_; -,_)
-open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂)
-open import Data.These.Base as These using (These; this; that; these)
-open import Data.Unit.Base using (tt)
-open import Data.Vec.Base as Vec using (Vec; []; _∷_)
-open import Function.Base
-open import Function.Bundles using () renaming (module Equivalence to Eq)
-open import Relation.Binary.PropositionalEquality as P using (_≡_; _≢_; refl)
-open import Relation.Nullary.Decidable using (isYes)
-
-------------------------------------------------------------------------
--- Re-export basic type and operations
-
-open import Data.List.NonEmpty.Base public
-
-
-------------------------------------------------------------------------
--- DEPRECATED
-------------------------------------------------------------------------
--- Please use the new names as continuing support for the old names is
--- not guaranteed.
-
-private
-  variable
-    a : Level
-    A : Set a
-
--- Version 1.4
-
-infixl 5 _∷ʳ'_
-
-_∷ʳ'_ : (xs : List A) (x : A) → SnocView (xs ∷ʳ x)
-_∷ʳ'_ = SnocView._∷ʳ′_
-{-# WARNING_ON_USAGE _∷ʳ'_
-"Warning: _∷ʳ'_ (ending in an apostrophe) was deprecated in v1.4.
-Please use _∷ʳ′_ (ending in a prime) instead."
-#-}
-
\ No newline at end of file diff --git a/Data.List.Properties.html b/Data.List.Properties.html index 0181f31a..fdc2e5e7 100644 --- a/Data.List.Properties.html +++ b/Data.List.Properties.html @@ -13,1128 +13,1284 @@ module Data.List.Properties where open import Algebra.Bundles -open import Algebra.Definitions as AlgebraicDefinitions using (Involutive) -open import Algebra.Morphism.Structures using (IsMagmaHomomorphism; IsMonoidHomomorphism) +open import Algebra.Definitions as AlgebraicDefinitions using (Involutive) +open import Algebra.Morphism.Structures using (IsMagmaHomomorphism; IsMonoidHomomorphism) import Algebra.Structures as AlgebraicStructures -open import Data.Bool.Base using (Bool; false; true; not; if_then_else_) -open import Data.Fin.Base using (Fin; zero; suc; cast; toℕ) +open import Data.Bool.Base using (Bool; false; true; not; if_then_else_) +open import Data.Fin.Base using (Fin; zero; suc; cast; toℕ) open import Data.List.Base as List -open import Data.List.Membership.Propositional using (_∈_) -open import Data.List.Relation.Unary.All using (All; []; _∷_) -open import Data.List.Relation.Unary.Any using (Any; here; there) -open import Data.Maybe.Base using (Maybe; just; nothing) -open import Data.Nat.Base -open import Data.Nat.Divisibility -open import Data.Nat.Properties -open import Data.Product as Prod hiding (map; zip) -import Data.Product.Relation.Unary.All as Prod using (All) -open import Data.Sum.Base using (_⊎_; inj₁; inj₂) -open import Data.These.Base as These using (These; this; that; these) -open import Function -open import Level using (Level) -open import Relation.Binary as B using (DecidableEquality) -import Relation.Binary.Reasoning.Setoid as EqR -open import Relation.Binary.PropositionalEquality as P hiding ([_]) -open import Relation.Binary as B using (Rel) -open import Relation.Nullary.Reflects using (invert) -open import Relation.Nullary using (¬_; Dec; does; _because_; yes; no; contradiction) -open import Relation.Nullary.Decidable as Decidable using (isYes; map′; ⌊_⌋; ¬?; _×-dec_) -open import Relation.Unary using (Pred; Decidable; ∁) -open import Relation.Unary.Properties using (∁?) - -open ≡-Reasoning - -private - variable - a b c d e p : Level - A : Set a - B : Set b - C : Set c - D : Set d - E : Set e - ------------------------------------------------------------------------ --- _∷_ - -module _ {x y : A} {xs ys : List A} where - - ∷-injective : x ∷ xs ≡ y List.∷ ys → x ≡ y × xs ≡ ys - ∷-injective refl = (refl , refl) - - ∷-injectiveˡ : x ∷ xs ≡ y List.∷ ys → x ≡ y - ∷-injectiveˡ refl = refl - - ∷-injectiveʳ : x ∷ xs ≡ y List.∷ ys → xs ≡ ys - ∷-injectiveʳ refl = refl - - ∷-dec : Dec (x ≡ y) → Dec (xs ≡ ys) → Dec (x List.∷ xs ≡ y ∷ ys) - ∷-dec x≟y xs≟ys = Decidable.map′ (uncurry (cong₂ _∷_)) ∷-injective (x≟y ×-dec xs≟ys) - -≡-dec : DecidableEquality A → DecidableEquality (List A) -≡-dec _≟_ [] [] = yes refl -≡-dec _≟_ (x ∷ xs) [] = no λ() -≡-dec _≟_ [] (y ∷ ys) = no λ() -≡-dec _≟_ (x ∷ xs) (y ∷ ys) = ∷-dec (x ≟ y) (≡-dec _≟_ xs ys) - ------------------------------------------------------------------------- --- map - -map-id : map id ≗ id {A = List A} -map-id [] = refl -map-id (x ∷ xs) = cong (x ∷_) (map-id xs) - -map-id-local : ∀ {f : A → A} {xs} → All (λ x → f x ≡ x) xs → map f xs ≡ xs -map-id-local [] = refl -map-id-local (fx≡x ∷ pxs) = cong₂ _∷_ fx≡x (map-id-local pxs) - -map-++ : ∀ (f : A → B) xs ys → - map f (xs ++ ys) ≡ map f xs ++ map f ys -map-++ f [] ys = refl -map-++ f (x ∷ xs) ys = cong (f x ∷_) (map-++ f xs ys) - -map-cong : ∀ {f g : A → B} → f ≗ g → map f ≗ map g -map-cong f≗g [] = refl -map-cong f≗g (x ∷ xs) = cong₂ _∷_ (f≗g x) (map-cong f≗g xs) - -map-cong-local : ∀ {f g : A → B} {xs} → - All (λ x → f x ≡ g x) xs → map f xs ≡ map g xs -map-cong-local [] = refl -map-cong-local (fx≡gx ∷ fxs≡gxs) = cong₂ _∷_ fx≡gx (map-cong-local fxs≡gxs) - -length-map : ∀ (f : A → B) xs → length (map f xs) ≡ length xs -length-map f [] = refl -length-map f (x ∷ xs) = cong suc (length-map f xs) - -map-∘ : {g : B → C} {f : A → B} → map (g ∘ f) ≗ map g ∘ map f -map-∘ [] = refl -map-∘ (x ∷ xs) = cong (_ ∷_) (map-∘ xs) - -map-injective : ∀ {f : A → B} → Injective _≡_ _≡_ f → Injective _≡_ _≡_ (map f) -map-injective finj {[]} {[]} eq = refl -map-injective finj {x ∷ xs} {y ∷ ys} eq = - let fx≡fy , fxs≡fys = ∷-injective eq in - cong₂ _∷_ (finj fx≡fy) (map-injective finj fxs≡fys) - ------------------------------------------------------------------------- --- mapMaybe - -mapMaybe-just : (xs : List A) → mapMaybe just xs ≡ xs -mapMaybe-just [] = refl -mapMaybe-just (x ∷ xs) = cong (x ∷_) (mapMaybe-just xs) - -mapMaybe-nothing : (xs : List A) → - mapMaybe {B = A} (λ _ → nothing) xs ≡ [] -mapMaybe-nothing [] = refl -mapMaybe-nothing (x ∷ xs) = mapMaybe-nothing xs - -module _ (f : A → Maybe B) where - - mapMaybe-concatMap : mapMaybe f ≗ concatMap (fromMaybe ∘ f) - mapMaybe-concatMap [] = refl - mapMaybe-concatMap (x ∷ xs) with ih ← mapMaybe-concatMap xs | f x - ... | just y = cong (y ∷_) ih - ... | nothing = ih - - length-mapMaybe : ∀ xs → length (mapMaybe f xs) ≤ length xs - length-mapMaybe [] = z≤n - length-mapMaybe (x ∷ xs) with ih ← length-mapMaybe xs | f x - ... | just y = s≤s ih - ... | nothing = m≤n⇒m≤1+n ih - ------------------------------------------------------------------------- --- _++_ - -length-++ : ∀ (xs : List A) {ys} → - length (xs ++ ys) ≡ length xs + length ys -length-++ [] = refl -length-++ (x ∷ xs) = cong suc (length-++ xs) - -module _ {A : Set a} where - - open AlgebraicDefinitions {A = List A} _≡_ - open AlgebraicStructures {A = List A} _≡_ - - ++-assoc : Associative _++_ - ++-assoc [] ys zs = refl - ++-assoc (x ∷ xs) ys zs = cong (x ∷_) (++-assoc xs ys zs) - - ++-identityˡ : LeftIdentity [] _++_ - ++-identityˡ xs = refl - - ++-identityʳ : RightIdentity [] _++_ - ++-identityʳ [] = refl - ++-identityʳ (x ∷ xs) = cong (x ∷_) (++-identityʳ xs) - - ++-identity : Identity [] _++_ - ++-identity = ++-identityˡ , ++-identityʳ - - ++-identityʳ-unique : ∀ (xs : List A) {ys} → xs ≡ xs ++ ys → ys ≡ [] - ++-identityʳ-unique [] refl = refl - ++-identityʳ-unique (x ∷ xs) eq = - ++-identityʳ-unique xs (proj₂ (∷-injective eq)) - - ++-identityˡ-unique : ∀ {xs} (ys : List A) → xs ≡ ys ++ xs → ys ≡ [] - ++-identityˡ-unique [] _ = refl - ++-identityˡ-unique {xs = x ∷ xs} (y ∷ ys) eq - with ++-identityˡ-unique (ys ++ [ x ]) (begin - xs ≡⟨ proj₂ (∷-injective eq) ⟩ - ys ++ x ∷ xs ≡⟨ sym (++-assoc ys [ x ] xs) ⟩ - (ys ++ [ x ]) ++ xs ∎) - ++-identityˡ-unique {xs = x ∷ xs} (y ∷ [] ) eq | () - ++-identityˡ-unique {xs = x ∷ xs} (y ∷ _ ∷ _) eq | () - - ++-cancelˡ : LeftCancellative _++_ - ++-cancelˡ [] _ _ ys≡zs = ys≡zs - ++-cancelˡ (x ∷ xs) _ _ x∷xs++ys≡x∷xs++zs = ++-cancelˡ xs _ _ (∷-injectiveʳ x∷xs++ys≡x∷xs++zs) - - ++-cancelʳ : RightCancellative _++_ - ++-cancelʳ _ [] [] _ = refl - ++-cancelʳ xs [] (z ∷ zs) eq = - contradiction (trans (cong length eq) (length-++ (z ∷ zs))) (m≢1+n+m (length xs)) - ++-cancelʳ xs (y ∷ ys) [] eq = - contradiction (trans (sym (length-++ (y ∷ ys))) (cong length eq)) (m≢1+n+m (length xs) ∘ sym) - ++-cancelʳ _ (y ∷ ys) (z ∷ zs) eq = - cong₂ _∷_ (∷-injectiveˡ eq) (++-cancelʳ _ ys zs (∷-injectiveʳ eq)) - - ++-cancel : Cancellative _++_ - ++-cancel = ++-cancelˡ , ++-cancelʳ - - ++-conicalˡ : ∀ (xs ys : List A) → xs ++ ys ≡ [] → xs ≡ [] - ++-conicalˡ [] _ refl = refl - - ++-conicalʳ : ∀ (xs ys : List A) → xs ++ ys ≡ [] → ys ≡ [] - ++-conicalʳ [] _ refl = refl - - ++-conical : Conical [] _++_ - ++-conical = ++-conicalˡ , ++-conicalʳ - - ++-isMagma : IsMagma _++_ - ++-isMagma = record - { isEquivalence = isEquivalence - ; ∙-cong = cong₂ _++_ - } - - ++-isSemigroup : IsSemigroup _++_ - ++-isSemigroup = record - { isMagma = ++-isMagma - ; assoc = ++-assoc - } - - ++-isMonoid : IsMonoid _++_ [] - ++-isMonoid = record - { isSemigroup = ++-isSemigroup - ; identity = ++-identity - } - -module _ (A : Set a) where - - ++-semigroup : Semigroup a a - ++-semigroup = record - { Carrier = List A - ; isSemigroup = ++-isSemigroup - } - - ++-monoid : Monoid a a - ++-monoid = record - { Carrier = List A - ; isMonoid = ++-isMonoid - } - -module _ (A : Set a) where - - length-isMagmaHomomorphism : IsMagmaHomomorphism (++-rawMagma A) +-rawMagma length - length-isMagmaHomomorphism = record - { isRelHomomorphism = record - { cong = cong length - } - ; homo = λ xs ys → length-++ xs {ys} - } - - length-isMonoidHomomorphism : IsMonoidHomomorphism (++-[]-rawMonoid A) +-0-rawMonoid length - length-isMonoidHomomorphism = record - { isMagmaHomomorphism = length-isMagmaHomomorphism - ; ε-homo = refl - } - ------------------------------------------------------------------------- --- cartesianProductWith - -module _ (f : A → B → C) where - - private - prod = cartesianProductWith f - - cartesianProductWith-zeroˡ : ∀ ys → prod [] ys ≡ [] - cartesianProductWith-zeroˡ _ = refl - - cartesianProductWith-zeroʳ : ∀ xs → prod xs [] ≡ [] - cartesianProductWith-zeroʳ [] = refl - cartesianProductWith-zeroʳ (x ∷ xs) = cartesianProductWith-zeroʳ xs - - cartesianProductWith-distribʳ-++ : ∀ xs ys zs → prod (xs ++ ys) zs ≡ prod xs zs ++ prod ys zs - cartesianProductWith-distribʳ-++ [] ys zs = refl - cartesianProductWith-distribʳ-++ (x ∷ xs) ys zs = begin - prod (x ∷ xs ++ ys) zs ≡⟨⟩ - map (f x) zs ++ prod (xs ++ ys) zs ≡⟨ cong (map (f x) zs ++_) (cartesianProductWith-distribʳ-++ xs ys zs) ⟩ - map (f x) zs ++ prod xs zs ++ prod ys zs ≡˘⟨ ++-assoc (map (f x) zs) (prod xs zs) (prod ys zs) ⟩ - (map (f x) zs ++ prod xs zs) ++ prod ys zs ≡⟨⟩ - prod (x ∷ xs) zs ++ prod ys zs ∎ - ------------------------------------------------------------------------- --- alignWith - -module _ {f g : These A B → C} where - - alignWith-cong : f ≗ g → ∀ as → alignWith f as ≗ alignWith g as - alignWith-cong f≗g [] bs = map-cong (f≗g ∘ that) bs - alignWith-cong f≗g as@(_ ∷ _) [] = map-cong (f≗g ∘ this) as - alignWith-cong f≗g (a ∷ as) (b ∷ bs) = - cong₂ _∷_ (f≗g (these a b)) (alignWith-cong f≗g as bs) - - length-alignWith : ∀ xs ys → - length (alignWith f xs ys) ≡ length xs ⊔ length ys - length-alignWith [] ys = length-map (f ∘′ that) ys - length-alignWith xs@(_ ∷ _) [] = length-map (f ∘′ this) xs - length-alignWith (x ∷ xs) (y ∷ ys) = cong suc (length-alignWith xs ys) - - alignWith-map : (g : D → A) (h : E → B) → - ∀ xs ys → alignWith f (map g xs) (map h ys) ≡ - alignWith (f ∘′ These.map g h) xs ys - alignWith-map g h [] ys = sym (map-∘ ys) - alignWith-map g h xs@(_ ∷ _) [] = sym (map-∘ xs) - alignWith-map g h (x ∷ xs) (y ∷ ys) = - cong₂ _∷_ refl (alignWith-map g h xs ys) - - map-alignWith : ∀ (g : C → D) → ∀ xs ys → - map g (alignWith f xs ys) ≡ - alignWith (g ∘′ f) xs ys - map-alignWith g [] ys = sym (map-∘ ys) - map-alignWith g xs@(_ ∷ _) [] = sym (map-∘ xs) - map-alignWith g (x ∷ xs) (y ∷ ys) = - cong₂ _∷_ refl (map-alignWith g xs ys) - ------------------------------------------------------------------------- --- zipWith - -module _ (f : A → A → B) where - - zipWith-comm : (∀ x y → f x y ≡ f y x) → - ∀ xs ys → zipWith f xs ys ≡ zipWith f ys xs - zipWith-comm f-comm [] [] = refl - zipWith-comm f-comm [] (x ∷ ys) = refl - zipWith-comm f-comm (x ∷ xs) [] = refl - zipWith-comm f-comm (x ∷ xs) (y ∷ ys) = - cong₂ _∷_ (f-comm x y) (zipWith-comm f-comm xs ys) - -module _ (f : A → B → C) where - - zipWith-zeroˡ : ∀ xs → zipWith f [] xs ≡ [] - zipWith-zeroˡ [] = refl - zipWith-zeroˡ (x ∷ xs) = refl - - zipWith-zeroʳ : ∀ xs → zipWith f xs [] ≡ [] - zipWith-zeroʳ [] = refl - zipWith-zeroʳ (x ∷ xs) = refl - - length-zipWith : ∀ xs ys → - length (zipWith f xs ys) ≡ length xs ⊓ length ys - length-zipWith [] [] = refl - length-zipWith [] (y ∷ ys) = refl - length-zipWith (x ∷ xs) [] = refl - length-zipWith (x ∷ xs) (y ∷ ys) = cong suc (length-zipWith xs ys) - - zipWith-map : ∀ {d e} {D : Set d} {E : Set e} (g : D → A) (h : E → B) → - ∀ xs ys → zipWith f (map g xs) (map h ys) ≡ - zipWith (λ x y → f (g x) (h y)) xs ys - zipWith-map g h [] [] = refl - zipWith-map g h [] (y ∷ ys) = refl - zipWith-map g h (x ∷ xs) [] = refl - zipWith-map g h (x ∷ xs) (y ∷ ys) = - cong₂ _∷_ refl (zipWith-map g h xs ys) - - map-zipWith : ∀ {d} {D : Set d} (g : C → D) → ∀ xs ys → - map g (zipWith f xs ys) ≡ - zipWith (λ x y → g (f x y)) xs ys - map-zipWith g [] [] = refl - map-zipWith g [] (y ∷ ys) = refl - map-zipWith g (x ∷ xs) [] = refl - map-zipWith g (x ∷ xs) (y ∷ ys) = - cong₂ _∷_ refl (map-zipWith g xs ys) - ------------------------------------------------------------------------- --- unalignWith - -unalignWith-this : unalignWith ((A → These A B) ∋ this) ≗ (_, []) -unalignWith-this [] = refl -unalignWith-this (a ∷ as) = cong (Prod.map₁ (a ∷_)) (unalignWith-this as) - -unalignWith-that : unalignWith ((B → These A B) ∋ that) ≗ ([] ,_) -unalignWith-that [] = refl -unalignWith-that (b ∷ bs) = cong (Prod.map₂ (b ∷_)) (unalignWith-that bs) - -module _ {f g : C → These A B} where - - unalignWith-cong : f ≗ g → unalignWith f ≗ unalignWith g - unalignWith-cong f≗g [] = refl - unalignWith-cong f≗g (c ∷ cs) with f c | g c | f≗g c - ... | this a | ._ | refl = cong (Prod.map₁ (a ∷_)) (unalignWith-cong f≗g cs) - ... | that b | ._ | refl = cong (Prod.map₂ (b ∷_)) (unalignWith-cong f≗g cs) - ... | these a b | ._ | refl = cong (Prod.map (a ∷_) (b ∷_)) (unalignWith-cong f≗g cs) - -module _ (f : C → These A B) where - - unalignWith-map : (g : D → C) → ∀ ds → - unalignWith f (map g ds) ≡ unalignWith (f ∘′ g) ds - unalignWith-map g [] = refl - unalignWith-map g (d ∷ ds) with f (g d) - ... | this a = cong (Prod.map₁ (a ∷_)) (unalignWith-map g ds) - ... | that b = cong (Prod.map₂ (b ∷_)) (unalignWith-map g ds) - ... | these a b = cong (Prod.map (a ∷_) (b ∷_)) (unalignWith-map g ds) - - map-unalignWith : (g : A → D) (h : B → E) → - Prod.map (map g) (map h) ∘′ unalignWith f ≗ unalignWith (These.map g h ∘′ f) - map-unalignWith g h [] = refl - map-unalignWith g h (c ∷ cs) with f c - ... | this a = cong (Prod.map₁ (g a ∷_)) (map-unalignWith g h cs) - ... | that b = cong (Prod.map₂ (h b ∷_)) (map-unalignWith g h cs) - ... | these a b = cong (Prod.map (g a ∷_) (h b ∷_)) (map-unalignWith g h cs) - - unalignWith-alignWith : (g : These A B → C) → f ∘′ g ≗ id → ∀ as bs → - unalignWith f (alignWith g as bs) ≡ (as , bs) - unalignWith-alignWith g g∘f≗id [] bs = begin - unalignWith f (map (g ∘′ that) bs) ≡⟨ unalignWith-map (g ∘′ that) bs ⟩ - unalignWith (f ∘′ g ∘′ that) bs ≡⟨ unalignWith-cong (g∘f≗id ∘ that) bs ⟩ - unalignWith that bs ≡⟨ unalignWith-that bs ⟩ - [] , bs ∎ - unalignWith-alignWith g g∘f≗id as@(_ ∷ _) [] = begin - unalignWith f (map (g ∘′ this) as) ≡⟨ unalignWith-map (g ∘′ this) as ⟩ - unalignWith (f ∘′ g ∘′ this) as ≡⟨ unalignWith-cong (g∘f≗id ∘ this) as ⟩ - unalignWith this as ≡⟨ unalignWith-this as ⟩ - as , [] ∎ - unalignWith-alignWith g g∘f≗id (a ∷ as) (b ∷ bs) - rewrite g∘f≗id (these a b) = - cong (Prod.map (a ∷_) (b ∷_)) (unalignWith-alignWith g g∘f≗id as bs) - ------------------------------------------------------------------------- --- unzipWith - -module _ (f : A → B × C) where - - length-unzipWith₁ : ∀ xys → - length (proj₁ (unzipWith f xys)) ≡ length xys - length-unzipWith₁ [] = refl - length-unzipWith₁ (x ∷ xys) = cong suc (length-unzipWith₁ xys) - - length-unzipWith₂ : ∀ xys → - length (proj₂ (unzipWith f xys)) ≡ length xys - length-unzipWith₂ [] = refl - length-unzipWith₂ (x ∷ xys) = cong suc (length-unzipWith₂ xys) - - zipWith-unzipWith : (g : B → C → A) → uncurry′ g ∘ f ≗ id → - uncurry′ (zipWith g) ∘ (unzipWith f) ≗ id - zipWith-unzipWith g f∘g≗id [] = refl - zipWith-unzipWith g f∘g≗id (x ∷ xs) = - cong₂ _∷_ (f∘g≗id x) (zipWith-unzipWith g f∘g≗id xs) - ------------------------------------------------------------------------- --- foldr - -foldr-universal : ∀ (h : List A → B) f e → (h [] ≡ e) → - (∀ x xs → h (x ∷ xs) ≡ f x (h xs)) → - h ≗ foldr f e -foldr-universal h f e base step [] = base -foldr-universal h f e base step (x ∷ xs) = begin - h (x ∷ xs) ≡⟨ step x xs ⟩ - f x (h xs) ≡⟨ cong (f x) (foldr-universal h f e base step xs) ⟩ - f x (foldr f e xs) ∎ - -foldr-cong : ∀ {f g : A → B → B} {d e : B} → - (∀ x y → f x y ≡ g x y) → d ≡ e → - foldr f d ≗ foldr g e -foldr-cong f≗g refl [] = refl -foldr-cong f≗g d≡e (x ∷ xs) rewrite foldr-cong f≗g d≡e xs = f≗g x _ - -foldr-fusion : ∀ (h : B → C) {f : A → B → B} {g : A → C → C} (e : B) → - (∀ x y → h (f x y) ≡ g x (h y)) → - h ∘ foldr f e ≗ foldr g (h e) -foldr-fusion h {f} {g} e fuse = - foldr-universal (h ∘ foldr f e) g (h e) refl - (λ x xs → fuse x (foldr f e xs)) - -id-is-foldr : id {A = List A} ≗ foldr _∷_ [] -id-is-foldr = foldr-universal id _∷_ [] refl (λ _ _ → refl) - -++-is-foldr : (xs ys : List A) → xs ++ ys ≡ foldr _∷_ ys xs -++-is-foldr xs ys = begin - xs ++ ys ≡⟨ cong (_++ ys) (id-is-foldr xs) ⟩ - foldr _∷_ [] xs ++ ys ≡⟨ foldr-fusion (_++ ys) [] (λ _ _ → refl) xs ⟩ - foldr _∷_ ([] ++ ys) xs ≡⟨⟩ - foldr _∷_ ys xs ∎ - -foldr-++ : ∀ (f : A → B → B) x ys zs → - foldr f x (ys ++ zs) ≡ foldr f (foldr f x zs) ys -foldr-++ f x [] zs = refl -foldr-++ f x (y ∷ ys) zs = cong (f y) (foldr-++ f x ys zs) - -map-is-foldr : {f : A → B} → map f ≗ foldr (λ x ys → f x ∷ ys) [] -map-is-foldr {f = f} xs = begin - map f xs ≡⟨ cong (map f) (id-is-foldr xs) ⟩ - map f (foldr _∷_ [] xs) ≡⟨ foldr-fusion (map f) [] (λ _ _ → refl) xs ⟩ - foldr (λ x ys → f x ∷ ys) [] xs ∎ - -foldr-∷ʳ : ∀ (f : A → B → B) x y ys → - foldr f x (ys ∷ʳ y) ≡ foldr f (f y x) ys -foldr-∷ʳ f x y [] = refl -foldr-∷ʳ f x y (z ∷ ys) = cong (f z) (foldr-∷ʳ f x y ys) - -foldr-map : ∀ (f : A → B → B) (g : C → A) x xs → foldr f x (map g xs) ≡ foldr (g -⟨ f ∣) x xs -foldr-map f g x [] = refl -foldr-map f g x (y ∷ xs) = cong (f (g y)) (foldr-map f g x xs) - --- Interaction with predicates - -module _ {P : Pred A p} {f : A → A → A} where - - foldr-forcesᵇ : (∀ x y → P (f x y) → P x × P y) → - ∀ e xs → P (foldr f e xs) → All P xs - foldr-forcesᵇ _ _ [] _ = [] - foldr-forcesᵇ forces _ (x ∷ xs) Pfold = - let px , pfxs = forces _ _ Pfold in px ∷ foldr-forcesᵇ forces _ xs pfxs - - foldr-preservesᵇ : (∀ {x y} → P x → P y → P (f x y)) → - ∀ {e xs} → P e → All P xs → P (foldr f e xs) - foldr-preservesᵇ _ Pe [] = Pe - foldr-preservesᵇ pres Pe (px ∷ pxs) = pres px (foldr-preservesᵇ pres Pe pxs) - - foldr-preservesʳ : (∀ x {y} → P y → P (f x y)) → - ∀ {e} → P e → ∀ xs → P (foldr f e xs) - foldr-preservesʳ pres Pe [] = Pe - foldr-preservesʳ pres Pe (_ ∷ xs) = pres _ (foldr-preservesʳ pres Pe xs) - - foldr-preservesᵒ : (∀ x y → P x ⊎ P y → P (f x y)) → - ∀ e xs → P e ⊎ Any P xs → P (foldr f e xs) - foldr-preservesᵒ pres e [] (inj₁ Pe) = Pe - foldr-preservesᵒ pres e (x ∷ xs) (inj₁ Pe) = - pres _ _ (inj₂ (foldr-preservesᵒ pres e xs (inj₁ Pe))) - foldr-preservesᵒ pres e (x ∷ xs) (inj₂ (here px)) = pres _ _ (inj₁ px) - foldr-preservesᵒ pres e (x ∷ xs) (inj₂ (there pxs)) = - pres _ _ (inj₂ (foldr-preservesᵒ pres e xs (inj₂ pxs))) - ------------------------------------------------------------------------- --- foldl - -foldl-++ : ∀ (f : A → B → A) x ys zs → - foldl f x (ys ++ zs) ≡ foldl f (foldl f x ys) zs -foldl-++ f x [] zs = refl -foldl-++ f x (y ∷ ys) zs = foldl-++ f (f x y) ys zs - -foldl-∷ʳ : ∀ (f : A → B → A) x y ys → - foldl f x (ys ∷ʳ y) ≡ f (foldl f x ys) y -foldl-∷ʳ f x y [] = refl -foldl-∷ʳ f x y (z ∷ ys) = foldl-∷ʳ f (f x z) y ys - -foldl-map : ∀ (f : A → B → A) (g : C → B) x xs → foldl f x (map g xs) ≡ foldl (∣ f ⟩- g) x xs -foldl-map f g x [] = refl -foldl-map f g x (y ∷ xs) = foldl-map f g (f x (g y)) xs - ------------------------------------------------------------------------- --- concat - -concat-map : ∀ {f : A → B} → concat ∘ map (map f) ≗ map f ∘ concat -concat-map {f = f} xss = begin - concat (map (map f) xss) ≡⟨ cong concat (map-is-foldr xss) ⟩ - concat (foldr (λ xs → map f xs ∷_) [] xss) ≡⟨ foldr-fusion concat [] (λ _ _ → refl) xss ⟩ - foldr (λ ys → map f ys ++_) [] xss ≡⟨ sym (foldr-fusion (map f) [] (map-++ f) xss) ⟩ - map f (concat xss) ∎ - -concat-++ : (xss yss : List (List A)) → concat xss ++ concat yss ≡ concat (xss ++ yss) -concat-++ [] yss = refl -concat-++ ([] ∷ xss) yss = concat-++ xss yss -concat-++ ((x ∷ xs) ∷ xss) yss = cong (x ∷_) (concat-++ (xs ∷ xss) yss) - -concat-concat : concat {A = A} ∘ map concat ≗ concat ∘ concat -concat-concat [] = refl -concat-concat (xss ∷ xsss) = begin - concat (map concat (xss ∷ xsss)) ≡⟨ cong (concat xss ++_) (concat-concat xsss) ⟩ - concat xss ++ concat (concat xsss) ≡⟨ concat-++ xss (concat xsss) ⟩ - concat (concat (xss ∷ xsss)) ∎ - -concat-[-] : concat {A = A} ∘ map [_] ≗ id -concat-[-] [] = refl -concat-[-] (x ∷ xs) = cong (x ∷_) (concat-[-] xs) - ------------------------------------------------------------------------- --- concatMap - -concatMap-cong : ∀ {f g : A → List B} → f ≗ g → concatMap f ≗ concatMap g -concatMap-cong eq xs = cong concat (map-cong eq xs) - -concatMap-pure : concatMap {A = A} [_] ≗ id -concatMap-pure = concat-[-] - -concatMap-map : (g : B → List C) → (f : A → B) → (xs : List A) → - concatMap g (map f xs) ≡ concatMap (g ∘′ f) xs -concatMap-map g f xs - = cong concat - {x = map g (map f xs)} - {y = map (g ∘′ f) xs} - (sym $ map-∘ xs) - -map-concatMap : (f : B → C) (g : A → List B) → - map f ∘′ concatMap g ≗ concatMap (map f ∘′ g) -map-concatMap f g xs = begin - map f (concatMap g xs) - ≡⟨⟩ - map f (concat (map g xs)) - ≡˘⟨ concat-map (map g xs) ⟩ - concat (map (map f) (map g xs)) - ≡⟨ cong concat - {x = map (map f) (map g xs)} - {y = map (map f ∘′ g) xs} - (sym $ map-∘ xs) ⟩ - concat (map (map f ∘′ g) xs) - ≡⟨⟩ - concatMap (map f ∘′ g) xs - ∎ - ------------------------------------------------------------------------- --- sum - -sum-++ : ∀ xs ys → sum (xs ++ ys) ≡ sum xs + sum ys -sum-++ [] ys = refl -sum-++ (x ∷ xs) ys = begin - x + sum (xs ++ ys) ≡⟨ cong (x +_) (sum-++ xs ys) ⟩ - x + (sum xs + sum ys) ≡⟨ sym (+-assoc x _ _) ⟩ - (x + sum xs) + sum ys ∎ - ------------------------------------------------------------------------- --- product - -∈⇒∣product : ∀ {n ns} → n ∈ ns → n ∣ product ns -∈⇒∣product {n} {n ∷ ns} (here refl) = divides (product ns) (*-comm n (product ns)) -∈⇒∣product {n} {m ∷ ns} (there n∈ns) = ∣n⇒∣m*n m (∈⇒∣product n∈ns) - ------------------------------------------------------------------------- --- replicate - -length-replicate : ∀ n {x : A} → length (replicate n x) ≡ n -length-replicate zero = refl -length-replicate (suc n) = cong suc (length-replicate n) - ------------------------------------------------------------------------- --- scanr - -scanr-defn : ∀ (f : A → B → B) (e : B) → - scanr f e ≗ map (foldr f e) ∘ tails -scanr-defn f e [] = refl -scanr-defn f e (x ∷ []) = refl -scanr-defn f e (x ∷ y∷xs@(_ ∷ _)) - with eq ← scanr-defn f e y∷xs - with z ∷ zs ← scanr f e y∷xs - = let z≡fy⦇f⦈xs , _ = ∷-injective eq in cong₂ (λ z → f x z ∷_) z≡fy⦇f⦈xs eq - ------------------------------------------------------------------------- --- scanl - -scanl-defn : ∀ (f : A → B → A) (e : A) → - scanl f e ≗ map (foldl f e) ∘ inits -scanl-defn f e [] = refl -scanl-defn f e (x ∷ xs) = cong (e ∷_) (begin - scanl f (f e x) xs - ≡⟨ scanl-defn f (f e x) xs ⟩ - map (foldl f (f e x)) (inits xs) - ≡⟨ refl ⟩ - map (foldl f e ∘ (x ∷_)) (inits xs) - ≡⟨ map-∘ (inits xs) ⟩ - map (foldl f e) (map (x ∷_) (inits xs)) - ∎) - ------------------------------------------------------------------------- --- applyUpTo - -length-applyUpTo : ∀ (f : ℕ → A) n → length (applyUpTo f n) ≡ n -length-applyUpTo f zero = refl -length-applyUpTo f (suc n) = cong suc (length-applyUpTo (f ∘ suc) n) - -lookup-applyUpTo : ∀ (f : ℕ → A) n i → lookup (applyUpTo f n) i ≡ f (toℕ i) -lookup-applyUpTo f (suc n) zero = refl -lookup-applyUpTo f (suc n) (suc i) = lookup-applyUpTo (f ∘ suc) n i - ------------------------------------------------------------------------- --- applyUpTo - -module _ (f : ℕ → A) where - - length-applyDownFrom : ∀ n → length (applyDownFrom f n) ≡ n - length-applyDownFrom zero = refl - length-applyDownFrom (suc n) = cong suc (length-applyDownFrom n) - - lookup-applyDownFrom : ∀ n i → lookup (applyDownFrom f n) i ≡ f (n ∸ (suc (toℕ i))) - lookup-applyDownFrom (suc n) zero = refl - lookup-applyDownFrom (suc n) (suc i) = lookup-applyDownFrom n i - ------------------------------------------------------------------------- --- upTo - -length-upTo : ∀ n → length (upTo n) ≡ n -length-upTo = length-applyUpTo id - -lookup-upTo : ∀ n i → lookup (upTo n) i ≡ toℕ i -lookup-upTo = lookup-applyUpTo id - ------------------------------------------------------------------------- --- downFrom - -length-downFrom : ∀ n → length (downFrom n) ≡ n -length-downFrom = length-applyDownFrom id - -lookup-downFrom : ∀ n i → lookup (downFrom n) i ≡ n ∸ (suc (toℕ i)) -lookup-downFrom = lookup-applyDownFrom id - ------------------------------------------------------------------------- --- tabulate - -tabulate-cong : ∀ {n} {f g : Fin n → A} → - f ≗ g → tabulate f ≡ tabulate g -tabulate-cong {n = zero} p = refl -tabulate-cong {n = suc n} p = cong₂ _∷_ (p zero) (tabulate-cong (p ∘ suc)) - -tabulate-lookup : ∀ (xs : List A) → tabulate (lookup xs) ≡ xs -tabulate-lookup [] = refl -tabulate-lookup (x ∷ xs) = cong (_ ∷_) (tabulate-lookup xs) - -length-tabulate : ∀ {n} → (f : Fin n → A) → - length (tabulate f) ≡ n -length-tabulate {n = zero} f = refl -length-tabulate {n = suc n} f = cong suc (length-tabulate (λ z → f (suc z))) - -lookup-tabulate : ∀ {n} → (f : Fin n → A) → - ∀ i → let i′ = cast (sym (length-tabulate f)) i - in lookup (tabulate f) i′ ≡ f i -lookup-tabulate f zero = refl -lookup-tabulate f (suc i) = lookup-tabulate (f ∘ suc) i - -map-tabulate : ∀ {n} (g : Fin n → A) (f : A → B) → - map f (tabulate g) ≡ tabulate (f ∘ g) -map-tabulate {n = zero} g f = refl -map-tabulate {n = suc n} g f = cong (_ ∷_) (map-tabulate (g ∘ suc) f) - ------------------------------------------------------------------------- --- _[_]%=_ - -length-%= : ∀ xs k (f : A → A) → length (xs [ k ]%= f) ≡ length xs -length-%= (x ∷ xs) zero f = refl -length-%= (x ∷ xs) (suc k) f = cong suc (length-%= xs k f) - ------------------------------------------------------------------------- --- _[_]∷=_ - -length-∷= : ∀ xs k (v : A) → length (xs [ k ]∷= v) ≡ length xs -length-∷= xs k v = length-%= xs k (const v) - -map-∷= : ∀ xs k (v : A) (f : A → B) → - let eq = sym (length-map f xs) in - map f (xs [ k ]∷= v) ≡ map f xs [ cast eq k ]∷= f v -map-∷= (x ∷ xs) zero v f = refl -map-∷= (x ∷ xs) (suc k) v f = cong (f x ∷_) (map-∷= xs k v f) - ------------------------------------------------------------------------- --- _─_ - -length-─ : ∀ (xs : List A) k → length (xs ─ k) ≡ pred (length xs) -length-─ (x ∷ xs) zero = refl -length-─ (x ∷ y ∷ xs) (suc k) = cong suc (length-─ (y ∷ xs) k) - -map-─ : ∀ xs k (f : A → B) → - let eq = sym (length-map f xs) in - map f (xs ─ k) ≡ map f xs ─ cast eq k -map-─ (x ∷ xs) zero f = refl -map-─ (x ∷ xs) (suc k) f = cong (f x ∷_) (map-─ xs k f) - ------------------------------------------------------------------------- --- take - -length-take : ∀ n (xs : List A) → length (take n xs) ≡ n ⊓ (length xs) -length-take zero xs = refl -length-take (suc n) [] = refl -length-take (suc n) (x ∷ xs) = cong suc (length-take n xs) - ------------------------------------------------------------------------- --- drop - -length-drop : ∀ n (xs : List A) → length (drop n xs) ≡ length xs ∸ n -length-drop zero xs = refl -length-drop (suc n) [] = refl -length-drop (suc n) (x ∷ xs) = length-drop n xs - -take++drop : ∀ n (xs : List A) → take n xs ++ drop n xs ≡ xs -take++drop zero xs = refl -take++drop (suc n) [] = refl -take++drop (suc n) (x ∷ xs) = cong (x ∷_) (take++drop n xs) - ------------------------------------------------------------------------- --- splitAt - -splitAt-defn : ∀ n → splitAt {A = A} n ≗ < take n , drop n > -splitAt-defn zero xs = refl -splitAt-defn (suc n) [] = refl -splitAt-defn (suc n) (x ∷ xs) = cong (Prod.map (x ∷_) id) (splitAt-defn n xs) - ------------------------------------------------------------------------- --- takeWhile, dropWhile, and span - -module _ {P : Pred A p} (P? : Decidable P) where - - takeWhile++dropWhile : ∀ xs → takeWhile P? xs ++ dropWhile P? xs ≡ xs - takeWhile++dropWhile [] = refl - takeWhile++dropWhile (x ∷ xs) with does (P? x) - ... | true = cong (x ∷_) (takeWhile++dropWhile xs) - ... | false = refl - - span-defn : span P? ≗ < takeWhile P? , dropWhile P? > - span-defn [] = refl - span-defn (x ∷ xs) with does (P? x) - ... | true = cong (Prod.map (x ∷_) id) (span-defn xs) - ... | false = refl - ------------------------------------------------------------------------- --- filter - -module _ {P : Pred A p} (P? : Decidable P) where - - length-filter : ∀ xs → length (filter P? xs) ≤ length xs - length-filter [] = z≤n - length-filter (x ∷ xs) with ih ← length-filter xs | does (P? x) - ... | false = m≤n⇒m≤1+n ih - ... | true = s≤s ih - - filter-all : ∀ {xs} → All P xs → filter P? xs ≡ xs - filter-all {[]} [] = refl - filter-all {x ∷ xs} (px ∷ pxs) with P? x - ... | no ¬px = contradiction px ¬px - ... | true because _ = cong (x ∷_) (filter-all pxs) - - filter-notAll : ∀ xs → Any (∁ P) xs → length (filter P? xs) < length xs - filter-notAll (x ∷ xs) (here ¬px) with P? x - ... | false because _ = s≤s (length-filter xs) - ... | yes px = contradiction px ¬px - filter-notAll (x ∷ xs) (there any) with ih ← filter-notAll xs any | does (P? x) - ... | false = m≤n⇒m≤1+n ih - ... | true = s≤s ih - - filter-some : ∀ {xs} → Any P xs → 0 < length (filter P? xs) - filter-some {x ∷ xs} (here px) with P? x - ... | true because _ = z<s - ... | no ¬px = contradiction px ¬px - filter-some {x ∷ xs} (there pxs) with does (P? x) - ... | true = m≤n⇒m≤1+n (filter-some pxs) - ... | false = filter-some pxs - - filter-none : ∀ {xs} → All (∁ P) xs → filter P? xs ≡ [] - filter-none {[]} [] = refl - filter-none {x ∷ xs} (¬px ∷ ¬pxs) with P? x - ... | false because _ = filter-none ¬pxs - ... | yes px = contradiction px ¬px - - filter-complete : ∀ {xs} → length (filter P? xs) ≡ length xs → - filter P? xs ≡ xs - filter-complete {[]} eq = refl - filter-complete {x ∷ xs} eq with does (P? x) - ... | false = contradiction eq (<⇒≢ (s≤s (length-filter xs))) - ... | true = cong (x ∷_) (filter-complete (suc-injective eq)) - - filter-accept : ∀ {x xs} → P x → filter P? (x ∷ xs) ≡ x ∷ (filter P? xs) - filter-accept {x} Px with P? x - ... | true because _ = refl - ... | no ¬Px = contradiction Px ¬Px - - filter-reject : ∀ {x xs} → ¬ P x → filter P? (x ∷ xs) ≡ filter P? xs - filter-reject {x} ¬Px with P? x - ... | yes Px = contradiction Px ¬Px - ... | false because _ = refl - - filter-idem : filter P? ∘ filter P? ≗ filter P? - filter-idem [] = refl - filter-idem (x ∷ xs) with does (P? x) | inspect does (P? x) - ... | false | _ = filter-idem xs - ... | true | P.[ eq ] rewrite eq = cong (x ∷_) (filter-idem xs) - - filter-++ : ∀ xs ys → filter P? (xs ++ ys) ≡ filter P? xs ++ filter P? ys - filter-++ [] ys = refl - filter-++ (x ∷ xs) ys with ih ← filter-++ xs ys | does (P? x) - ... | true = cong (x ∷_) ih - ... | false = ih - ------------------------------------------------------------------------- --- derun and deduplicate - -module _ {R : Rel A p} (R? : B.Decidable R) where - - length-derun : ∀ xs → length (derun R? xs) ≤ length xs - length-derun [] = ≤-refl - length-derun (x ∷ []) = ≤-refl - length-derun (x ∷ y ∷ xs) with ih ← length-derun (y ∷ xs) | does (R? x y) - ... | true = m≤n⇒m≤1+n ih - ... | false = s≤s ih - - length-deduplicate : ∀ xs → length (deduplicate R? xs) ≤ length xs - length-deduplicate [] = z≤n - length-deduplicate (x ∷ xs) = ≤-begin - 1 + length (filter (¬? ∘ R? x) r) ≤⟨ s≤s (length-filter (¬? ∘ R? x) r) ⟩ - 1 + length r ≤⟨ s≤s (length-deduplicate xs) ⟩ - 1 + length xs ≤-∎ - where - open ≤-Reasoning renaming (begin_ to ≤-begin_; _∎ to _≤-∎) - r = deduplicate R? xs - - derun-reject : ∀ {x y} xs → R x y → derun R? (x ∷ y ∷ xs) ≡ derun R? (y ∷ xs) - derun-reject {x} {y} xs Rxy with R? x y - ... | yes _ = refl - ... | no ¬Rxy = contradiction Rxy ¬Rxy - - derun-accept : ∀ {x y} xs → ¬ R x y → derun R? (x ∷ y ∷ xs) ≡ x ∷ derun R? (y ∷ xs) - derun-accept {x} {y} xs ¬Rxy with R? x y - ... | yes Rxy = contradiction Rxy ¬Rxy - ... | no _ = refl - ------------------------------------------------------------------------- --- partition - -module _ {P : Pred A p} (P? : Decidable P) where - - partition-defn : partition P? ≗ < filter P? , filter (∁? P?) > - partition-defn [] = refl - partition-defn (x ∷ xs) with ih ← partition-defn xs | does (P? x) - ... | true = cong (Prod.map (x ∷_) id) ih - ... | false = cong (Prod.map id (x ∷_)) ih - - length-partition : ∀ xs → (let (ys , zs) = partition P? xs) → - length ys ≤ length xs × length zs ≤ length xs - length-partition [] = z≤n , z≤n - length-partition (x ∷ xs) with ih ← length-partition xs | does (P? x) - ... | true = Prod.map s≤s m≤n⇒m≤1+n ih - ... | false = Prod.map m≤n⇒m≤1+n s≤s ih - ------------------------------------------------------------------------- --- _ʳ++_ - -ʳ++-defn : ∀ (xs : List A) {ys} → xs ʳ++ ys ≡ reverse xs ++ ys -ʳ++-defn [] = refl -ʳ++-defn (x ∷ xs) {ys} = begin - (x ∷ xs) ʳ++ ys ≡⟨⟩ - xs ʳ++ x ∷ ys ≡⟨⟩ - xs ʳ++ [ x ] ++ ys ≡⟨ ʳ++-defn xs ⟩ - reverse xs ++ [ x ] ++ ys ≡⟨ sym (++-assoc (reverse xs) _ _) ⟩ - (reverse xs ++ [ x ]) ++ ys ≡⟨ cong (_++ ys) (sym (ʳ++-defn xs)) ⟩ - (xs ʳ++ [ x ]) ++ ys ≡⟨⟩ - reverse (x ∷ xs) ++ ys ∎ - --- Reverse-append of append is reverse-append after reverse-append. - -ʳ++-++ : ∀ (xs {ys zs} : List A) → (xs ++ ys) ʳ++ zs ≡ ys ʳ++ xs ʳ++ zs -ʳ++-++ [] = refl -ʳ++-++ (x ∷ xs) {ys} {zs} = begin - (x ∷ xs ++ ys) ʳ++ zs ≡⟨⟩ - (xs ++ ys) ʳ++ x ∷ zs ≡⟨ ʳ++-++ xs ⟩ - ys ʳ++ xs ʳ++ x ∷ zs ≡⟨⟩ - ys ʳ++ (x ∷ xs) ʳ++ zs ∎ - --- Reverse-append of reverse-append is commuted reverse-append after append. - -ʳ++-ʳ++ : ∀ (xs {ys zs} : List A) → (xs ʳ++ ys) ʳ++ zs ≡ ys ʳ++ xs ++ zs -ʳ++-ʳ++ [] = refl -ʳ++-ʳ++ (x ∷ xs) {ys} {zs} = begin - ((x ∷ xs) ʳ++ ys) ʳ++ zs ≡⟨⟩ - (xs ʳ++ x ∷ ys) ʳ++ zs ≡⟨ ʳ++-ʳ++ xs ⟩ - (x ∷ ys) ʳ++ xs ++ zs ≡⟨⟩ - ys ʳ++ (x ∷ xs) ++ zs ∎ - --- Length of reverse-append - -length-ʳ++ : ∀ (xs {ys} : List A) → - length (xs ʳ++ ys) ≡ length xs + length ys -length-ʳ++ [] = refl -length-ʳ++ (x ∷ xs) {ys} = begin - length ((x ∷ xs) ʳ++ ys) ≡⟨⟩ - length (xs ʳ++ x ∷ ys) ≡⟨ length-ʳ++ xs ⟩ - length xs + length (x ∷ ys) ≡⟨ +-suc _ _ ⟩ - length (x ∷ xs) + length ys ∎ - --- map distributes over reverse-append. - -map-ʳ++ : (f : A → B) (xs {ys} : List A) → - map f (xs ʳ++ ys) ≡ map f xs ʳ++ map f ys -map-ʳ++ f [] = refl -map-ʳ++ f (x ∷ xs) {ys} = begin - map f ((x ∷ xs) ʳ++ ys) ≡⟨⟩ - map f (xs ʳ++ x ∷ ys) ≡⟨ map-ʳ++ f xs ⟩ - map f xs ʳ++ map f (x ∷ ys) ≡⟨⟩ - map f xs ʳ++ f x ∷ map f ys ≡⟨⟩ - (f x ∷ map f xs) ʳ++ map f ys ≡⟨⟩ - map f (x ∷ xs) ʳ++ map f ys ∎ - --- A foldr after a reverse is a foldl. - -foldr-ʳ++ : ∀ (f : A → B → B) b xs {ys} → - foldr f b (xs ʳ++ ys) ≡ foldl (flip f) (foldr f b ys) xs -foldr-ʳ++ f b [] {_} = refl -foldr-ʳ++ f b (x ∷ xs) {ys} = begin - foldr f b ((x ∷ xs) ʳ++ ys) ≡⟨⟩ - foldr f b (xs ʳ++ x ∷ ys) ≡⟨ foldr-ʳ++ f b xs ⟩ - foldl (flip f) (foldr f b (x ∷ ys)) xs ≡⟨⟩ - foldl (flip f) (f x (foldr f b ys)) xs ≡⟨⟩ - foldl (flip f) (foldr f b ys) (x ∷ xs) ∎ - --- A foldl after a reverse is a foldr. - -foldl-ʳ++ : ∀ (f : B → A → B) b xs {ys} → - foldl f b (xs ʳ++ ys) ≡ foldl f (foldr (flip f) b xs) ys -foldl-ʳ++ f b [] {_} = refl -foldl-ʳ++ f b (x ∷ xs) {ys} = begin - foldl f b ((x ∷ xs) ʳ++ ys) ≡⟨⟩ - foldl f b (xs ʳ++ x ∷ ys) ≡⟨ foldl-ʳ++ f b xs ⟩ - foldl f (foldr (flip f) b xs) (x ∷ ys) ≡⟨⟩ - foldl f (f (foldr (flip f) b xs) x) ys ≡⟨⟩ - foldl f (foldr (flip f) b (x ∷ xs)) ys ∎ - ------------------------------------------------------------------------- --- reverse - --- reverse of cons is snoc of reverse. - -unfold-reverse : ∀ (x : A) xs → reverse (x ∷ xs) ≡ reverse xs ∷ʳ x -unfold-reverse x xs = ʳ++-defn xs - --- reverse is an involution with respect to append. - -reverse-++ : (xs ys : List A) → - reverse (xs ++ ys) ≡ reverse ys ++ reverse xs -reverse-++ xs ys = begin - reverse (xs ++ ys) ≡⟨⟩ - (xs ++ ys) ʳ++ [] ≡⟨ ʳ++-++ xs ⟩ - ys ʳ++ xs ʳ++ [] ≡⟨⟩ - ys ʳ++ reverse xs ≡⟨ ʳ++-defn ys ⟩ - reverse ys ++ reverse xs ∎ - --- reverse is involutive. - -reverse-involutive : Involutive {A = List A} _≡_ reverse -reverse-involutive xs = begin - reverse (reverse xs) ≡⟨⟩ - (xs ʳ++ []) ʳ++ [] ≡⟨ ʳ++-ʳ++ xs ⟩ - [] ʳ++ xs ++ [] ≡⟨⟩ - xs ++ [] ≡⟨ ++-identityʳ xs ⟩ - xs ∎ - --- reverse is injective. - -reverse-injective : ∀ {xs ys : List A} → reverse xs ≡ reverse ys → xs ≡ ys -reverse-injective = subst₂ _≡_ (reverse-involutive _) (reverse-involutive _) ∘ cong reverse - --- reverse preserves length. - -length-reverse : ∀ (xs : List A) → length (reverse xs) ≡ length xs -length-reverse xs = begin - length (reverse xs) ≡⟨⟩ - length (xs ʳ++ []) ≡⟨ length-ʳ++ xs ⟩ - length xs + 0 ≡⟨ +-identityʳ _ ⟩ - length xs ∎ - -reverse-map : (f : A → B) → map f ∘ reverse ≗ reverse ∘ map f -reverse-map f xs = begin - map f (reverse xs) ≡⟨⟩ - map f (xs ʳ++ []) ≡⟨ map-ʳ++ f xs ⟩ - map f xs ʳ++ [] ≡⟨⟩ - reverse (map f xs) ∎ - -reverse-foldr : ∀ (f : A → B → B) b → - foldr f b ∘ reverse ≗ foldl (flip f) b -reverse-foldr f b xs = foldr-ʳ++ f b xs - -reverse-foldl : ∀ (f : B → A → B) b xs → - foldl f b (reverse xs) ≡ foldr (flip f) b xs -reverse-foldl f b xs = foldl-ʳ++ f b xs - ------------------------------------------------------------------------- --- _∷ʳ_ - -module _ {x y : A} where - - ∷ʳ-injective : ∀ xs ys → xs ∷ʳ x ≡ ys ∷ʳ y → xs ≡ ys × x ≡ y - ∷ʳ-injective [] [] refl = (refl , refl) - ∷ʳ-injective (x ∷ xs) (y ∷ ys) eq with refl , eq′ ← ∷-injective eq - = Prod.map (cong (x ∷_)) id (∷ʳ-injective xs ys eq′) - ∷ʳ-injective [] (_ ∷ _ ∷ _) () - ∷ʳ-injective (_ ∷ _ ∷ _) [] () - - ∷ʳ-injectiveˡ : ∀ (xs ys : List A) → xs ∷ʳ x ≡ ys ∷ʳ y → xs ≡ ys - ∷ʳ-injectiveˡ xs ys eq = proj₁ (∷ʳ-injective xs ys eq) - - ∷ʳ-injectiveʳ : ∀ (xs ys : List A) → xs ∷ʳ x ≡ ys ∷ʳ y → x ≡ y - ∷ʳ-injectiveʳ xs ys eq = proj₂ (∷ʳ-injective xs ys eq) - -∷ʳ-++ : ∀ (xs : List A) (a : A) (ys : List A) → xs ∷ʳ a ++ ys ≡ xs ++ a ∷ ys -∷ʳ-++ xs a ys = ++-assoc xs [ a ] ys - ------------------------------------------------------------------------- --- DEPRECATED ------------------------------------------------------------------------- --- Please use the new names as continuing support for the old names is --- not guaranteed. - --- Version 2.0 - -map-id₂ = map-id-local -{-# WARNING_ON_USAGE map-id₂ -"Warning: map-id₂ was deprecated in v2.0. +open import Data.List.Membership.Propositional using (_∈_) +open import Data.List.Relation.Unary.All using (All; []; _∷_) +open import Data.List.Relation.Unary.Any using (Any; here; there) +open import Data.Maybe.Base as Maybe using (Maybe; just; nothing) +open import Data.Nat.Base +open import Data.Nat.Divisibility +open import Data.Nat.Properties +open import Data.Product.Base as Prod + using (_×_; _,_; uncurry; uncurry′; proj₁; proj₂; <_,_>) +import Data.Product.Relation.Unary.All as Prod using (All) +open import Data.Sum.Base using (_⊎_; inj₁; inj₂) +open import Data.These.Base as These using (These; this; that; these) +open import Data.Fin.Properties using (toℕ-cast) +open import Function.Base using (id; _∘_; _∘′_; _∋_; _-⟨_∣; ∣_⟩-_; _$_; const; flip) +open import Function.Definitions using (Injective) +open import Level using (Level) +open import Relation.Binary.Definitions as B using (DecidableEquality) +import Relation.Binary.Reasoning.Setoid as EqR +open import Relation.Binary.PropositionalEquality as P hiding ([_]) +open import Relation.Binary.Core using (Rel) +open import Relation.Nullary.Reflects using (invert) +open import Relation.Nullary using (¬_; Dec; does; _because_; yes; no; contradiction) +open import Relation.Nullary.Decidable as Decidable using (isYes; map′; ⌊_⌋; ¬?; _×-dec_) +open import Relation.Unary using (Pred; Decidable; ∁) +open import Relation.Unary.Properties using (∁?) +import Data.Nat.GeneralisedArithmetic as ℕ + + +open ≡-Reasoning + +private + variable + a b c d e p : Level + A : Set a + B : Set b + C : Set c + D : Set d + E : Set e + +------------------------------------------------------------------------ +-- _∷_ + +module _ {x y : A} {xs ys : List A} where + + ∷-injective : x ∷ xs ≡ y List.∷ ys → x ≡ y × xs ≡ ys + ∷-injective refl = (refl , refl) + + ∷-injectiveˡ : x ∷ xs ≡ y List.∷ ys → x ≡ y + ∷-injectiveˡ refl = refl + + ∷-injectiveʳ : x ∷ xs ≡ y List.∷ ys → xs ≡ ys + ∷-injectiveʳ refl = refl + + ∷-dec : Dec (x ≡ y) → Dec (xs ≡ ys) → Dec (x List.∷ xs ≡ y ∷ ys) + ∷-dec x≟y xs≟ys = Decidable.map′ (uncurry (cong₂ _∷_)) ∷-injective (x≟y ×-dec xs≟ys) + +≡-dec : DecidableEquality A → DecidableEquality (List A) +≡-dec _≟_ [] [] = yes refl +≡-dec _≟_ (x ∷ xs) [] = no λ() +≡-dec _≟_ [] (y ∷ ys) = no λ() +≡-dec _≟_ (x ∷ xs) (y ∷ ys) = ∷-dec (x ≟ y) (≡-dec _≟_ xs ys) + +------------------------------------------------------------------------ +-- map + +map-id : map id ≗ id {A = List A} +map-id [] = refl +map-id (x ∷ xs) = cong (x ∷_) (map-id xs) + +map-id-local : ∀ {f : A → A} {xs} → All (λ x → f x ≡ x) xs → map f xs ≡ xs +map-id-local [] = refl +map-id-local (fx≡x ∷ pxs) = cong₂ _∷_ fx≡x (map-id-local pxs) + +map-++ : ∀ (f : A → B) xs ys → + map f (xs ++ ys) ≡ map f xs ++ map f ys +map-++ f [] ys = refl +map-++ f (x ∷ xs) ys = cong (f x ∷_) (map-++ f xs ys) + +map-cong : ∀ {f g : A → B} → f ≗ g → map f ≗ map g +map-cong f≗g [] = refl +map-cong f≗g (x ∷ xs) = cong₂ _∷_ (f≗g x) (map-cong f≗g xs) + +map-cong-local : ∀ {f g : A → B} {xs} → + All (λ x → f x ≡ g x) xs → map f xs ≡ map g xs +map-cong-local [] = refl +map-cong-local (fx≡gx ∷ fxs≡gxs) = cong₂ _∷_ fx≡gx (map-cong-local fxs≡gxs) + +length-map : ∀ (f : A → B) xs → length (map f xs) ≡ length xs +length-map f [] = refl +length-map f (x ∷ xs) = cong suc (length-map f xs) + +map-∘ : {g : B → C} {f : A → B} → map (g ∘ f) ≗ map g ∘ map f +map-∘ [] = refl +map-∘ (x ∷ xs) = cong (_ ∷_) (map-∘ xs) + +map-injective : ∀ {f : A → B} → Injective _≡_ _≡_ f → Injective _≡_ _≡_ (map f) +map-injective finj {[]} {[]} eq = refl +map-injective finj {x ∷ xs} {y ∷ ys} eq = + let fx≡fy , fxs≡fys = ∷-injective eq in + cong₂ _∷_ (finj fx≡fy) (map-injective finj fxs≡fys) + +------------------------------------------------------------------------ +-- mapMaybe + +mapMaybe-just : (xs : List A) → mapMaybe just xs ≡ xs +mapMaybe-just [] = refl +mapMaybe-just (x ∷ xs) = cong (x ∷_) (mapMaybe-just xs) + +mapMaybe-nothing : (xs : List A) → + mapMaybe {B = A} (λ _ → nothing) xs ≡ [] +mapMaybe-nothing [] = refl +mapMaybe-nothing (x ∷ xs) = mapMaybe-nothing xs + +module _ (f : A → Maybe B) where + + mapMaybe-concatMap : mapMaybe f ≗ concatMap (fromMaybe ∘ f) + mapMaybe-concatMap [] = refl + mapMaybe-concatMap (x ∷ xs) with ih ← mapMaybe-concatMap xs | f x + ... | just y = cong (y ∷_) ih + ... | nothing = ih + + length-mapMaybe : ∀ xs → length (mapMaybe f xs) ≤ length xs + length-mapMaybe [] = z≤n + length-mapMaybe (x ∷ xs) with ih ← length-mapMaybe xs | f x + ... | just y = s≤s ih + ... | nothing = m≤n⇒m≤1+n ih + +------------------------------------------------------------------------ +-- _++_ + +length-++ : ∀ (xs : List A) {ys} → + length (xs ++ ys) ≡ length xs + length ys +length-++ [] = refl +length-++ (x ∷ xs) = cong suc (length-++ xs) + +module _ {A : Set a} where + + open AlgebraicDefinitions {A = List A} _≡_ + open AlgebraicStructures {A = List A} _≡_ + + ++-assoc : Associative _++_ + ++-assoc [] ys zs = refl + ++-assoc (x ∷ xs) ys zs = cong (x ∷_) (++-assoc xs ys zs) + + ++-identityˡ : LeftIdentity [] _++_ + ++-identityˡ xs = refl + + ++-identityʳ : RightIdentity [] _++_ + ++-identityʳ [] = refl + ++-identityʳ (x ∷ xs) = cong (x ∷_) (++-identityʳ xs) + + ++-identity : Identity [] _++_ + ++-identity = ++-identityˡ , ++-identityʳ + + ++-identityʳ-unique : ∀ (xs : List A) {ys} → xs ≡ xs ++ ys → ys ≡ [] + ++-identityʳ-unique [] refl = refl + ++-identityʳ-unique (x ∷ xs) eq = + ++-identityʳ-unique xs (proj₂ (∷-injective eq)) + + ++-identityˡ-unique : ∀ {xs} (ys : List A) → xs ≡ ys ++ xs → ys ≡ [] + ++-identityˡ-unique [] _ = refl + ++-identityˡ-unique {xs = x ∷ xs} (y ∷ ys) eq + with ++-identityˡ-unique (ys ++ [ x ]) (begin + xs ≡⟨ proj₂ (∷-injective eq) ⟩ + ys ++ x ∷ xs ≡⟨ sym (++-assoc ys [ x ] xs) ⟩ + (ys ++ [ x ]) ++ xs ∎) + ++-identityˡ-unique {xs = x ∷ xs} (y ∷ [] ) eq | () + ++-identityˡ-unique {xs = x ∷ xs} (y ∷ _ ∷ _) eq | () + + ++-cancelˡ : LeftCancellative _++_ + ++-cancelˡ [] _ _ ys≡zs = ys≡zs + ++-cancelˡ (x ∷ xs) _ _ x∷xs++ys≡x∷xs++zs = ++-cancelˡ xs _ _ (∷-injectiveʳ x∷xs++ys≡x∷xs++zs) + + ++-cancelʳ : RightCancellative _++_ + ++-cancelʳ _ [] [] _ = refl + ++-cancelʳ xs [] (z ∷ zs) eq = + contradiction (trans (cong length eq) (length-++ (z ∷ zs))) (m≢1+n+m (length xs)) + ++-cancelʳ xs (y ∷ ys) [] eq = + contradiction (trans (sym (length-++ (y ∷ ys))) (cong length eq)) (m≢1+n+m (length xs) ∘ sym) + ++-cancelʳ _ (y ∷ ys) (z ∷ zs) eq = + cong₂ _∷_ (∷-injectiveˡ eq) (++-cancelʳ _ ys zs (∷-injectiveʳ eq)) + + ++-cancel : Cancellative _++_ + ++-cancel = ++-cancelˡ , ++-cancelʳ + + ++-conicalˡ : ∀ (xs ys : List A) → xs ++ ys ≡ [] → xs ≡ [] + ++-conicalˡ [] _ refl = refl + + ++-conicalʳ : ∀ (xs ys : List A) → xs ++ ys ≡ [] → ys ≡ [] + ++-conicalʳ [] _ refl = refl + + ++-conical : Conical [] _++_ + ++-conical = ++-conicalˡ , ++-conicalʳ + + ++-isMagma : IsMagma _++_ + ++-isMagma = record + { isEquivalence = isEquivalence + ; ∙-cong = cong₂ _++_ + } + + ++-isSemigroup : IsSemigroup _++_ + ++-isSemigroup = record + { isMagma = ++-isMagma + ; assoc = ++-assoc + } + + ++-isMonoid : IsMonoid _++_ [] + ++-isMonoid = record + { isSemigroup = ++-isSemigroup + ; identity = ++-identity + } + +module _ (A : Set a) where + + ++-semigroup : Semigroup a a + ++-semigroup = record + { Carrier = List A + ; isSemigroup = ++-isSemigroup + } + + ++-monoid : Monoid a a + ++-monoid = record + { Carrier = List A + ; isMonoid = ++-isMonoid + } + +module _ (A : Set a) where + + length-isMagmaHomomorphism : IsMagmaHomomorphism (++-rawMagma A) +-rawMagma length + length-isMagmaHomomorphism = record + { isRelHomomorphism = record + { cong = cong length + } + ; homo = λ xs ys → length-++ xs {ys} + } + + length-isMonoidHomomorphism : IsMonoidHomomorphism (++-[]-rawMonoid A) +-0-rawMonoid length + length-isMonoidHomomorphism = record + { isMagmaHomomorphism = length-isMagmaHomomorphism + ; ε-homo = refl + } + +------------------------------------------------------------------------ +-- cartesianProductWith + +module _ (f : A → B → C) where + + private + prod = cartesianProductWith f + + cartesianProductWith-zeroˡ : ∀ ys → prod [] ys ≡ [] + cartesianProductWith-zeroˡ _ = refl + + cartesianProductWith-zeroʳ : ∀ xs → prod xs [] ≡ [] + cartesianProductWith-zeroʳ [] = refl + cartesianProductWith-zeroʳ (x ∷ xs) = cartesianProductWith-zeroʳ xs + + cartesianProductWith-distribʳ-++ : ∀ xs ys zs → prod (xs ++ ys) zs ≡ prod xs zs ++ prod ys zs + cartesianProductWith-distribʳ-++ [] ys zs = refl + cartesianProductWith-distribʳ-++ (x ∷ xs) ys zs = begin + prod (x ∷ xs ++ ys) zs ≡⟨⟩ + map (f x) zs ++ prod (xs ++ ys) zs ≡⟨ cong (map (f x) zs ++_) (cartesianProductWith-distribʳ-++ xs ys zs) ⟩ + map (f x) zs ++ prod xs zs ++ prod ys zs ≡⟨ ++-assoc (map (f x) zs) (prod xs zs) (prod ys zs) ⟨ + (map (f x) zs ++ prod xs zs) ++ prod ys zs ≡⟨⟩ + prod (x ∷ xs) zs ++ prod ys zs ∎ + +------------------------------------------------------------------------ +-- alignWith + +module _ {f g : These A B → C} where + + alignWith-cong : f ≗ g → ∀ as → alignWith f as ≗ alignWith g as + alignWith-cong f≗g [] bs = map-cong (f≗g ∘ that) bs + alignWith-cong f≗g as@(_ ∷ _) [] = map-cong (f≗g ∘ this) as + alignWith-cong f≗g (a ∷ as) (b ∷ bs) = + cong₂ _∷_ (f≗g (these a b)) (alignWith-cong f≗g as bs) + + length-alignWith : ∀ xs ys → + length (alignWith f xs ys) ≡ length xs ⊔ length ys + length-alignWith [] ys = length-map (f ∘′ that) ys + length-alignWith xs@(_ ∷ _) [] = length-map (f ∘′ this) xs + length-alignWith (x ∷ xs) (y ∷ ys) = cong suc (length-alignWith xs ys) + + alignWith-map : (g : D → A) (h : E → B) → + ∀ xs ys → alignWith f (map g xs) (map h ys) ≡ + alignWith (f ∘′ These.map g h) xs ys + alignWith-map g h [] ys = sym (map-∘ ys) + alignWith-map g h xs@(_ ∷ _) [] = sym (map-∘ xs) + alignWith-map g h (x ∷ xs) (y ∷ ys) = + cong₂ _∷_ refl (alignWith-map g h xs ys) + + map-alignWith : ∀ (g : C → D) → ∀ xs ys → + map g (alignWith f xs ys) ≡ + alignWith (g ∘′ f) xs ys + map-alignWith g [] ys = sym (map-∘ ys) + map-alignWith g xs@(_ ∷ _) [] = sym (map-∘ xs) + map-alignWith g (x ∷ xs) (y ∷ ys) = + cong₂ _∷_ refl (map-alignWith g xs ys) + +------------------------------------------------------------------------ +-- zipWith + +module _ (f : A → A → B) where + + zipWith-comm : (∀ x y → f x y ≡ f y x) → + ∀ xs ys → zipWith f xs ys ≡ zipWith f ys xs + zipWith-comm f-comm [] [] = refl + zipWith-comm f-comm [] (x ∷ ys) = refl + zipWith-comm f-comm (x ∷ xs) [] = refl + zipWith-comm f-comm (x ∷ xs) (y ∷ ys) = + cong₂ _∷_ (f-comm x y) (zipWith-comm f-comm xs ys) + +module _ (f : A → B → C) where + + zipWith-zeroˡ : ∀ xs → zipWith f [] xs ≡ [] + zipWith-zeroˡ [] = refl + zipWith-zeroˡ (x ∷ xs) = refl + + zipWith-zeroʳ : ∀ xs → zipWith f xs [] ≡ [] + zipWith-zeroʳ [] = refl + zipWith-zeroʳ (x ∷ xs) = refl + + length-zipWith : ∀ xs ys → + length (zipWith f xs ys) ≡ length xs ⊓ length ys + length-zipWith [] [] = refl + length-zipWith [] (y ∷ ys) = refl + length-zipWith (x ∷ xs) [] = refl + length-zipWith (x ∷ xs) (y ∷ ys) = cong suc (length-zipWith xs ys) + + zipWith-map : ∀ {d e} {D : Set d} {E : Set e} (g : D → A) (h : E → B) → + ∀ xs ys → zipWith f (map g xs) (map h ys) ≡ + zipWith (λ x y → f (g x) (h y)) xs ys + zipWith-map g h [] [] = refl + zipWith-map g h [] (y ∷ ys) = refl + zipWith-map g h (x ∷ xs) [] = refl + zipWith-map g h (x ∷ xs) (y ∷ ys) = + cong₂ _∷_ refl (zipWith-map g h xs ys) + + map-zipWith : ∀ {d} {D : Set d} (g : C → D) → ∀ xs ys → + map g (zipWith f xs ys) ≡ + zipWith (λ x y → g (f x y)) xs ys + map-zipWith g [] [] = refl + map-zipWith g [] (y ∷ ys) = refl + map-zipWith g (x ∷ xs) [] = refl + map-zipWith g (x ∷ xs) (y ∷ ys) = + cong₂ _∷_ refl (map-zipWith g xs ys) + +------------------------------------------------------------------------ +-- unalignWith + +unalignWith-this : unalignWith ((A → These A B) ∋ this) ≗ (_, []) +unalignWith-this [] = refl +unalignWith-this (a ∷ as) = cong (Prod.map₁ (a ∷_)) (unalignWith-this as) + +unalignWith-that : unalignWith ((B → These A B) ∋ that) ≗ ([] ,_) +unalignWith-that [] = refl +unalignWith-that (b ∷ bs) = cong (Prod.map₂ (b ∷_)) (unalignWith-that bs) + +module _ {f g : C → These A B} where + + unalignWith-cong : f ≗ g → unalignWith f ≗ unalignWith g + unalignWith-cong f≗g [] = refl + unalignWith-cong f≗g (c ∷ cs) with f c | g c | f≗g c + ... | this a | ._ | refl = cong (Prod.map₁ (a ∷_)) (unalignWith-cong f≗g cs) + ... | that b | ._ | refl = cong (Prod.map₂ (b ∷_)) (unalignWith-cong f≗g cs) + ... | these a b | ._ | refl = cong (Prod.map (a ∷_) (b ∷_)) (unalignWith-cong f≗g cs) + +module _ (f : C → These A B) where + + unalignWith-map : (g : D → C) → ∀ ds → + unalignWith f (map g ds) ≡ unalignWith (f ∘′ g) ds + unalignWith-map g [] = refl + unalignWith-map g (d ∷ ds) with f (g d) + ... | this a = cong (Prod.map₁ (a ∷_)) (unalignWith-map g ds) + ... | that b = cong (Prod.map₂ (b ∷_)) (unalignWith-map g ds) + ... | these a b = cong (Prod.map (a ∷_) (b ∷_)) (unalignWith-map g ds) + + map-unalignWith : (g : A → D) (h : B → E) → + Prod.map (map g) (map h) ∘′ unalignWith f ≗ unalignWith (These.map g h ∘′ f) + map-unalignWith g h [] = refl + map-unalignWith g h (c ∷ cs) with f c + ... | this a = cong (Prod.map₁ (g a ∷_)) (map-unalignWith g h cs) + ... | that b = cong (Prod.map₂ (h b ∷_)) (map-unalignWith g h cs) + ... | these a b = cong (Prod.map (g a ∷_) (h b ∷_)) (map-unalignWith g h cs) + + unalignWith-alignWith : (g : These A B → C) → f ∘′ g ≗ id → ∀ as bs → + unalignWith f (alignWith g as bs) ≡ (as , bs) + unalignWith-alignWith g g∘f≗id [] bs = begin + unalignWith f (map (g ∘′ that) bs) ≡⟨ unalignWith-map (g ∘′ that) bs ⟩ + unalignWith (f ∘′ g ∘′ that) bs ≡⟨ unalignWith-cong (g∘f≗id ∘ that) bs ⟩ + unalignWith that bs ≡⟨ unalignWith-that bs ⟩ + [] , bs ∎ + unalignWith-alignWith g g∘f≗id as@(_ ∷ _) [] = begin + unalignWith f (map (g ∘′ this) as) ≡⟨ unalignWith-map (g ∘′ this) as ⟩ + unalignWith (f ∘′ g ∘′ this) as ≡⟨ unalignWith-cong (g∘f≗id ∘ this) as ⟩ + unalignWith this as ≡⟨ unalignWith-this as ⟩ + as , [] ∎ + unalignWith-alignWith g g∘f≗id (a ∷ as) (b ∷ bs) + rewrite g∘f≗id (these a b) = + cong (Prod.map (a ∷_) (b ∷_)) (unalignWith-alignWith g g∘f≗id as bs) + +------------------------------------------------------------------------ +-- unzipWith + +module _ (f : A → B × C) where + + length-unzipWith₁ : ∀ xys → + length (proj₁ (unzipWith f xys)) ≡ length xys + length-unzipWith₁ [] = refl + length-unzipWith₁ (x ∷ xys) = cong suc (length-unzipWith₁ xys) + + length-unzipWith₂ : ∀ xys → + length (proj₂ (unzipWith f xys)) ≡ length xys + length-unzipWith₂ [] = refl + length-unzipWith₂ (x ∷ xys) = cong suc (length-unzipWith₂ xys) + + zipWith-unzipWith : (g : B → C → A) → uncurry′ g ∘ f ≗ id → + uncurry′ (zipWith g) ∘ (unzipWith f) ≗ id + zipWith-unzipWith g f∘g≗id [] = refl + zipWith-unzipWith g f∘g≗id (x ∷ xs) = + cong₂ _∷_ (f∘g≗id x) (zipWith-unzipWith g f∘g≗id xs) + +------------------------------------------------------------------------ +-- foldr + +foldr-universal : ∀ (h : List A → B) f e → (h [] ≡ e) → + (∀ x xs → h (x ∷ xs) ≡ f x (h xs)) → + h ≗ foldr f e +foldr-universal h f e base step [] = base +foldr-universal h f e base step (x ∷ xs) = begin + h (x ∷ xs) ≡⟨ step x xs ⟩ + f x (h xs) ≡⟨ cong (f x) (foldr-universal h f e base step xs) ⟩ + f x (foldr f e xs) ∎ + +foldr-cong : ∀ {f g : A → B → B} {d e : B} → + (∀ x y → f x y ≡ g x y) → d ≡ e → + foldr f d ≗ foldr g e +foldr-cong f≗g refl [] = refl +foldr-cong f≗g d≡e (x ∷ xs) rewrite foldr-cong f≗g d≡e xs = f≗g x _ + +foldr-fusion : ∀ (h : B → C) {f : A → B → B} {g : A → C → C} (e : B) → + (∀ x y → h (f x y) ≡ g x (h y)) → + h ∘ foldr f e ≗ foldr g (h e) +foldr-fusion h {f} {g} e fuse = + foldr-universal (h ∘ foldr f e) g (h e) refl + (λ x xs → fuse x (foldr f e xs)) + +id-is-foldr : id {A = List A} ≗ foldr _∷_ [] +id-is-foldr = foldr-universal id _∷_ [] refl (λ _ _ → refl) + +++-is-foldr : (xs ys : List A) → xs ++ ys ≡ foldr _∷_ ys xs +++-is-foldr xs ys = begin + xs ++ ys ≡⟨ cong (_++ ys) (id-is-foldr xs) ⟩ + foldr _∷_ [] xs ++ ys ≡⟨ foldr-fusion (_++ ys) [] (λ _ _ → refl) xs ⟩ + foldr _∷_ ([] ++ ys) xs ≡⟨⟩ + foldr _∷_ ys xs ∎ + +foldr-++ : ∀ (f : A → B → B) x ys zs → + foldr f x (ys ++ zs) ≡ foldr f (foldr f x zs) ys +foldr-++ f x [] zs = refl +foldr-++ f x (y ∷ ys) zs = cong (f y) (foldr-++ f x ys zs) + +map-is-foldr : {f : A → B} → map f ≗ foldr (λ x ys → f x ∷ ys) [] +map-is-foldr {f = f} xs = begin + map f xs ≡⟨ cong (map f) (id-is-foldr xs) ⟩ + map f (foldr _∷_ [] xs) ≡⟨ foldr-fusion (map f) [] (λ _ _ → refl) xs ⟩ + foldr (λ x ys → f x ∷ ys) [] xs ∎ + +foldr-∷ʳ : ∀ (f : A → B → B) x y ys → + foldr f x (ys ∷ʳ y) ≡ foldr f (f y x) ys +foldr-∷ʳ f x y [] = refl +foldr-∷ʳ f x y (z ∷ ys) = cong (f z) (foldr-∷ʳ f x y ys) + +foldr-map : ∀ (f : A → B → B) (g : C → A) x xs → foldr f x (map g xs) ≡ foldr (g -⟨ f ∣) x xs +foldr-map f g x [] = refl +foldr-map f g x (y ∷ xs) = cong (f (g y)) (foldr-map f g x xs) + +-- Interaction with predicates + +module _ {P : Pred A p} {f : A → A → A} where + + foldr-forcesᵇ : (∀ x y → P (f x y) → P x × P y) → + ∀ e xs → P (foldr f e xs) → All P xs + foldr-forcesᵇ _ _ [] _ = [] + foldr-forcesᵇ forces _ (x ∷ xs) Pfold = + let px , pfxs = forces _ _ Pfold in px ∷ foldr-forcesᵇ forces _ xs pfxs + + foldr-preservesᵇ : (∀ {x y} → P x → P y → P (f x y)) → + ∀ {e xs} → P e → All P xs → P (foldr f e xs) + foldr-preservesᵇ _ Pe [] = Pe + foldr-preservesᵇ pres Pe (px ∷ pxs) = pres px (foldr-preservesᵇ pres Pe pxs) + + foldr-preservesʳ : (∀ x {y} → P y → P (f x y)) → + ∀ {e} → P e → ∀ xs → P (foldr f e xs) + foldr-preservesʳ pres Pe [] = Pe + foldr-preservesʳ pres Pe (_ ∷ xs) = pres _ (foldr-preservesʳ pres Pe xs) + + foldr-preservesᵒ : (∀ x y → P x ⊎ P y → P (f x y)) → + ∀ e xs → P e ⊎ Any P xs → P (foldr f e xs) + foldr-preservesᵒ pres e [] (inj₁ Pe) = Pe + foldr-preservesᵒ pres e (x ∷ xs) (inj₁ Pe) = + pres _ _ (inj₂ (foldr-preservesᵒ pres e xs (inj₁ Pe))) + foldr-preservesᵒ pres e (x ∷ xs) (inj₂ (here px)) = pres _ _ (inj₁ px) + foldr-preservesᵒ pres e (x ∷ xs) (inj₂ (there pxs)) = + pres _ _ (inj₂ (foldr-preservesᵒ pres e xs (inj₂ pxs))) + +------------------------------------------------------------------------ +-- foldl + +foldl-++ : ∀ (f : A → B → A) x ys zs → + foldl f x (ys ++ zs) ≡ foldl f (foldl f x ys) zs +foldl-++ f x [] zs = refl +foldl-++ f x (y ∷ ys) zs = foldl-++ f (f x y) ys zs + +foldl-∷ʳ : ∀ (f : A → B → A) x y ys → + foldl f x (ys ∷ʳ y) ≡ f (foldl f x ys) y +foldl-∷ʳ f x y [] = refl +foldl-∷ʳ f x y (z ∷ ys) = foldl-∷ʳ f (f x z) y ys + +foldl-map : ∀ (f : A → B → A) (g : C → B) x xs → foldl f x (map g xs) ≡ foldl (∣ f ⟩- g) x xs +foldl-map f g x [] = refl +foldl-map f g x (y ∷ xs) = foldl-map f g (f x (g y)) xs + +------------------------------------------------------------------------ +-- concat + +concat-map : ∀ {f : A → B} → concat ∘ map (map f) ≗ map f ∘ concat +concat-map {f = f} xss = begin + concat (map (map f) xss) ≡⟨ cong concat (map-is-foldr xss) ⟩ + concat (foldr (λ xs → map f xs ∷_) [] xss) ≡⟨ foldr-fusion concat [] (λ _ _ → refl) xss ⟩ + foldr (λ ys → map f ys ++_) [] xss ≡⟨ sym (foldr-fusion (map f) [] (map-++ f) xss) ⟩ + map f (concat xss) ∎ + +concat-++ : (xss yss : List (List A)) → concat xss ++ concat yss ≡ concat (xss ++ yss) +concat-++ [] yss = refl +concat-++ ([] ∷ xss) yss = concat-++ xss yss +concat-++ ((x ∷ xs) ∷ xss) yss = cong (x ∷_) (concat-++ (xs ∷ xss) yss) + +concat-concat : concat {A = A} ∘ map concat ≗ concat ∘ concat +concat-concat [] = refl +concat-concat (xss ∷ xsss) = begin + concat (map concat (xss ∷ xsss)) ≡⟨ cong (concat xss ++_) (concat-concat xsss) ⟩ + concat xss ++ concat (concat xsss) ≡⟨ concat-++ xss (concat xsss) ⟩ + concat (concat (xss ∷ xsss)) ∎ + +concat-[-] : concat {A = A} ∘ map [_] ≗ id +concat-[-] [] = refl +concat-[-] (x ∷ xs) = cong (x ∷_) (concat-[-] xs) + +------------------------------------------------------------------------ +-- concatMap + +concatMap-cong : ∀ {f g : A → List B} → f ≗ g → concatMap f ≗ concatMap g +concatMap-cong eq xs = cong concat (map-cong eq xs) + +concatMap-pure : concatMap {A = A} [_] ≗ id +concatMap-pure = concat-[-] + +concatMap-map : (g : B → List C) → (f : A → B) → (xs : List A) → + concatMap g (map f xs) ≡ concatMap (g ∘′ f) xs +concatMap-map g f xs + = cong concat + {x = map g (map f xs)} + {y = map (g ∘′ f) xs} + (sym $ map-∘ xs) + +map-concatMap : (f : B → C) (g : A → List B) → + map f ∘′ concatMap g ≗ concatMap (map f ∘′ g) +map-concatMap f g xs = begin + map f (concatMap g xs) + ≡⟨⟩ + map f (concat (map g xs)) + ≡⟨ concat-map (map g xs) ⟨ + concat (map (map f) (map g xs)) + ≡⟨ cong concat + {x = map (map f) (map g xs)} + {y = map (map f ∘′ g) xs} + (sym $ map-∘ xs) ⟩ + concat (map (map f ∘′ g) xs) + ≡⟨⟩ + concatMap (map f ∘′ g) xs + ∎ + +------------------------------------------------------------------------ +-- sum + +sum-++ : ∀ xs ys → sum (xs ++ ys) ≡ sum xs + sum ys +sum-++ [] ys = refl +sum-++ (x ∷ xs) ys = begin + x + sum (xs ++ ys) ≡⟨ cong (x +_) (sum-++ xs ys) ⟩ + x + (sum xs + sum ys) ≡⟨ sym (+-assoc x _ _) ⟩ + (x + sum xs) + sum ys ∎ + +------------------------------------------------------------------------ +-- product + +∈⇒∣product : ∀ {n ns} → n ∈ ns → n ∣ product ns +∈⇒∣product {n} {n ∷ ns} (here refl) = divides (product ns) (*-comm n (product ns)) +∈⇒∣product {n} {m ∷ ns} (there n∈ns) = ∣n⇒∣m*n m (∈⇒∣product n∈ns) + +------------------------------------------------------------------------ +-- scanr + +scanr-defn : ∀ (f : A → B → B) (e : B) → + scanr f e ≗ map (foldr f e) ∘ tails +scanr-defn f e [] = refl +scanr-defn f e (x ∷ []) = refl +scanr-defn f e (x ∷ y∷xs@(_ ∷ _)) + with eq ← scanr-defn f e y∷xs + with z ∷ zs ← scanr f e y∷xs + = let z≡fy⦇f⦈xs , _ = ∷-injective eq in cong₂ (λ z → f x z ∷_) z≡fy⦇f⦈xs eq + +------------------------------------------------------------------------ +-- scanl + +scanl-defn : ∀ (f : A → B → A) (e : A) → + scanl f e ≗ map (foldl f e) ∘ inits +scanl-defn f e [] = refl +scanl-defn f e (x ∷ xs) = cong (e ∷_) (begin + scanl f (f e x) xs + ≡⟨ scanl-defn f (f e x) xs ⟩ + map (foldl f (f e x)) (inits xs) + ≡⟨ refl ⟩ + map (foldl f e ∘ (x ∷_)) (inits xs) + ≡⟨ map-∘ (inits xs) ⟩ + map (foldl f e) (map (x ∷_) (inits xs)) + ∎) + +------------------------------------------------------------------------ +-- applyUpTo + +length-applyUpTo : ∀ (f : ℕ → A) n → length (applyUpTo f n) ≡ n +length-applyUpTo f zero = refl +length-applyUpTo f (suc n) = cong suc (length-applyUpTo (f ∘ suc) n) + +lookup-applyUpTo : ∀ (f : ℕ → A) n i → lookup (applyUpTo f n) i ≡ f (toℕ i) +lookup-applyUpTo f (suc n) zero = refl +lookup-applyUpTo f (suc n) (suc i) = lookup-applyUpTo (f ∘ suc) n i + +------------------------------------------------------------------------ +-- applyUpTo + +module _ (f : ℕ → A) where + + length-applyDownFrom : ∀ n → length (applyDownFrom f n) ≡ n + length-applyDownFrom zero = refl + length-applyDownFrom (suc n) = cong suc (length-applyDownFrom n) + + lookup-applyDownFrom : ∀ n i → lookup (applyDownFrom f n) i ≡ f (n ∸ (suc (toℕ i))) + lookup-applyDownFrom (suc n) zero = refl + lookup-applyDownFrom (suc n) (suc i) = lookup-applyDownFrom n i + +------------------------------------------------------------------------ +-- upTo + +length-upTo : ∀ n → length (upTo n) ≡ n +length-upTo = length-applyUpTo id + +lookup-upTo : ∀ n i → lookup (upTo n) i ≡ toℕ i +lookup-upTo = lookup-applyUpTo id + +------------------------------------------------------------------------ +-- downFrom + +length-downFrom : ∀ n → length (downFrom n) ≡ n +length-downFrom = length-applyDownFrom id + +lookup-downFrom : ∀ n i → lookup (downFrom n) i ≡ n ∸ (suc (toℕ i)) +lookup-downFrom = lookup-applyDownFrom id + +------------------------------------------------------------------------ +-- tabulate + +tabulate-cong : ∀ {n} {f g : Fin n → A} → + f ≗ g → tabulate f ≡ tabulate g +tabulate-cong {n = zero} p = refl +tabulate-cong {n = suc n} p = cong₂ _∷_ (p zero) (tabulate-cong (p ∘ suc)) + +tabulate-lookup : ∀ (xs : List A) → tabulate (lookup xs) ≡ xs +tabulate-lookup [] = refl +tabulate-lookup (x ∷ xs) = cong (_ ∷_) (tabulate-lookup xs) + +length-tabulate : ∀ {n} → (f : Fin n → A) → + length (tabulate f) ≡ n +length-tabulate {n = zero} f = refl +length-tabulate {n = suc n} f = cong suc (length-tabulate (λ z → f (suc z))) + +lookup-tabulate : ∀ {n} → (f : Fin n → A) → + ∀ i → let i′ = cast (sym (length-tabulate f)) i + in lookup (tabulate f) i′ ≡ f i +lookup-tabulate f zero = refl +lookup-tabulate f (suc i) = lookup-tabulate (f ∘ suc) i + +map-tabulate : ∀ {n} (g : Fin n → A) (f : A → B) → + map f (tabulate g) ≡ tabulate (f ∘ g) +map-tabulate {n = zero} g f = refl +map-tabulate {n = suc n} g f = cong (_ ∷_) (map-tabulate (g ∘ suc) f) + +------------------------------------------------------------------------ +-- _[_]%=_ + +length-%= : ∀ xs k (f : A → A) → length (xs [ k ]%= f) ≡ length xs +length-%= (x ∷ xs) zero f = refl +length-%= (x ∷ xs) (suc k) f = cong suc (length-%= xs k f) + +------------------------------------------------------------------------ +-- _[_]∷=_ + +length-∷= : ∀ xs k (v : A) → length (xs [ k ]∷= v) ≡ length xs +length-∷= xs k v = length-%= xs k (const v) + +map-∷= : ∀ xs k (v : A) (f : A → B) → + let eq = sym (length-map f xs) in + map f (xs [ k ]∷= v) ≡ map f xs [ cast eq k ]∷= f v +map-∷= (x ∷ xs) zero v f = refl +map-∷= (x ∷ xs) (suc k) v f = cong (f x ∷_) (map-∷= xs k v f) + +------------------------------------------------------------------------ +-- insertAt + +length-insertAt : ∀ (xs : List A) (i : Fin (suc (length xs))) v → + length (insertAt xs i v) ≡ suc (length xs) +length-insertAt xs zero v = refl +length-insertAt (x ∷ xs) (suc i) v = cong suc (length-insertAt xs i v) + +------------------------------------------------------------------------ +-- removeAt + +length-removeAt : ∀ (xs : List A) k → length (removeAt xs k) ≡ pred (length xs) +length-removeAt (x ∷ xs) zero = refl +length-removeAt (x ∷ xs@(_ ∷ _)) (suc k) = cong suc (length-removeAt xs k) + +length-removeAt′ : ∀ (xs : List A) k → length xs ≡ suc (length (removeAt xs k)) +length-removeAt′ xs@(_ ∷ _) k rewrite length-removeAt xs k = refl + +map-removeAt : ∀ xs k (f : A → B) → + let eq = sym (length-map f xs) in + map f (removeAt xs k) ≡ removeAt (map f xs) (cast eq k) +map-removeAt (x ∷ xs) zero f = refl +map-removeAt (x ∷ xs) (suc k) f = cong (f x ∷_) (map-removeAt xs k f) + +------------------------------------------------------------------------ + -- insertAt and removeAt + +removeAt-insertAt : ∀ (xs : List A) (i : Fin (suc (length xs))) v → + removeAt (insertAt xs i v) ((cast (sym (length-insertAt xs i v)) i)) ≡ xs +removeAt-insertAt xs zero v = refl +removeAt-insertAt (x ∷ xs) (suc i) v = cong (_ ∷_) (removeAt-insertAt xs i v) + +insertAt-removeAt : (xs : List A) (i : Fin (length xs)) → + insertAt (removeAt xs i) (cast (length-removeAt′ xs i) i) (lookup xs i) ≡ xs +insertAt-removeAt (x ∷ xs) zero = refl +insertAt-removeAt (x ∷ xs) (suc i) = cong (x ∷_) (insertAt-removeAt xs i) + +------------------------------------------------------------------------ +-- take + +length-take : ∀ n (xs : List A) → length (take n xs) ≡ n ⊓ (length xs) +length-take zero xs = refl +length-take (suc n) [] = refl +length-take (suc n) (x ∷ xs) = cong suc (length-take n xs) + +-- Take commutes with map. +take-map : ∀ {f : A → B} (n : ℕ) xs → take n (map f xs) ≡ map f (take n xs) +take-map zero xs = refl +take-map (suc s) [] = refl +take-map (suc s) (a ∷ xs) = cong (_ ∷_) (take-map s xs) + +take-suc : (xs : List A) (i : Fin (length xs)) → let m = toℕ i in + take (suc m) xs ≡ take m xs ∷ʳ lookup xs i +take-suc (x ∷ xs) zero = refl +take-suc (x ∷ xs) (suc i) = cong (x ∷_) (take-suc xs i) + +take-suc-tabulate : ∀ {n} (f : Fin n → A) (i : Fin n) → let m = toℕ i in + take (suc m) (tabulate f) ≡ take m (tabulate f) ∷ʳ f i +take-suc-tabulate f i rewrite sym (toℕ-cast (sym (length-tabulate f)) i) | sym (lookup-tabulate f i) + = take-suc (tabulate f) (cast _ i) + +-- If you take at least as many elements from a list as it has, you get +-- the whole list. +take-all : (n : ℕ) (xs : List A) → n ≥ length xs → take n xs ≡ xs +take-all zero [] _ = refl +take-all (suc _) [] _ = refl +take-all (suc n) (x ∷ xs) (s≤s pf) = cong (x ∷_) (take-all n xs pf) + +-- Taking from an empty list does nothing. +take-[] : ∀ m → take {A = A} m [] ≡ [] +take-[] zero = refl +take-[] (suc m) = refl + +------------------------------------------------------------------------ +-- drop + +length-drop : ∀ n (xs : List A) → length (drop n xs) ≡ length xs ∸ n +length-drop zero xs = refl +length-drop (suc n) [] = refl +length-drop (suc n) (x ∷ xs) = length-drop n xs + +-- Drop commutes with map. +drop-map : ∀ {f : A → B} (n : ℕ) xs → drop n (map f xs) ≡ map f (drop n xs) +drop-map zero xs = refl +drop-map (suc n) [] = refl +drop-map (suc n) (a ∷ xs) = drop-map n xs + +-- Dropping from an empty list does nothing. +drop-[] : ∀ m → drop {A = A} m [] ≡ [] +drop-[] zero = refl +drop-[] (suc m) = refl + +take++drop≡id : ∀ n (xs : List A) → take n xs ++ drop n xs ≡ xs +take++drop≡id zero xs = refl +take++drop≡id (suc n) [] = refl +take++drop≡id (suc n) (x ∷ xs) = cong (x ∷_) (take++drop≡id n xs) + +drop-take-suc : (xs : List A) (i : Fin (length xs)) → let m = toℕ i in + drop m (take (suc m) xs) ≡ [ lookup xs i ] +drop-take-suc (x ∷ xs) zero = refl +drop-take-suc (x ∷ xs) (suc i) = drop-take-suc xs i + +drop-take-suc-tabulate : ∀ {n} (f : Fin n → A) (i : Fin n) → let m = toℕ i in + drop m (take (suc m) (tabulate f)) ≡ [ f i ] +drop-take-suc-tabulate f i rewrite sym (toℕ-cast (sym (length-tabulate f)) i) | sym (lookup-tabulate f i) + = drop-take-suc (tabulate f) (cast _ i) + +-- Dropping m elements and then n elements is same as dropping m+n elements +drop-drop : (m n : ℕ) → (xs : List A) → drop n (drop m xs) ≡ drop (m + n) xs +drop-drop zero n xs = refl +drop-drop (suc m) n [] = drop-[] n +drop-drop (suc m) n (x ∷ xs) = drop-drop m n xs + +drop-all : (n : ℕ) (xs : List A) → n ≥ length xs → drop n xs ≡ [] +drop-all n [] _ = drop-[] n +drop-all (suc n) (x ∷ xs) p = drop-all n xs (s≤s⁻¹ p) + +------------------------------------------------------------------------ +-- replicate + +length-replicate : ∀ n {x : A} → length (replicate n x) ≡ n +length-replicate zero = refl +length-replicate (suc n) = cong suc (length-replicate n) + +lookup-replicate : ∀ n (x : A) (i : Fin n) → + lookup (replicate n x) (cast (sym (length-replicate n)) i) ≡ x +lookup-replicate (suc n) x zero = refl +lookup-replicate (suc n) x (suc i) = lookup-replicate n x i + +map-replicate : ∀ (f : A → B) n (x : A) → + map f (replicate n x) ≡ replicate n (f x) +map-replicate f zero x = refl +map-replicate f (suc n) x = cong (_ ∷_) (map-replicate f n x) + +zipWith-replicate : ∀ n (_⊕_ : A → B → C) (x : A) (y : B) → + zipWith _⊕_ (replicate n x) (replicate n y) ≡ replicate n (x ⊕ y) +zipWith-replicate zero _⊕_ x y = refl +zipWith-replicate (suc n) _⊕_ x y = cong (x ⊕ y ∷_) (zipWith-replicate n _⊕_ x y) + +------------------------------------------------------------------------ +-- iterate + +length-iterate : ∀ f (x : A) n → length (iterate f x n) ≡ n +length-iterate f x zero = refl +length-iterate f x (suc n) = cong suc (length-iterate f (f x) n) + +iterate-id : ∀ (x : A) n → iterate id x n ≡ replicate n x +iterate-id x zero = refl +iterate-id x (suc n) = cong (_ ∷_) (iterate-id x n) + +lookup-iterate : ∀ f (x : A) n (i : Fin n) → + lookup (iterate f x n) (cast (sym (length-iterate f x n)) i) ≡ ℕ.iterate f x (toℕ i) +lookup-iterate f x (suc n) zero = refl +lookup-iterate f x (suc n) (suc i) = lookup-iterate f (f x) n i + +------------------------------------------------------------------------ +-- splitAt + +splitAt-defn : ∀ n → splitAt {A = A} n ≗ < take n , drop n > +splitAt-defn zero xs = refl +splitAt-defn (suc n) [] = refl +splitAt-defn (suc n) (x ∷ xs) = cong (Prod.map (x ∷_) id) (splitAt-defn n xs) + +------------------------------------------------------------------------ +-- takeWhile, dropWhile, and span + +module _ {P : Pred A p} (P? : Decidable P) where + + takeWhile++dropWhile : ∀ xs → takeWhile P? xs ++ dropWhile P? xs ≡ xs + takeWhile++dropWhile [] = refl + takeWhile++dropWhile (x ∷ xs) with does (P? x) + ... | true = cong (x ∷_) (takeWhile++dropWhile xs) + ... | false = refl + + span-defn : span P? ≗ < takeWhile P? , dropWhile P? > + span-defn [] = refl + span-defn (x ∷ xs) with does (P? x) + ... | true = cong (Prod.map (x ∷_) id) (span-defn xs) + ... | false = refl + +------------------------------------------------------------------------ +-- filter + +module _ {P : Pred A p} (P? : Decidable P) where + + length-filter : ∀ xs → length (filter P? xs) ≤ length xs + length-filter [] = z≤n + length-filter (x ∷ xs) with ih ← length-filter xs | does (P? x) + ... | false = m≤n⇒m≤1+n ih + ... | true = s≤s ih + + filter-all : ∀ {xs} → All P xs → filter P? xs ≡ xs + filter-all {[]} [] = refl + filter-all {x ∷ xs} (px ∷ pxs) with P? x + ... | no ¬px = contradiction px ¬px + ... | true because _ = cong (x ∷_) (filter-all pxs) + + filter-notAll : ∀ xs → Any (∁ P) xs → length (filter P? xs) < length xs + filter-notAll (x ∷ xs) (here ¬px) with P? x + ... | false because _ = s≤s (length-filter xs) + ... | yes px = contradiction px ¬px + filter-notAll (x ∷ xs) (there any) with ih ← filter-notAll xs any | does (P? x) + ... | false = m≤n⇒m≤1+n ih + ... | true = s≤s ih + + filter-some : ∀ {xs} → Any P xs → 0 < length (filter P? xs) + filter-some {x ∷ xs} (here px) with P? x + ... | true because _ = z<s + ... | no ¬px = contradiction px ¬px + filter-some {x ∷ xs} (there pxs) with does (P? x) + ... | true = m≤n⇒m≤1+n (filter-some pxs) + ... | false = filter-some pxs + + filter-none : ∀ {xs} → All (∁ P) xs → filter P? xs ≡ [] + filter-none {[]} [] = refl + filter-none {x ∷ xs} (¬px ∷ ¬pxs) with P? x + ... | false because _ = filter-none ¬pxs + ... | yes px = contradiction px ¬px + + filter-complete : ∀ {xs} → length (filter P? xs) ≡ length xs → + filter P? xs ≡ xs + filter-complete {[]} eq = refl + filter-complete {x ∷ xs} eq with does (P? x) + ... | false = contradiction eq (<⇒≢ (s≤s (length-filter xs))) + ... | true = cong (x ∷_) (filter-complete (suc-injective eq)) + + filter-accept : ∀ {x xs} → P x → filter P? (x ∷ xs) ≡ x ∷ (filter P? xs) + filter-accept {x} Px with P? x + ... | true because _ = refl + ... | no ¬Px = contradiction Px ¬Px + + filter-reject : ∀ {x xs} → ¬ P x → filter P? (x ∷ xs) ≡ filter P? xs + filter-reject {x} ¬Px with P? x + ... | yes Px = contradiction Px ¬Px + ... | false because _ = refl + + filter-idem : filter P? ∘ filter P? ≗ filter P? + filter-idem [] = refl + filter-idem (x ∷ xs) with does (P? x) in eq + ... | false = filter-idem xs + ... | true rewrite eq = cong (x ∷_) (filter-idem xs) + + filter-++ : ∀ xs ys → filter P? (xs ++ ys) ≡ filter P? xs ++ filter P? ys + filter-++ [] ys = refl + filter-++ (x ∷ xs) ys with ih ← filter-++ xs ys | does (P? x) + ... | true = cong (x ∷_) ih + ... | false = ih + +------------------------------------------------------------------------ +-- derun and deduplicate + +module _ {R : Rel A p} (R? : B.Decidable R) where + + length-derun : ∀ xs → length (derun R? xs) ≤ length xs + length-derun [] = ≤-refl + length-derun (x ∷ []) = ≤-refl + length-derun (x ∷ y ∷ xs) with ih ← length-derun (y ∷ xs) | does (R? x y) + ... | true = m≤n⇒m≤1+n ih + ... | false = s≤s ih + + length-deduplicate : ∀ xs → length (deduplicate R? xs) ≤ length xs + length-deduplicate [] = z≤n + length-deduplicate (x ∷ xs) = ≤-begin + 1 + length (filter (¬? ∘ R? x) r) ≤⟨ s≤s (length-filter (¬? ∘ R? x) r) ⟩ + 1 + length r ≤⟨ s≤s (length-deduplicate xs) ⟩ + 1 + length xs ≤-∎ + where + open ≤-Reasoning renaming (begin_ to ≤-begin_; _∎ to _≤-∎) + r = deduplicate R? xs + + derun-reject : ∀ {x y} xs → R x y → derun R? (x ∷ y ∷ xs) ≡ derun R? (y ∷ xs) + derun-reject {x} {y} xs Rxy with R? x y + ... | yes _ = refl + ... | no ¬Rxy = contradiction Rxy ¬Rxy + + derun-accept : ∀ {x y} xs → ¬ R x y → derun R? (x ∷ y ∷ xs) ≡ x ∷ derun R? (y ∷ xs) + derun-accept {x} {y} xs ¬Rxy with R? x y + ... | yes Rxy = contradiction Rxy ¬Rxy + ... | no _ = refl + +------------------------------------------------------------------------ +-- partition + +module _ {P : Pred A p} (P? : Decidable P) where + + partition-defn : partition P? ≗ < filter P? , filter (∁? P?) > + partition-defn [] = refl + partition-defn (x ∷ xs) with ih ← partition-defn xs | does (P? x) + ... | true = cong (Prod.map (x ∷_) id) ih + ... | false = cong (Prod.map id (x ∷_)) ih + + length-partition : ∀ xs → (let (ys , zs) = partition P? xs) → + length ys ≤ length xs × length zs ≤ length xs + length-partition [] = z≤n , z≤n + length-partition (x ∷ xs) with ih ← length-partition xs | does (P? x) + ... | true = Prod.map s≤s m≤n⇒m≤1+n ih + ... | false = Prod.map m≤n⇒m≤1+n s≤s ih + +------------------------------------------------------------------------ +-- _ʳ++_ + +ʳ++-defn : ∀ (xs : List A) {ys} → xs ʳ++ ys ≡ reverse xs ++ ys +ʳ++-defn [] = refl +ʳ++-defn (x ∷ xs) {ys} = begin + (x ∷ xs) ʳ++ ys ≡⟨⟩ + xs ʳ++ x ∷ ys ≡⟨⟩ + xs ʳ++ [ x ] ++ ys ≡⟨ ʳ++-defn xs ⟩ + reverse xs ++ [ x ] ++ ys ≡⟨ sym (++-assoc (reverse xs) _ _) ⟩ + (reverse xs ++ [ x ]) ++ ys ≡⟨ cong (_++ ys) (sym (ʳ++-defn xs)) ⟩ + (xs ʳ++ [ x ]) ++ ys ≡⟨⟩ + reverse (x ∷ xs) ++ ys ∎ + +-- Reverse-append of append is reverse-append after reverse-append. + +++-ʳ++ : ∀ (xs {ys zs} : List A) → (xs ++ ys) ʳ++ zs ≡ ys ʳ++ xs ʳ++ zs +++-ʳ++ [] = refl +++-ʳ++ (x ∷ xs) {ys} {zs} = begin + (x ∷ xs ++ ys) ʳ++ zs ≡⟨⟩ + (xs ++ ys) ʳ++ x ∷ zs ≡⟨ ++-ʳ++ xs ⟩ + ys ʳ++ xs ʳ++ x ∷ zs ≡⟨⟩ + ys ʳ++ (x ∷ xs) ʳ++ zs ∎ + +-- Reverse-append of reverse-append is commuted reverse-append after append. + +ʳ++-ʳ++ : ∀ (xs {ys zs} : List A) → (xs ʳ++ ys) ʳ++ zs ≡ ys ʳ++ xs ++ zs +ʳ++-ʳ++ [] = refl +ʳ++-ʳ++ (x ∷ xs) {ys} {zs} = begin + ((x ∷ xs) ʳ++ ys) ʳ++ zs ≡⟨⟩ + (xs ʳ++ x ∷ ys) ʳ++ zs ≡⟨ ʳ++-ʳ++ xs ⟩ + (x ∷ ys) ʳ++ xs ++ zs ≡⟨⟩ + ys ʳ++ (x ∷ xs) ++ zs ∎ + +-- Length of reverse-append + +length-ʳ++ : ∀ (xs {ys} : List A) → + length (xs ʳ++ ys) ≡ length xs + length ys +length-ʳ++ [] = refl +length-ʳ++ (x ∷ xs) {ys} = begin + length ((x ∷ xs) ʳ++ ys) ≡⟨⟩ + length (xs ʳ++ x ∷ ys) ≡⟨ length-ʳ++ xs ⟩ + length xs + length (x ∷ ys) ≡⟨ +-suc _ _ ⟩ + length (x ∷ xs) + length ys ∎ + +-- map distributes over reverse-append. + +map-ʳ++ : (f : A → B) (xs {ys} : List A) → + map f (xs ʳ++ ys) ≡ map f xs ʳ++ map f ys +map-ʳ++ f [] = refl +map-ʳ++ f (x ∷ xs) {ys} = begin + map f ((x ∷ xs) ʳ++ ys) ≡⟨⟩ + map f (xs ʳ++ x ∷ ys) ≡⟨ map-ʳ++ f xs ⟩ + map f xs ʳ++ map f (x ∷ ys) ≡⟨⟩ + map f xs ʳ++ f x ∷ map f ys ≡⟨⟩ + (f x ∷ map f xs) ʳ++ map f ys ≡⟨⟩ + map f (x ∷ xs) ʳ++ map f ys ∎ + +-- A foldr after a reverse is a foldl. + +foldr-ʳ++ : ∀ (f : A → B → B) b xs {ys} → + foldr f b (xs ʳ++ ys) ≡ foldl (flip f) (foldr f b ys) xs +foldr-ʳ++ f b [] {_} = refl +foldr-ʳ++ f b (x ∷ xs) {ys} = begin + foldr f b ((x ∷ xs) ʳ++ ys) ≡⟨⟩ + foldr f b (xs ʳ++ x ∷ ys) ≡⟨ foldr-ʳ++ f b xs ⟩ + foldl (flip f) (foldr f b (x ∷ ys)) xs ≡⟨⟩ + foldl (flip f) (f x (foldr f b ys)) xs ≡⟨⟩ + foldl (flip f) (foldr f b ys) (x ∷ xs) ∎ + +-- A foldl after a reverse is a foldr. + +foldl-ʳ++ : ∀ (f : B → A → B) b xs {ys} → + foldl f b (xs ʳ++ ys) ≡ foldl f (foldr (flip f) b xs) ys +foldl-ʳ++ f b [] {_} = refl +foldl-ʳ++ f b (x ∷ xs) {ys} = begin + foldl f b ((x ∷ xs) ʳ++ ys) ≡⟨⟩ + foldl f b (xs ʳ++ x ∷ ys) ≡⟨ foldl-ʳ++ f b xs ⟩ + foldl f (foldr (flip f) b xs) (x ∷ ys) ≡⟨⟩ + foldl f (f (foldr (flip f) b xs) x) ys ≡⟨⟩ + foldl f (foldr (flip f) b (x ∷ xs)) ys ∎ + +------------------------------------------------------------------------ +-- reverse + +-- reverse of cons is snoc of reverse. + +unfold-reverse : ∀ (x : A) xs → reverse (x ∷ xs) ≡ reverse xs ∷ʳ x +unfold-reverse x xs = ʳ++-defn xs + +-- reverse is an involution with respect to append. + +reverse-++ : (xs ys : List A) → + reverse (xs ++ ys) ≡ reverse ys ++ reverse xs +reverse-++ xs ys = begin + reverse (xs ++ ys) ≡⟨⟩ + (xs ++ ys) ʳ++ [] ≡⟨ ++-ʳ++ xs ⟩ + ys ʳ++ xs ʳ++ [] ≡⟨⟩ + ys ʳ++ reverse xs ≡⟨ ʳ++-defn ys ⟩ + reverse ys ++ reverse xs ∎ + +-- reverse is involutive. + +reverse-involutive : Involutive {A = List A} _≡_ reverse +reverse-involutive xs = begin + reverse (reverse xs) ≡⟨⟩ + (xs ʳ++ []) ʳ++ [] ≡⟨ ʳ++-ʳ++ xs ⟩ + [] ʳ++ xs ++ [] ≡⟨⟩ + xs ++ [] ≡⟨ ++-identityʳ xs ⟩ + xs ∎ + +-- reverse is injective. + +reverse-injective : ∀ {xs ys : List A} → reverse xs ≡ reverse ys → xs ≡ ys +reverse-injective = subst₂ _≡_ (reverse-involutive _) (reverse-involutive _) ∘ cong reverse + +-- reverse preserves length. + +length-reverse : ∀ (xs : List A) → length (reverse xs) ≡ length xs +length-reverse xs = begin + length (reverse xs) ≡⟨⟩ + length (xs ʳ++ []) ≡⟨ length-ʳ++ xs ⟩ + length xs + 0 ≡⟨ +-identityʳ _ ⟩ + length xs ∎ + +reverse-map : (f : A → B) → map f ∘ reverse ≗ reverse ∘ map f +reverse-map f xs = begin + map f (reverse xs) ≡⟨⟩ + map f (xs ʳ++ []) ≡⟨ map-ʳ++ f xs ⟩ + map f xs ʳ++ [] ≡⟨⟩ + reverse (map f xs) ∎ + +reverse-foldr : ∀ (f : A → B → B) b → + foldr f b ∘ reverse ≗ foldl (flip f) b +reverse-foldr f b xs = foldr-ʳ++ f b xs + +reverse-foldl : ∀ (f : B → A → B) b xs → + foldl f b (reverse xs) ≡ foldr (flip f) b xs +reverse-foldl f b xs = foldl-ʳ++ f b xs + +------------------------------------------------------------------------ +-- _∷ʳ_ + +module _ {x y : A} where + + ∷ʳ-injective : ∀ xs ys → xs ∷ʳ x ≡ ys ∷ʳ y → xs ≡ ys × x ≡ y + ∷ʳ-injective [] [] refl = (refl , refl) + ∷ʳ-injective (x ∷ xs) (y ∷ ys) eq with refl , eq′ ← ∷-injective eq + = Prod.map (cong (x ∷_)) id (∷ʳ-injective xs ys eq′) + ∷ʳ-injective [] (_ ∷ _ ∷ _) () + ∷ʳ-injective (_ ∷ _ ∷ _) [] () + + ∷ʳ-injectiveˡ : ∀ (xs ys : List A) → xs ∷ʳ x ≡ ys ∷ʳ y → xs ≡ ys + ∷ʳ-injectiveˡ xs ys eq = proj₁ (∷ʳ-injective xs ys eq) + + ∷ʳ-injectiveʳ : ∀ (xs ys : List A) → xs ∷ʳ x ≡ ys ∷ʳ y → x ≡ y + ∷ʳ-injectiveʳ xs ys eq = proj₂ (∷ʳ-injective xs ys eq) + +∷ʳ-++ : ∀ (xs : List A) (a : A) (ys : List A) → xs ∷ʳ a ++ ys ≡ xs ++ a ∷ ys +∷ʳ-++ xs a ys = ++-assoc xs [ a ] ys + + + +------------------------------------------------------------------------ +-- head + +-- 'commute' List.head and List.map to obtain a Maybe.map and List.head. +head-map : ∀ {f : A → B} xs → head (map f xs) ≡ Maybe.map f (head xs) +head-map [] = refl +head-map (_ ∷ _) = refl + + + + +------------------------------------------------------------------------ +-- DEPRECATED +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 2.0 + +map-id₂ = map-id-local +{-# WARNING_ON_USAGE map-id₂ +"Warning: map-id₂ was deprecated in v2.0. Please use map-id-local instead." -#-} +#-} -map-cong₂ = map-cong-local -{-# WARNING_ON_USAGE map-id₂ -"Warning: map-cong₂ was deprecated in v2.0. +map-cong₂ = map-cong-local +{-# WARNING_ON_USAGE map-id₂ +"Warning: map-cong₂ was deprecated in v2.0. Please use map-cong-local instead." -#-} +#-} -map-compose = map-∘ -{-# WARNING_ON_USAGE map-compose -"Warning: map-compose was deprecated in v2.0. +map-compose = map-∘ +{-# WARNING_ON_USAGE map-compose +"Warning: map-compose was deprecated in v2.0. Please use map-∘ instead." -#-} +#-} -map-++-commute = map-++ -{-# WARNING_ON_USAGE map-++-commute -"Warning: map-++-commute was deprecated in v2.0. +map-++-commute = map-++ +{-# WARNING_ON_USAGE map-++-commute +"Warning: map-++-commute was deprecated in v2.0. Please use map-++ instead." -#-} +#-} -sum-++-commute = sum-++ -{-# WARNING_ON_USAGE sum-++-commute -"Warning: map-++-commute was deprecated in v2.0. +sum-++-commute = sum-++ +{-# WARNING_ON_USAGE sum-++-commute +"Warning: map-++-commute was deprecated in v2.0. Please use map-++ instead." -#-} +#-} -reverse-map-commute = reverse-map -{-# WARNING_ON_USAGE reverse-map-commute -"Warning: reverse-map-commute was deprecated in v2.0. +reverse-map-commute = reverse-map +{-# WARNING_ON_USAGE reverse-map-commute +"Warning: reverse-map-commute was deprecated in v2.0. Please use reverse-map instead." -#-} +#-} -reverse-++-commute = reverse-++ -{-# WARNING_ON_USAGE reverse-++-commute -"Warning: reverse-++-commute was deprecated in v2.0. +reverse-++-commute = reverse-++ +{-# WARNING_ON_USAGE reverse-++-commute +"Warning: reverse-++-commute was deprecated in v2.0. Please use reverse-++ instead." -#-} +#-} -zipWith-identityˡ = zipWith-zeroˡ -{-# WARNING_ON_USAGE zipWith-identityˡ -"Warning: zipWith-identityˡ was deprecated in v2.0. +zipWith-identityˡ = zipWith-zeroˡ +{-# WARNING_ON_USAGE zipWith-identityˡ +"Warning: zipWith-identityˡ was deprecated in v2.0. Please use zipWith-zeroˡ instead." -#-} +#-} -zipWith-identityʳ = zipWith-zeroʳ -{-# WARNING_ON_USAGE zipWith-identityʳ -"Warning: zipWith-identityʳ was deprecated in v2.0. +zipWith-identityʳ = zipWith-zeroʳ +{-# WARNING_ON_USAGE zipWith-identityʳ +"Warning: zipWith-identityʳ was deprecated in v2.0. Please use zipWith-zeroʳ instead." -#-} +#-} + +ʳ++-++ = ++-ʳ++ +{-# WARNING_ON_USAGE ʳ++-++ +"Warning: ʳ++-++ was deprecated in v2.0. +Please use ++-ʳ++ instead." +#-} + +take++drop = take++drop≡id +{-# WARNING_ON_USAGE take++drop +"Warning: take++drop was deprecated in v2.0. +Please use take++drop≡id instead." +#-} + +length-─ = length-removeAt +{-# WARNING_ON_USAGE length-─ +"Warning: length-─ was deprecated in v2.0. +Please use length-removeAt instead." +#-} + +map-─ = map-removeAt +{-# WARNING_ON_USAGE map-─ +"Warning: map-─ was deprecated in v2.0. +Please use map-removeAt instead." +#-} \ No newline at end of file diff --git a/Data.List.Relation.Binary.Equality.Propositional.html b/Data.List.Relation.Binary.Equality.Propositional.html index bd69d1df..8f8a0ebf 100644 --- a/Data.List.Relation.Binary.Equality.Propositional.html +++ b/Data.List.Relation.Binary.Equality.Propositional.html @@ -11,26 +11,27 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary +open import Relation.Binary.Core using (_⇒_) -module Data.List.Relation.Binary.Equality.Propositional {a} {A : Set a} where +module Data.List.Relation.Binary.Equality.Propositional {a} {A : Set a} where -open import Data.List.Base -import Data.List.Relation.Binary.Equality.Setoid as SetoidEquality -open import Relation.Binary.PropositionalEquality as P using (_≡_) +open import Data.List.Base +import Data.List.Relation.Binary.Equality.Setoid as SetoidEquality +open import Relation.Binary.PropositionalEquality.Core as P using (_≡_) +import Relation.Binary.PropositionalEquality.Properties as P ------------------------------------------------------------------------- --- Re-export everything from setoid equality +------------------------------------------------------------------------ +-- Re-export everything from setoid equality -open SetoidEquality (P.setoid A) public +open SetoidEquality (P.setoid A) public ------------------------------------------------------------------------- --- ≋ is propositional +------------------------------------------------------------------------ +-- ≋ is propositional -≋⇒≡ : _≋_ ⇒ _≡_ -≋⇒≡ [] = P.refl -≋⇒≡ (P.refl ∷ xs≈ys) = P.cong (_ ∷_) (≋⇒≡ xs≈ys) +≋⇒≡ : _≋_ ⇒ _≡_ +≋⇒≡ [] = P.refl +≋⇒≡ (P.refl ∷ xs≈ys) = P.cong (_ ∷_) (≋⇒≡ xs≈ys) -≡⇒≋ : _≡_ ⇒ _≋_ -≡⇒≋ P.refl = ≋-refl +≡⇒≋ : _≡_ ⇒ _≋_ +≡⇒≋ P.refl = ≋-refl \ No newline at end of file diff --git a/Data.List.Relation.Binary.Equality.Setoid.html b/Data.List.Relation.Binary.Equality.Setoid.html index 65ce65c1..f06a9e74 100644 --- a/Data.List.Relation.Binary.Equality.Setoid.html +++ b/Data.List.Relation.Binary.Equality.Setoid.html @@ -8,152 +8,154 @@ {-# OPTIONS --cubical-compatible --safe #-} open import Algebra.Core using (Op₂) -open import Relation.Binary using (Setoid) +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Binary.Definitions using (Transitive; Symmetric; Reflexive; _Respects_) +open import Relation.Binary.Structures using (IsEquivalence) -module Data.List.Relation.Binary.Equality.Setoid {a ℓ} (S : Setoid a ℓ) where +module Data.List.Relation.Binary.Equality.Setoid {a ℓ} (S : Setoid a ℓ) where -open import Data.Fin.Base using (Fin) -open import Data.List.Base -open import Data.List.Relation.Binary.Pointwise as PW using (Pointwise) -open import Data.List.Relation.Unary.Unique.Setoid S using (Unique) -open import Function.Base using (_∘_) -open import Level -open import Relation.Binary renaming (Rel to Rel₂) -open import Relation.Binary.PropositionalEquality as P using (_≡_) -open import Relation.Binary.Properties.Setoid S using (≉-resp₂) -open import Relation.Unary as U using (Pred) +open import Data.Fin.Base using (Fin) +open import Data.List.Base +open import Data.List.Relation.Binary.Pointwise as PW using (Pointwise) +open import Data.List.Relation.Unary.Unique.Setoid S using (Unique) +open import Function.Base using (_∘_) +open import Level +open import Relation.Binary.Core renaming (Rel to Rel₂) +open import Relation.Binary.PropositionalEquality as P using (_≡_) +open import Relation.Binary.Properties.Setoid S using (≉-resp₂) +open import Relation.Unary as U using (Pred) -open Setoid S renaming (Carrier to A) +open Setoid S renaming (Carrier to A) -private - variable - p q : Level +private + variable + p q : Level ------------------------------------------------------------------------- --- Definition of equality ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Definition of equality +------------------------------------------------------------------------ -infix 4 _≋_ +infix 4 _≋_ -_≋_ : Rel₂ (List A) (a ⊔ ℓ) -_≋_ = Pointwise _≈_ +_≋_ : Rel₂ (List A) (a ⊔ ℓ) +_≋_ = Pointwise _≈_ -open PW public - using ([]; _∷_) +open PW public + using ([]; _∷_) ------------------------------------------------------------------------- --- Relational properties ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Relational properties +------------------------------------------------------------------------ -≋-refl : Reflexive _≋_ -≋-refl = PW.refl refl +≋-refl : Reflexive _≋_ +≋-refl = PW.refl refl -≋-reflexive : _≡_ ⇒ _≋_ -≋-reflexive P.refl = ≋-refl +≋-reflexive : _≡_ ⇒ _≋_ +≋-reflexive P.refl = ≋-refl -≋-sym : Symmetric _≋_ -≋-sym = PW.symmetric sym +≋-sym : Symmetric _≋_ +≋-sym = PW.symmetric sym -≋-trans : Transitive _≋_ -≋-trans = PW.transitive trans +≋-trans : Transitive _≋_ +≋-trans = PW.transitive trans -≋-isEquivalence : IsEquivalence _≋_ -≋-isEquivalence = PW.isEquivalence isEquivalence +≋-isEquivalence : IsEquivalence _≋_ +≋-isEquivalence = PW.isEquivalence isEquivalence -≋-setoid : Setoid _ _ -≋-setoid = PW.setoid S +≋-setoid : Setoid _ _ +≋-setoid = PW.setoid S ------------------------------------------------------------------------- --- Relationships to predicates ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Relationships to predicates +------------------------------------------------------------------------ -open PW public - using () renaming - ( Any-resp-Pointwise to Any-resp-≋ - ; All-resp-Pointwise to All-resp-≋ - ; AllPairs-resp-Pointwise to AllPairs-resp-≋ - ) +open PW public + using () renaming + ( Any-resp-Pointwise to Any-resp-≋ + ; All-resp-Pointwise to All-resp-≋ + ; AllPairs-resp-Pointwise to AllPairs-resp-≋ + ) -Unique-resp-≋ : Unique Respects _≋_ -Unique-resp-≋ = AllPairs-resp-≋ ≉-resp₂ +Unique-resp-≋ : Unique Respects _≋_ +Unique-resp-≋ = AllPairs-resp-≋ ≉-resp₂ ------------------------------------------------------------------------- --- List operations ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- List operations +------------------------------------------------------------------------ ------------------------------------------------------------------------- --- length +------------------------------------------------------------------------ +-- length -≋-length : ∀ {xs ys} → xs ≋ ys → length xs ≡ length ys -≋-length = PW.Pointwise-length +≋-length : ∀ {xs ys} → xs ≋ ys → length xs ≡ length ys +≋-length = PW.Pointwise-length ------------------------------------------------------------------------- --- map +------------------------------------------------------------------------ +-- map -module _ {b ℓ₂} (T : Setoid b ℓ₂) where +module _ {b ℓ₂} (T : Setoid b ℓ₂) where - open Setoid T using () renaming (_≈_ to _≈′_) - private - _≋′_ = Pointwise _≈′_ + open Setoid T using () renaming (_≈_ to _≈′_) + private + _≋′_ = Pointwise _≈′_ - map⁺ : ∀ {f} → f Preserves _≈_ ⟶ _≈′_ → - ∀ {xs ys} → xs ≋ ys → map f xs ≋′ map f ys - map⁺ {f} pres xs≋ys = PW.map⁺ f f (PW.map pres xs≋ys) + map⁺ : ∀ {f} → f Preserves _≈_ ⟶ _≈′_ → + ∀ {xs ys} → xs ≋ ys → map f xs ≋′ map f ys + map⁺ {f} pres xs≋ys = PW.map⁺ f f (PW.map pres xs≋ys) ------------------------------------------------------------------------- --- foldr +------------------------------------------------------------------------ +-- foldr -foldr⁺ : ∀ {_•_ : Op₂ A} {_◦_ : Op₂ A} → - (∀ {w x y z} → w ≈ x → y ≈ z → (w • y) ≈ (x ◦ z)) → - ∀ {xs ys e f} → e ≈ f → xs ≋ ys → - foldr _•_ e xs ≈ foldr _◦_ f ys -foldr⁺ ∙⇔◦ e≈f xs≋ys = PW.foldr⁺ ∙⇔◦ e≈f xs≋ys +foldr⁺ : ∀ {_•_ : Op₂ A} {_◦_ : Op₂ A} → + (∀ {w x y z} → w ≈ x → y ≈ z → (w • y) ≈ (x ◦ z)) → + ∀ {xs ys e f} → e ≈ f → xs ≋ ys → + foldr _•_ e xs ≈ foldr _◦_ f ys +foldr⁺ ∙⇔◦ e≈f xs≋ys = PW.foldr⁺ ∙⇔◦ e≈f xs≋ys ------------------------------------------------------------------------- --- _++_ +------------------------------------------------------------------------ +-- _++_ -++⁺ : ∀ {ws xs ys zs} → ws ≋ xs → ys ≋ zs → ws ++ ys ≋ xs ++ zs -++⁺ = PW.++⁺ +++⁺ : ∀ {ws xs ys zs} → ws ≋ xs → ys ≋ zs → ws ++ ys ≋ xs ++ zs +++⁺ = PW.++⁺ -++-cancelˡ : ∀ xs {ys zs} → xs ++ ys ≋ xs ++ zs → ys ≋ zs -++-cancelˡ xs = PW.++-cancelˡ xs +++-cancelˡ : ∀ xs {ys zs} → xs ++ ys ≋ xs ++ zs → ys ≋ zs +++-cancelˡ xs = PW.++-cancelˡ xs -++-cancelʳ : ∀ {xs} ys zs → ys ++ xs ≋ zs ++ xs → ys ≋ zs -++-cancelʳ = PW.++-cancelʳ +++-cancelʳ : ∀ {xs} ys zs → ys ++ xs ≋ zs ++ xs → ys ≋ zs +++-cancelʳ = PW.++-cancelʳ ------------------------------------------------------------------------- --- concat +------------------------------------------------------------------------ +-- concat -concat⁺ : ∀ {xss yss} → Pointwise _≋_ xss yss → concat xss ≋ concat yss -concat⁺ = PW.concat⁺ +concat⁺ : ∀ {xss yss} → Pointwise _≋_ xss yss → concat xss ≋ concat yss +concat⁺ = PW.concat⁺ ------------------------------------------------------------------------- --- tabulate +------------------------------------------------------------------------ +-- tabulate -module _ {n} {f g : Fin n → A} - where +module _ {n} {f g : Fin n → A} + where - tabulate⁺ : (∀ i → f i ≈ g i) → tabulate f ≋ tabulate g - tabulate⁺ = PW.tabulate⁺ + tabulate⁺ : (∀ i → f i ≈ g i) → tabulate f ≋ tabulate g + tabulate⁺ = PW.tabulate⁺ - tabulate⁻ : tabulate f ≋ tabulate g → (∀ i → f i ≈ g i) - tabulate⁻ = PW.tabulate⁻ + tabulate⁻ : tabulate f ≋ tabulate g → (∀ i → f i ≈ g i) + tabulate⁻ = PW.tabulate⁻ ------------------------------------------------------------------------- --- filter +------------------------------------------------------------------------ +-- filter -module _ {P : Pred A p} (P? : U.Decidable P) (resp : P Respects _≈_) - where +module _ {P : Pred A p} (P? : U.Decidable P) (resp : P Respects _≈_) + where - filter⁺ : ∀ {xs ys} → xs ≋ ys → filter P? xs ≋ filter P? ys - filter⁺ xs≋ys = PW.filter⁺ P? P? resp (resp ∘ sym) xs≋ys + filter⁺ : ∀ {xs ys} → xs ≋ ys → filter P? xs ≋ filter P? ys + filter⁺ xs≋ys = PW.filter⁺ P? P? resp (resp ∘ sym) xs≋ys ------------------------------------------------------------------------- --- reverse +------------------------------------------------------------------------ +-- reverse -ʳ++⁺ : ∀{xs xs′ ys ys′} → xs ≋ xs′ → ys ≋ ys′ → xs ʳ++ ys ≋ xs′ ʳ++ ys′ -ʳ++⁺ = PW.ʳ++⁺ +ʳ++⁺ : ∀{xs xs′ ys ys′} → xs ≋ xs′ → ys ≋ ys′ → xs ʳ++ ys ≋ xs′ ʳ++ ys′ +ʳ++⁺ = PW.ʳ++⁺ -reverse⁺ : ∀ {xs ys} → xs ≋ ys → reverse xs ≋ reverse ys -reverse⁺ = PW.reverse⁺ +reverse⁺ : ∀ {xs ys} → xs ≋ ys → reverse xs ≋ reverse ys +reverse⁺ = PW.reverse⁺ \ No newline at end of file diff --git a/Data.List.Relation.Binary.Lex.Core.html b/Data.List.Relation.Binary.Lex.Core.html index fdac70e2..5f7c8d76 100644 --- a/Data.List.Relation.Binary.Lex.Core.html +++ b/Data.List.Relation.Binary.Lex.Core.html @@ -11,39 +11,39 @@ open import Data.Empty using (⊥; ⊥-elim) open import Data.Unit.Base using (⊤; tt) -open import Data.Product using (_×_; _,_; proj₁; proj₂; uncurry) -open import Data.List.Base using (List; []; _∷_) -open import Function.Base using (_∘_; flip; id) -open import Level using (Level; _⊔_) -open import Relation.Nullary.Negation using (¬_) -open import Relation.Binary.Core using (Rel) -open import Data.List.Relation.Binary.Pointwise.Base - using (Pointwise; []; _∷_; head; tail) - -private - variable - a ℓ₁ ℓ₂ : Level - --- The lexicographic ordering itself can be either strict or non-strict, --- depending on whether type P is inhabited. - -data Lex {A : Set a} (P : Set) - (_≈_ : Rel A ℓ₁) (_≺_ : Rel A ℓ₂) : - Rel (List A) (a ⊔ ℓ₁ ⊔ ℓ₂) where - base : P → Lex P _≈_ _≺_ [] [] - halt : ∀ {y ys} → Lex P _≈_ _≺_ [] (y ∷ ys) - this : ∀ {x xs y ys} (x≺y : x ≺ y) → Lex P _≈_ _≺_ (x ∷ xs) (y ∷ ys) - next : ∀ {x xs y ys} (x≈y : x ≈ y) - (xs<ys : Lex P _≈_ _≺_ xs ys) → Lex P _≈_ _≺_ (x ∷ xs) (y ∷ ys) - ----------------------------------------------------------------------- --- Lexicographic orderings, using a strict ordering as the base - -Lex-< : {A : Set a} (_≈_ : Rel A ℓ₁) (_≺_ : Rel A ℓ₂) → - Rel (List A) (a ⊔ ℓ₁ ⊔ ℓ₂) -Lex-< = Lex ⊥ - -Lex-≤ : {A : Set a} (_≈_ : Rel A ℓ₁) (_≺_ : Rel A ℓ₂) → - Rel (List A) (a ⊔ ℓ₁ ⊔ ℓ₂) -Lex-≤ = Lex ⊤ +open import Data.Product.Base using (_×_; _,_; proj₁; proj₂; uncurry) +open import Data.List.Base using (List; []; _∷_) +open import Function.Base using (_∘_; flip; id) +open import Level using (Level; _⊔_) +open import Relation.Nullary.Negation using (¬_) +open import Relation.Binary.Core using (Rel) +open import Data.List.Relation.Binary.Pointwise.Base + using (Pointwise; []; _∷_; head; tail) + +private + variable + a ℓ₁ ℓ₂ : Level + +-- The lexicographic ordering itself can be either strict or non-strict, +-- depending on whether type P is inhabited. + +data Lex {A : Set a} (P : Set) + (_≈_ : Rel A ℓ₁) (_≺_ : Rel A ℓ₂) : + Rel (List A) (a ⊔ ℓ₁ ⊔ ℓ₂) where + base : P → Lex P _≈_ _≺_ [] [] + halt : ∀ {y ys} → Lex P _≈_ _≺_ [] (y ∷ ys) + this : ∀ {x xs y ys} (x≺y : x ≺ y) → Lex P _≈_ _≺_ (x ∷ xs) (y ∷ ys) + next : ∀ {x xs y ys} (x≈y : x ≈ y) + (xs<ys : Lex P _≈_ _≺_ xs ys) → Lex P _≈_ _≺_ (x ∷ xs) (y ∷ ys) + +------------------------------------------------------------------------ +-- Lexicographic orderings, using a strict ordering as the base + +Lex-< : {A : Set a} (_≈_ : Rel A ℓ₁) (_≺_ : Rel A ℓ₂) → + Rel (List A) (a ⊔ ℓ₁ ⊔ ℓ₂) +Lex-< = Lex ⊥ + +Lex-≤ : {A : Set a} (_≈_ : Rel A ℓ₁) (_≺_ : Rel A ℓ₂) → + Rel (List A) (a ⊔ ℓ₁ ⊔ ℓ₂) +Lex-≤ = Lex ⊤ \ No newline at end of file diff --git a/Data.List.Relation.Binary.Lex.Strict.html b/Data.List.Relation.Binary.Lex.Strict.html deleted file mode 100644 index 3bc49f1b..00000000 --- a/Data.List.Relation.Binary.Lex.Strict.html +++ /dev/null @@ -1,246 +0,0 @@ - -Data.List.Relation.Binary.Lex.Strict
------------------------------------------------------------------------
--- The Agda standard library
---
--- Lexicographic ordering of lists
-------------------------------------------------------------------------
-
--- The definitions of lexicographic ordering used here are suitable if
--- the argument order is a strict partial order.
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-module Data.List.Relation.Binary.Lex.Strict where
-
-open import Data.Empty using (⊥)
-open import Data.Unit.Base using (⊤; tt)
-open import Function.Base using (_∘_; id)
-open import Data.Product using (_,_)
-open import Data.Sum.Base using (inj₁; inj₂)
-open import Data.List.Base using (List; []; _∷_)
-open import Level using (_⊔_)
-open import Relation.Nullary using (yes; no; ¬_)
-open import Relation.Binary
-open import Relation.Binary.Consequences
-open import Data.List.Relation.Binary.Pointwise as Pointwise
-   using (Pointwise; []; _∷_; head; tail)
-
-import Data.List.Relation.Binary.Lex as Core
-
-----------------------------------------------------------------------
--- Re-exporting core definitions
-
-open Core public
-  using (Lex-<; Lex-≤; base; halt; this; next; ¬≤-this; ¬≤-next)
-
-----------------------------------------------------------------------
--- Strict lexicographic ordering.
-
-module _ {a ℓ₁ ℓ₂} {A : Set a} where
-
-  -- Properties
-
-  module _ {_≈_ : Rel A ℓ₁} {_≺_ : Rel A ℓ₂} where
-
-    private
-      _≋_ = Pointwise _≈_
-      _<_ = Lex-< _≈_ _≺_
-
-    xs≮[] : ∀ xs → ¬ xs < []
-    xs≮[] _ (base ())
-
-    ¬[]<[] : ¬ [] < []
-    ¬[]<[] = xs≮[] []
-
-    <-irreflexive : Irreflexive _≈_ _≺_ → Irreflexive _≋_ _<_
-    <-irreflexive irr (x≈y ∷ xs≋ys) (this x<y)     = irr x≈y x<y
-    <-irreflexive irr (x≈y ∷ xs≋ys) (next _ xs⊴ys) =
-      <-irreflexive irr xs≋ys xs⊴ys
-
-    <-asymmetric : Symmetric _≈_ → _≺_ Respects₂ _≈_ → Asymmetric _≺_ →
-                   Asymmetric _<_
-    <-asymmetric sym resp as = asym
-      where
-      irrefl : Irreflexive _≈_ _≺_
-      irrefl = asym⇒irr resp sym as
-
-      asym : Asymmetric _<_
-      asym (base bot)       _                = bot
-      asym (this x<y)       (this y<x)       = as x<y y<x
-      asym (this x<y)       (next y≈x ys⊴xs) = irrefl (sym y≈x) x<y
-      asym (next x≈y xs⊴ys) (this y<x)       = irrefl (sym x≈y) y<x
-      asym (next x≈y xs⊴ys) (next y≈x ys⊴xs) = asym xs⊴ys ys⊴xs
-
-    <-antisymmetric : Symmetric _≈_ → Irreflexive _≈_ _≺_ →
-                      Asymmetric _≺_ → Antisymmetric _≋_ _<_
-    <-antisymmetric = Core.antisymmetric
-
-    <-transitive : IsEquivalence _≈_ → _≺_ Respects₂ _≈_ →
-                   Transitive _≺_ → Transitive _<_
-    <-transitive = Core.transitive
-
-    <-compare : Symmetric _≈_ → Trichotomous _≈_ _≺_ →
-                Trichotomous _≋_ _<_
-    <-compare sym tri []       []       = tri≈ ¬[]<[] []    ¬[]<[]
-    <-compare sym tri []       (y ∷ ys) = tri< halt   (λ()) (λ())
-    <-compare sym tri (x ∷ xs) []       = tri> (λ())  (λ()) halt
-    <-compare sym tri (x ∷ xs) (y ∷ ys) with tri x y
-    ... | tri< x<y x≉y y≮x =
-          tri< (this x<y) (x≉y ∘ head) (¬≤-this (x≉y ∘ sym) y≮x)
-    ... | tri> x≮y x≉y y<x =
-          tri> (¬≤-this x≉y x≮y) (x≉y ∘ head) (this y<x)
-    ... | tri≈ x≮y x≈y y≮x with <-compare sym tri xs ys
-    ...   | tri< xs<ys xs≉ys ys≮xs =
-            tri< (next x≈y xs<ys) (xs≉ys ∘ tail) (¬≤-next y≮x ys≮xs)
-    ...   | tri≈ xs≮ys xs≈ys ys≮xs =
-            tri≈ (¬≤-next x≮y xs≮ys) (x≈y ∷ xs≈ys) (¬≤-next y≮x ys≮xs)
-    ...   | tri> xs≮ys xs≉ys ys<xs =
-            tri> (¬≤-next x≮y xs≮ys) (xs≉ys ∘ tail) (next (sym x≈y) ys<xs)
-
-    <-decidable : Decidable _≈_ → Decidable _≺_ → Decidable _<_
-    <-decidable = Core.decidable (no id)
-
-    <-respects₂ : IsEquivalence _≈_ → _≺_ Respects₂ _≈_ →
-                  _<_ Respects₂ _≋_
-    <-respects₂ = Core.respects₂
-
-    <-isStrictPartialOrder : IsStrictPartialOrder _≈_ _≺_ →
-                             IsStrictPartialOrder _≋_ _<_
-    <-isStrictPartialOrder spo = record
-      { isEquivalence = Pointwise.isEquivalence isEquivalence
-      ; irrefl        = <-irreflexive irrefl
-      ; trans         = Core.transitive isEquivalence <-resp-≈ trans
-      ; <-resp-≈      = Core.respects₂ isEquivalence <-resp-≈
-      } where open IsStrictPartialOrder spo
-
-    <-isStrictTotalOrder : IsStrictTotalOrder _≈_ _≺_ →
-                           IsStrictTotalOrder _≋_ _<_
-    <-isStrictTotalOrder sto = record
-      { isEquivalence = Pointwise.isEquivalence isEquivalence
-      ; trans         = <-transitive isEquivalence <-resp-≈ trans
-      ; compare       = <-compare Eq.sym compare
-      } where open IsStrictTotalOrder sto
-
-<-strictPartialOrder : ∀ {a ℓ₁ ℓ₂} → StrictPartialOrder a ℓ₁ ℓ₂ →
-                       StrictPartialOrder _ _ _
-<-strictPartialOrder spo = record
-  { isStrictPartialOrder = <-isStrictPartialOrder isStrictPartialOrder
-  } where open StrictPartialOrder spo
-
-<-strictTotalOrder : ∀ {a ℓ₁ ℓ₂} → StrictTotalOrder a ℓ₁ ℓ₂ →
-                       StrictTotalOrder _ _ _
-<-strictTotalOrder sto = record
-  { isStrictTotalOrder = <-isStrictTotalOrder isStrictTotalOrder
-  } where open StrictTotalOrder sto
-
-----------------------------------------------------------------------
--- Non-strict lexicographic ordering.
-
-module _ {a ℓ₁ ℓ₂} {A : Set a} where
-
-  -- Properties
-
-  ≤-reflexive : (_≈_ : Rel A ℓ₁) (_≺_ : Rel A ℓ₂) →
-                Pointwise _≈_ ⇒ Lex-≤ _≈_ _≺_
-  ≤-reflexive _≈_ _≺_ []            = base tt
-  ≤-reflexive _≈_ _≺_ (x≈y ∷ xs≈ys) =
-    next x≈y (≤-reflexive _≈_ _≺_ xs≈ys)
-
-  module _ {_≈_ : Rel A ℓ₁} {_≺_ : Rel A ℓ₂} where
-
-    private
-      _≋_ = Pointwise _≈_
-      _≤_ = Lex-≤ _≈_ _≺_
-
-    ≤-antisymmetric : Symmetric _≈_ → Irreflexive _≈_ _≺_ →
-                      Asymmetric _≺_ → Antisymmetric _≋_ _≤_
-    ≤-antisymmetric = Core.antisymmetric
-
-    ≤-transitive : IsEquivalence _≈_ → _≺_ Respects₂ _≈_ →
-                   Transitive _≺_ → Transitive _≤_
-    ≤-transitive = Core.transitive
-
-    -- Note that trichotomy is an unnecessarily strong precondition for
-    -- the following lemma.
-
-    ≤-total : Symmetric _≈_ → Trichotomous _≈_ _≺_ → Total _≤_
-    ≤-total _   _   []       []       = inj₁ (base tt)
-    ≤-total _   _   []       (x ∷ xs) = inj₁ halt
-    ≤-total _   _   (x ∷ xs) []       = inj₂ halt
-    ≤-total sym tri (x ∷ xs) (y ∷ ys) with tri x y
-    ... | tri< x<y _ _ = inj₁ (this x<y)
-    ... | tri> _ _ y<x = inj₂ (this y<x)
-    ... | tri≈ _ x≈y _ with ≤-total sym tri xs ys
-    ...   | inj₁ xs≲ys = inj₁ (next      x≈y  xs≲ys)
-    ...   | inj₂ ys≲xs = inj₂ (next (sym x≈y) ys≲xs)
-
-    ≤-decidable : Decidable _≈_ → Decidable _≺_ → Decidable _≤_
-    ≤-decidable = Core.decidable (yes tt)
-
-    ≤-respects₂ : IsEquivalence _≈_ → _≺_ Respects₂ _≈_ →
-                  _≤_ Respects₂ _≋_
-    ≤-respects₂ = Core.respects₂
-
-    ≤-isPreorder : IsEquivalence _≈_ → Transitive _≺_ →
-                   _≺_ Respects₂ _≈_ → IsPreorder _≋_ _≤_
-    ≤-isPreorder eq tr resp = record
-      { isEquivalence = Pointwise.isEquivalence eq
-      ; reflexive     = ≤-reflexive _≈_ _≺_
-      ; trans         = Core.transitive eq resp tr
-      }
-
-    ≤-isPartialOrder : IsStrictPartialOrder _≈_ _≺_ →
-                       IsPartialOrder _≋_ _≤_
-    ≤-isPartialOrder  spo = record
-      { isPreorder = ≤-isPreorder isEquivalence trans <-resp-≈
-      ; antisym    = Core.antisymmetric Eq.sym irrefl asym
-      }
-      where open IsStrictPartialOrder spo
-
-    ≤-isDecPartialOrder : IsStrictTotalOrder _≈_ _≺_ →
-                          IsDecPartialOrder _≋_ _≤_
-    ≤-isDecPartialOrder sto = record
-      { isPartialOrder = ≤-isPartialOrder isStrictPartialOrder
-      ; _≟_            = Pointwise.decidable _≟_
-      ; _≤?_           = ≤-decidable _≟_ _<?_
-      } where open IsStrictTotalOrder sto
-
-    ≤-isTotalOrder : IsStrictTotalOrder _≈_ _≺_ → IsTotalOrder _≋_ _≤_
-    ≤-isTotalOrder sto = record
-      { isPartialOrder = ≤-isPartialOrder isStrictPartialOrder
-      ; total          = ≤-total Eq.sym compare
-      }
-      where open IsStrictTotalOrder sto
-
-    ≤-isDecTotalOrder : IsStrictTotalOrder _≈_ _≺_ →
-                        IsDecTotalOrder _≋_ _≤_
-    ≤-isDecTotalOrder sto = record
-      { isTotalOrder = ≤-isTotalOrder sto
-      ; _≟_          = Pointwise.decidable _≟_
-      ; _≤?_         = ≤-decidable _≟_ _<?_
-      }
-      where open IsStrictTotalOrder sto
-
-≤-preorder : ∀ {a ℓ₁ ℓ₂} → Preorder a ℓ₁ ℓ₂ → Preorder _ _ _
-≤-preorder pre = record
-  { isPreorder = ≤-isPreorder isEquivalence trans ∼-resp-≈
-  } where open Preorder pre
-
-≤-partialOrder : ∀ {a ℓ₁ ℓ₂} → StrictPartialOrder a ℓ₁ ℓ₂ → Poset _ _ _
-≤-partialOrder spo = record
-  { isPartialOrder = ≤-isPartialOrder isStrictPartialOrder
-  } where open StrictPartialOrder spo
-
-≤-decPoset : ∀ {a ℓ₁ ℓ₂} → StrictTotalOrder a ℓ₁ ℓ₂ →
-             DecPoset _ _ _
-≤-decPoset sto = record
-  { isDecPartialOrder = ≤-isDecPartialOrder isStrictTotalOrder
-  } where open StrictTotalOrder sto
-
-
-≤-decTotalOrder : ∀ {a ℓ₁ ℓ₂} → StrictTotalOrder a ℓ₁ ℓ₂ →
-                  DecTotalOrder _ _ _
-≤-decTotalOrder sto = record
-  { isDecTotalOrder = ≤-isDecTotalOrder isStrictTotalOrder
-  } where open StrictTotalOrder sto
-
\ No newline at end of file diff --git a/Data.List.Relation.Binary.Lex.html b/Data.List.Relation.Binary.Lex.html deleted file mode 100644 index a22fb57e..00000000 --- a/Data.List.Relation.Binary.Lex.html +++ /dev/null @@ -1,117 +0,0 @@ - -Data.List.Relation.Binary.Lex
------------------------------------------------------------------------
--- The Agda standard library
---
--- Lexicographic ordering of lists
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-module Data.List.Relation.Binary.Lex where
-
-open import Data.Empty using (⊥; ⊥-elim)
-open import Data.Unit.Base using (⊤; tt)
-open import Data.Product using (_×_; _,_; proj₁; proj₂; uncurry)
-open import Data.List.Base using (List; []; _∷_)
-open import Data.Sum.Base using (_⊎_; inj₁; inj₂; [_,_])
-open import Function.Base using (_∘_; flip; id)
-open import Function.Bundles using (_⇔_; mk⇔)
-open import Level using (_⊔_)
-open import Relation.Nullary.Negation using (¬_)
-open import Relation.Nullary.Decidable as Dec
-  using (Dec; yes; no; _×-dec_; _⊎-dec_)
-open import Relation.Binary hiding (_⇔_)
-open import Data.List.Relation.Binary.Pointwise.Base
-   using (Pointwise; []; _∷_; head; tail)
-
-------------------------------------------------------------------------
--- Re-exporting the core definitions and properties
-
-open import Data.List.Relation.Binary.Lex.Core public
-
-------------------------------------------------------------------------
--- Properties
-
-module _ {a ℓ₁ ℓ₂} {A : Set a} {P : Set}
-         {_≈_ : Rel A ℓ₁} {_≺_ : Rel A ℓ₂} where
-
-  private
-    _≋_ = Pointwise _≈_
-    _<_ = Lex P _≈_ _≺_
-
-  ¬≤-this : ∀ {x y xs ys} → ¬ (x ≈ y) → ¬ (x ≺ y) →
-            ¬ (x ∷ xs) < (y ∷ ys)
-  ¬≤-this x≉y x≮y (this x≺y)       = x≮y x≺y
-  ¬≤-this x≉y x≮y (next x≈y xs<ys) = x≉y x≈y
-
-  ¬≤-next : ∀ {x y xs ys} → ¬ x ≺ y → ¬ xs < ys →
-            ¬ (x ∷ xs) < (y ∷ ys)
-  ¬≤-next x≮y xs≮ys (this x≺y)     = x≮y x≺y
-  ¬≤-next x≮y xs≮ys (next _ xs<ys) = xs≮ys xs<ys
-
-  antisymmetric : Symmetric _≈_ → Irreflexive _≈_ _≺_ →
-                  Asymmetric _≺_ → Antisymmetric _≋_ _<_
-  antisymmetric sym ir asym = as
-    where
-    as : Antisymmetric _≋_ _<_
-    as (base _)         (base _)         = []
-    as (this x≺y)       (this y≺x)       = ⊥-elim (asym x≺y y≺x)
-    as (this x≺y)       (next y≈x ys<xs) = ⊥-elim (ir (sym y≈x) x≺y)
-    as (next x≈y xs<ys) (this y≺x)       = ⊥-elim (ir (sym x≈y) y≺x)
-    as (next x≈y xs<ys) (next y≈x ys<xs) = x≈y ∷ as xs<ys ys<xs
-
-  toSum : ∀ {x y xs ys} → (x ∷ xs) < (y ∷ ys) → (x ≺ y ⊎ (x ≈ y × xs < ys))
-  toSum (this x≺y) = inj₁ x≺y
-  toSum (next x≈y xs<ys) = inj₂ (x≈y , xs<ys)
-
-  transitive : IsEquivalence _≈_ → _≺_ Respects₂ _≈_ → Transitive _≺_ →
-               Transitive _<_
-  transitive eq resp tr = trans
-    where
-    trans : Transitive (Lex P _≈_ _≺_)
-    trans (base p)         (base _)         = base p
-    trans (base y)         halt             = halt
-    trans halt             (this y≺z)       = halt
-    trans halt             (next y≈z ys<zs) = halt
-    trans (this x≺y)       (this y≺z)       = this (tr x≺y y≺z)
-    trans (this x≺y)       (next y≈z ys<zs) = this (proj₁ resp y≈z x≺y)
-    trans (next x≈y xs<ys) (this y≺z)       =
-      this (proj₂ resp (IsEquivalence.sym eq x≈y) y≺z)
-    trans (next x≈y xs<ys) (next y≈z ys<zs) =
-      next (IsEquivalence.trans eq x≈y y≈z) (trans xs<ys ys<zs)
-
-  respects₂ : IsEquivalence _≈_ → _≺_ Respects₂ _≈_ → _<_ Respects₂ _≋_
-  respects₂ eq (resp₁ , resp₂) = resp¹ , resp²
-    where
-    open IsEquivalence eq using (sym; trans)
-    resp¹ : ∀ {xs} → Lex P _≈_ _≺_ xs Respects _≋_
-    resp¹ []            xs<[]            = xs<[]
-    resp¹ (_   ∷ _)     halt             = halt
-    resp¹ (x≈y ∷ _)     (this z≺x)       = this (resp₁ x≈y z≺x)
-    resp¹ (x≈y ∷ xs≋ys) (next z≈x zs<xs) =
-      next (trans z≈x x≈y) (resp¹ xs≋ys zs<xs)
-
-    resp² : ∀ {ys} → flip (Lex P _≈_ _≺_) ys Respects _≋_
-    resp² []            []<ys            = []<ys
-    resp² (x≈z ∷ _)     (this x≺y)       = this (resp₂ x≈z x≺y)
-    resp² (x≈z ∷ xs≋zs) (next x≈y xs<ys) =
-      next (trans (sym x≈z) x≈y) (resp² xs≋zs xs<ys)
-
-
-  []<[]-⇔ : P ⇔ [] < []
-  []<[]-⇔ = mk⇔ base (λ { (base p) → p })
-
-
-  ∷<∷-⇔ : ∀ {x y xs ys} → (x ≺ y ⊎ (x ≈ y × xs < ys)) ⇔ (x ∷ xs) < (y ∷ ys)
-  ∷<∷-⇔ = mk⇔ [ this , uncurry next ] toSum
-
-  module _ (dec-P : Dec P) (dec-≈ : Decidable _≈_) (dec-≺ : Decidable _≺_)
-    where
-
-    decidable : Decidable _<_
-    decidable []       []       = Dec.map []<[]-⇔ dec-P
-    decidable []       (y ∷ ys) = yes halt
-    decidable (x ∷ xs) []       = no λ()
-    decidable (x ∷ xs) (y ∷ ys) =
-      Dec.map ∷<∷-⇔ (dec-≺ x y ⊎-dec (dec-≈ x y ×-dec decidable xs ys))
-
\ No newline at end of file diff --git a/Data.List.Relation.Binary.Permutation.Propositional.Properties.html b/Data.List.Relation.Binary.Permutation.Propositional.Properties.html index 2d35fdbe..19d0284f 100644 --- a/Data.List.Relation.Binary.Permutation.Propositional.Properties.html +++ b/Data.List.Relation.Binary.Permutation.Propositional.Properties.html @@ -14,333 +14,344 @@ open import Algebra.Structures open import Data.Bool.Base using (Bool; true; false) open import Data.Nat using (suc) -open import Data.Product using (-,_; proj₂) -open import Data.List.Base as List -open import Data.List.Relation.Binary.Permutation.Propositional -open import Data.List.Relation.Unary.Any using (Any; here; there) -open import Data.List.Relation.Unary.All using (All; []; _∷_) -open import Data.List.Membership.Propositional -open import Data.List.Membership.Propositional.Properties -import Data.List.Properties as Lₚ -open import Data.Product using (_,_; _×_; ∃; ∃₂) -open import Function.Base using (_∘_; _⟨_⟩_) -open import Function.Equality using (_⟨$⟩_) -open import Function.Inverse as Inv using (inverse) -open import Level using (Level) -open import Relation.Unary using (Pred) -open import Relation.Binary -open import Relation.Binary.PropositionalEquality as ≡ - using (_≡_ ; refl ; cong; cong₂; _≢_; inspect) -open import Relation.Nullary - -open PermutationReasoning - -private - variable - a b p : Level - A : Set a - B : Set b - ------------------------------------------------------------------------- --- Permutations of empty and singleton lists - -↭-empty-inv : ∀ {xs : List A} → xs ↭ [] → xs ≡ [] -↭-empty-inv refl = refl -↭-empty-inv (trans p q) with refl ← ↭-empty-inv q = ↭-empty-inv p - -¬x∷xs↭[] : ∀ {x} {xs : List A} → ¬ ((x ∷ xs) ↭ []) -¬x∷xs↭[] (trans s₁ s₂) with ↭-empty-inv s₂ -... | refl = ¬x∷xs↭[] s₁ - -↭-singleton-inv : ∀ {x} {xs : List A} → xs ↭ [ x ] → xs ≡ [ x ] -↭-singleton-inv refl = refl -↭-singleton-inv (prep _ ρ) with refl ← ↭-empty-inv ρ = refl -↭-singleton-inv (trans ρ₁ ρ₂) with refl ← ↭-singleton-inv ρ₂ = ↭-singleton-inv ρ₁ - ------------------------------------------------------------------------- --- sym - -↭-sym-involutive : ∀ {xs ys : List A} (p : xs ↭ ys) → ↭-sym (↭-sym p) ≡ p -↭-sym-involutive refl = refl -↭-sym-involutive (prep x ↭) = cong (prep x) (↭-sym-involutive ↭) -↭-sym-involutive (swap x y ↭) = cong (swap x y) (↭-sym-involutive ↭) -↭-sym-involutive (trans ↭₁ ↭₂) = - cong₂ trans (↭-sym-involutive ↭₁) (↭-sym-involutive ↭₂) - ------------------------------------------------------------------------- --- Relationships to other predicates - -All-resp-↭ : ∀ {P : Pred A p} → (All P) Respects _↭_ -All-resp-↭ refl wit = wit -All-resp-↭ (prep x p) (px ∷ wit) = px ∷ All-resp-↭ p wit -All-resp-↭ (swap x y p) (px ∷ py ∷ wit) = py ∷ px ∷ All-resp-↭ p wit -All-resp-↭ (trans p₁ p₂) wit = All-resp-↭ p₂ (All-resp-↭ p₁ wit) - -Any-resp-↭ : ∀ {P : Pred A p} → (Any P) Respects _↭_ -Any-resp-↭ refl wit = wit -Any-resp-↭ (prep x p) (here px) = here px -Any-resp-↭ (prep x p) (there wit) = there (Any-resp-↭ p wit) -Any-resp-↭ (swap x y p) (here px) = there (here px) -Any-resp-↭ (swap x y p) (there (here px)) = here px -Any-resp-↭ (swap x y p) (there (there wit)) = there (there (Any-resp-↭ p wit)) -Any-resp-↭ (trans p p₁) wit = Any-resp-↭ p₁ (Any-resp-↭ p wit) - -∈-resp-↭ : ∀ {x : A} → (x ∈_) Respects _↭_ -∈-resp-↭ = Any-resp-↭ - -Any-resp-[σ⁻¹∘σ] : {xs ys : List A} {P : Pred A p} → - (σ : xs ↭ ys) → - (ix : Any P xs) → - Any-resp-↭ (trans σ (↭-sym σ)) ix ≡ ix -Any-resp-[σ⁻¹∘σ] refl ix = refl -Any-resp-[σ⁻¹∘σ] (prep _ _) (here _) = refl -Any-resp-[σ⁻¹∘σ] (swap _ _ _) (here _) = refl -Any-resp-[σ⁻¹∘σ] (swap _ _ _) (there (here _)) = refl -Any-resp-[σ⁻¹∘σ] (trans σ₁ σ₂) ix - rewrite Any-resp-[σ⁻¹∘σ] σ₂ (Any-resp-↭ σ₁ ix) - rewrite Any-resp-[σ⁻¹∘σ] σ₁ ix - = refl -Any-resp-[σ⁻¹∘σ] (prep _ σ) (there ix) - rewrite Any-resp-[σ⁻¹∘σ] σ ix - = refl -Any-resp-[σ⁻¹∘σ] (swap _ _ σ) (there (there ix)) - rewrite Any-resp-[σ⁻¹∘σ] σ ix - = refl - -∈-resp-[σ⁻¹∘σ] : {xs ys : List A} {x : A} → - (σ : xs ↭ ys) → - (ix : x ∈ xs) → - ∈-resp-↭ (trans σ (↭-sym σ)) ix ≡ ix -∈-resp-[σ⁻¹∘σ] = Any-resp-[σ⁻¹∘σ] - ------------------------------------------------------------------------- --- map - -module _ (f : A → B) where - - map⁺ : ∀ {xs ys} → xs ↭ ys → map f xs ↭ map f ys - map⁺ refl = refl - map⁺ (prep x p) = prep _ (map⁺ p) - map⁺ (swap x y p) = swap _ _ (map⁺ p) - map⁺ (trans p₁ p₂) = trans (map⁺ p₁) (map⁺ p₂) - - -- permutations preserve 'being a mapped list' - ↭-map-inv : ∀ {xs ys} → map f xs ↭ ys → ∃ λ ys′ → ys ≡ map f ys′ × xs ↭ ys′ - ↭-map-inv {[]} ρ = -, ↭-empty-inv (↭-sym ρ) , ↭-refl - ↭-map-inv {x ∷ []} ρ = -, ↭-singleton-inv (↭-sym ρ) , ↭-refl - ↭-map-inv {_ ∷ _ ∷ _} refl = -, refl , ↭-refl - ↭-map-inv {_ ∷ _ ∷ _} (prep _ ρ) with _ , refl , ρ′ ← ↭-map-inv ρ = -, refl , prep _ ρ′ - ↭-map-inv {_ ∷ _ ∷ _} (swap _ _ ρ) with _ , refl , ρ′ ← ↭-map-inv ρ = -, refl , swap _ _ ρ′ - ↭-map-inv {_ ∷ _ ∷ _} (trans ρ₁ ρ₂) with _ , refl , ρ₃ ← ↭-map-inv ρ₁ - with _ , refl , ρ₄ ← ↭-map-inv ρ₂ = -, refl , trans ρ₃ ρ₄ - ------------------------------------------------------------------------- --- length - -↭-length : ∀ {xs ys : List A} → xs ↭ ys → length xs ≡ length ys -↭-length refl = refl -↭-length (prep x lr) = cong suc (↭-length lr) -↭-length (swap x y lr) = cong (suc ∘ suc) (↭-length lr) -↭-length (trans lr₁ lr₂) = ≡.trans (↭-length lr₁) (↭-length lr₂) - ------------------------------------------------------------------------- --- _++_ - -++⁺ˡ : ∀ xs {ys zs : List A} → ys ↭ zs → xs ++ ys ↭ xs ++ zs -++⁺ˡ [] ys↭zs = ys↭zs -++⁺ˡ (x ∷ xs) ys↭zs = prep x (++⁺ˡ xs ys↭zs) - -++⁺ʳ : ∀ {xs ys : List A} zs → xs ↭ ys → xs ++ zs ↭ ys ++ zs -++⁺ʳ zs refl = refl -++⁺ʳ zs (prep x ↭) = prep x (++⁺ʳ zs ↭) -++⁺ʳ zs (swap x y ↭) = swap x y (++⁺ʳ zs ↭) -++⁺ʳ zs (trans ↭₁ ↭₂) = trans (++⁺ʳ zs ↭₁) (++⁺ʳ zs ↭₂) - -++⁺ : _++_ {A = A} Preserves₂ _↭_ ⟶ _↭_ ⟶ _↭_ -++⁺ ws↭xs ys↭zs = trans (++⁺ʳ _ ws↭xs) (++⁺ˡ _ ys↭zs) - --- Some useful lemmas - -zoom : ∀ h {t xs ys : List A} → xs ↭ ys → h ++ xs ++ t ↭ h ++ ys ++ t -zoom h {t} = ++⁺ˡ h ∘ ++⁺ʳ t - -inject : ∀ (v : A) {ws xs ys zs} → ws ↭ ys → xs ↭ zs → - ws ++ [ v ] ++ xs ↭ ys ++ [ v ] ++ zs -inject v ws↭ys xs↭zs = trans (++⁺ˡ _ (prep v xs↭zs)) (++⁺ʳ _ ws↭ys) - -shift : ∀ v (xs ys : List A) → xs ++ [ v ] ++ ys ↭ v ∷ xs ++ ys -shift v [] ys = refl -shift v (x ∷ xs) ys = begin - x ∷ (xs ++ [ v ] ++ ys) <⟨ shift v xs ys ⟩ - x ∷ v ∷ xs ++ ys <<⟨ refl ⟩ - v ∷ x ∷ xs ++ ys ∎ - -drop-mid-≡ : ∀ {x : A} ws xs {ys} {zs} → - ws ++ [ x ] ++ ys ≡ xs ++ [ x ] ++ zs → - ws ++ ys ↭ xs ++ zs -drop-mid-≡ [] [] eq with cong tail eq -drop-mid-≡ [] [] eq | refl = refl -drop-mid-≡ [] (x ∷ xs) refl = shift _ xs _ -drop-mid-≡ (w ∷ ws) [] refl = ↭-sym (shift _ ws _) -drop-mid-≡ (w ∷ ws) (x ∷ xs) eq with Lₚ.∷-injective eq -... | refl , eq′ = prep w (drop-mid-≡ ws xs eq′) - -drop-mid : ∀ {x : A} ws xs {ys zs} → - ws ++ [ x ] ++ ys ↭ xs ++ [ x ] ++ zs → - ws ++ ys ↭ xs ++ zs -drop-mid {A = A} {x} ws xs p = drop-mid′ p ws xs refl refl - where - drop-mid′ : ∀ {l′ l″ : List A} → l′ ↭ l″ → - ∀ ws xs {ys zs} → - ws ++ [ x ] ++ ys ≡ l′ → - xs ++ [ x ] ++ zs ≡ l″ → - ws ++ ys ↭ xs ++ zs - drop-mid′ refl ws xs refl eq = drop-mid-≡ ws xs (≡.sym eq) - drop-mid′ (prep x p) [] [] refl eq with cong tail eq - drop-mid′ (prep x p) [] [] refl eq | refl = p - drop-mid′ (prep x p) [] (x ∷ xs) refl refl = trans p (shift _ _ _) - drop-mid′ (prep x p) (w ∷ ws) [] refl refl = trans (↭-sym (shift _ _ _)) p - drop-mid′ (prep x p) (w ∷ ws) (x ∷ xs) refl refl = prep _ (drop-mid′ p ws xs refl refl) - drop-mid′ (swap y z p) [] [] refl refl = prep _ p - drop-mid′ (swap y z p) [] (x ∷ []) refl eq with cong {B = List _} - (λ { (x ∷ _ ∷ xs) → x ∷ xs - ; _ → [] - }) - eq - drop-mid′ (swap y z p) [] (x ∷ []) refl eq | refl = prep _ p - drop-mid′ (swap y z p) [] (x ∷ _ ∷ xs) refl refl = prep _ (trans p (shift _ _ _)) - drop-mid′ (swap y z p) (w ∷ []) [] refl eq with cong tail eq - drop-mid′ (swap y z p) (w ∷ []) [] refl eq | refl = prep _ p - drop-mid′ (swap y z p) (w ∷ x ∷ ws) [] refl refl = prep _ (trans (↭-sym (shift _ _ _)) p) - drop-mid′ (swap y y p) (y ∷ []) (y ∷ []) refl refl = prep _ p - drop-mid′ (swap y z p) (y ∷ []) (z ∷ y ∷ xs) refl refl = begin - _ ∷ _ <⟨ p ⟩ - _ ∷ (xs ++ _ ∷ _) <⟨ shift _ _ _ ⟩ - _ ∷ _ ∷ xs ++ _ <<⟨ refl ⟩ - _ ∷ _ ∷ xs ++ _ ∎ - drop-mid′ (swap y z p) (y ∷ z ∷ ws) (z ∷ []) refl refl = begin - _ ∷ _ ∷ ws ++ _ <<⟨ refl ⟩ - _ ∷ (_ ∷ ws ++ _) <⟨ ↭-sym (shift _ _ _) ⟩ - _ ∷ (ws ++ _ ∷ _) <⟨ p ⟩ - _ ∷ _ ∎ - drop-mid′ (swap y z p) (y ∷ z ∷ ws) (z ∷ y ∷ xs) refl refl = swap y z (drop-mid′ p _ _ refl refl) - drop-mid′ (trans p₁ p₂) ws xs refl refl with ∈-∃++ (∈-resp-↭ p₁ (∈-insert ws)) - ... | (h , t , refl) = trans (drop-mid′ p₁ ws h refl refl) (drop-mid′ p₂ h xs refl refl) - --- Algebraic properties - -++-identityˡ : LeftIdentity {A = List A} _↭_ [] _++_ -++-identityˡ xs = refl - -++-identityʳ : RightIdentity {A = List A} _↭_ [] _++_ -++-identityʳ xs = ↭-reflexive (Lₚ.++-identityʳ xs) - -++-identity : Identity {A = List A} _↭_ [] _++_ -++-identity = ++-identityˡ , ++-identityʳ - -++-assoc : Associative {A = List A} _↭_ _++_ -++-assoc xs ys zs = ↭-reflexive (Lₚ.++-assoc xs ys zs) - -++-comm : Commutative {A = List A} _↭_ _++_ -++-comm [] ys = ↭-sym (++-identityʳ ys) -++-comm (x ∷ xs) ys = begin - x ∷ xs ++ ys <⟨ ++-comm xs ys ⟩ - x ∷ ys ++ xs ↭˘⟨ shift x ys xs ⟩ - ys ++ (x ∷ xs) ∎ - -++-isMagma : IsMagma {A = List A} _↭_ _++_ -++-isMagma = record - { isEquivalence = ↭-isEquivalence - ; ∙-cong = ++⁺ - } - -++-isSemigroup : IsSemigroup {A = List A} _↭_ _++_ -++-isSemigroup = record - { isMagma = ++-isMagma - ; assoc = ++-assoc - } - -++-isMonoid : IsMonoid {A = List A} _↭_ _++_ [] -++-isMonoid = record - { isSemigroup = ++-isSemigroup - ; identity = ++-identity - } - -++-isCommutativeMonoid : IsCommutativeMonoid {A = List A} _↭_ _++_ [] -++-isCommutativeMonoid = record - { isMonoid = ++-isMonoid - ; comm = ++-comm - } - -module _ {a} {A : Set a} where - - ++-magma : Magma _ _ - ++-magma = record - { isMagma = ++-isMagma {A = A} - } - - ++-semigroup : Semigroup a _ - ++-semigroup = record - { isSemigroup = ++-isSemigroup {A = A} - } - - ++-monoid : Monoid a _ - ++-monoid = record - { isMonoid = ++-isMonoid {A = A} - } - - ++-commutativeMonoid : CommutativeMonoid _ _ - ++-commutativeMonoid = record - { isCommutativeMonoid = ++-isCommutativeMonoid {A = A} - } - --- Another useful lemma - -shifts : ∀ xs ys {zs : List A} → xs ++ ys ++ zs ↭ ys ++ xs ++ zs -shifts xs ys {zs} = begin - xs ++ ys ++ zs ↭˘⟨ ++-assoc xs ys zs ⟩ - (xs ++ ys) ++ zs ↭⟨ ++⁺ʳ zs (++-comm xs ys) ⟩ - (ys ++ xs) ++ zs ↭⟨ ++-assoc ys xs zs ⟩ - ys ++ xs ++ zs ∎ - ------------------------------------------------------------------------- --- _∷_ - -drop-∷ : ∀ {x : A} {xs ys} → x ∷ xs ↭ x ∷ ys → xs ↭ ys -drop-∷ = drop-mid [] [] - ------------------------------------------------------------------------- --- _∷ʳ_ - -∷↭∷ʳ : ∀ (x : A) xs → x ∷ xs ↭ xs ∷ʳ x -∷↭∷ʳ x xs = ↭-sym (begin - xs ++ [ x ] ↭⟨ shift x xs [] ⟩ - x ∷ xs ++ [] ≡⟨ Lₚ.++-identityʳ _ ⟩ - x ∷ xs ∎) - ------------------------------------------------------------------------- --- ʳ++ - -++↭ʳ++ : ∀ (xs ys : List A) → xs ++ ys ↭ xs ʳ++ ys -++↭ʳ++ [] ys = ↭-refl -++↭ʳ++ (x ∷ xs) ys = ↭-trans (↭-sym (shift x xs ys)) (++↭ʳ++ xs (x ∷ ys)) - ------------------------------------------------------------------------- --- merge - -module _ {ℓ} {R : Rel A ℓ} (R? : Decidable R) where - - merge-↭ : ∀ xs ys → merge R? xs ys ↭ xs ++ ys - merge-↭ [] [] = ↭-refl - merge-↭ [] (y ∷ ys) = ↭-refl - merge-↭ (x ∷ xs) [] = ↭-sym (++-identityʳ (x ∷ xs)) - merge-↭ (x ∷ xs) (y ∷ ys) - with does (R? x y) | merge-↭ xs (y ∷ ys) | merge-↭ (x ∷ xs) ys - ... | true | rec | _ = prep x rec - ... | false | _ | rec = begin - y ∷ merge R? (x ∷ xs) ys <⟨ rec ⟩ - y ∷ x ∷ xs ++ ys ↭˘⟨ shift y (x ∷ xs) ys ⟩ - (x ∷ xs) ++ y ∷ ys ≡˘⟨ Lₚ.++-assoc [ x ] xs (y ∷ ys) ⟩ - x ∷ xs ++ y ∷ ys ∎ - where open PermutationReasoning +open import Data.Product.Base using (-,_; proj₂) +open import Data.List.Base as List +open import Data.List.Relation.Binary.Permutation.Propositional +open import Data.List.Relation.Unary.Any using (Any; here; there) +open import Data.List.Relation.Unary.All using (All; []; _∷_) +open import Data.List.Membership.Propositional +open import Data.List.Membership.Propositional.Properties +import Data.List.Properties as Lₚ +open import Data.Product.Base using (_,_; _×_; ∃; ∃₂) +open import Function.Base using (_∘_; _⟨_⟩_) +open import Level using (Level) +open import Relation.Unary using (Pred) +open import Relation.Binary.Core using (Rel; _Preserves₂_⟶_⟶_) +open import Relation.Binary.Definitions using (_Respects_; Decidable) +open import Relation.Binary.PropositionalEquality.Core as ≡ + using (_≡_ ; refl ; cong; cong₂; _≢_) +open import Relation.Nullary + +open PermutationReasoning + +private + variable + a b p : Level + A : Set a + B : Set b + +------------------------------------------------------------------------ +-- Permutations of empty and singleton lists + +↭-empty-inv : ∀ {xs : List A} → xs ↭ [] → xs ≡ [] +↭-empty-inv refl = refl +↭-empty-inv (trans p q) with refl ← ↭-empty-inv q = ↭-empty-inv p + +¬x∷xs↭[] : ∀ {x} {xs : List A} → ¬ ((x ∷ xs) ↭ []) +¬x∷xs↭[] (trans s₁ s₂) with ↭-empty-inv s₂ +... | refl = ¬x∷xs↭[] s₁ + +↭-singleton-inv : ∀ {x} {xs : List A} → xs ↭ [ x ] → xs ≡ [ x ] +↭-singleton-inv refl = refl +↭-singleton-inv (prep _ ρ) with refl ← ↭-empty-inv ρ = refl +↭-singleton-inv (trans ρ₁ ρ₂) with refl ← ↭-singleton-inv ρ₂ = ↭-singleton-inv ρ₁ + +------------------------------------------------------------------------ +-- sym + +↭-sym-involutive : ∀ {xs ys : List A} (p : xs ↭ ys) → ↭-sym (↭-sym p) ≡ p +↭-sym-involutive refl = refl +↭-sym-involutive (prep x ↭) = cong (prep x) (↭-sym-involutive ↭) +↭-sym-involutive (swap x y ↭) = cong (swap x y) (↭-sym-involutive ↭) +↭-sym-involutive (trans ↭₁ ↭₂) = + cong₂ trans (↭-sym-involutive ↭₁) (↭-sym-involutive ↭₂) + +------------------------------------------------------------------------ +-- Relationships to other predicates + +All-resp-↭ : ∀ {P : Pred A p} → (All P) Respects _↭_ +All-resp-↭ refl wit = wit +All-resp-↭ (prep x p) (px ∷ wit) = px ∷ All-resp-↭ p wit +All-resp-↭ (swap x y p) (px ∷ py ∷ wit) = py ∷ px ∷ All-resp-↭ p wit +All-resp-↭ (trans p₁ p₂) wit = All-resp-↭ p₂ (All-resp-↭ p₁ wit) + +Any-resp-↭ : ∀ {P : Pred A p} → (Any P) Respects _↭_ +Any-resp-↭ refl wit = wit +Any-resp-↭ (prep x p) (here px) = here px +Any-resp-↭ (prep x p) (there wit) = there (Any-resp-↭ p wit) +Any-resp-↭ (swap x y p) (here px) = there (here px) +Any-resp-↭ (swap x y p) (there (here px)) = here px +Any-resp-↭ (swap x y p) (there (there wit)) = there (there (Any-resp-↭ p wit)) +Any-resp-↭ (trans p p₁) wit = Any-resp-↭ p₁ (Any-resp-↭ p wit) + +∈-resp-↭ : ∀ {x : A} → (x ∈_) Respects _↭_ +∈-resp-↭ = Any-resp-↭ + +Any-resp-[σ⁻¹∘σ] : {xs ys : List A} {P : Pred A p} → + (σ : xs ↭ ys) → + (ix : Any P xs) → + Any-resp-↭ (trans σ (↭-sym σ)) ix ≡ ix +Any-resp-[σ⁻¹∘σ] refl ix = refl +Any-resp-[σ⁻¹∘σ] (prep _ _) (here _) = refl +Any-resp-[σ⁻¹∘σ] (swap _ _ _) (here _) = refl +Any-resp-[σ⁻¹∘σ] (swap _ _ _) (there (here _)) = refl +Any-resp-[σ⁻¹∘σ] (trans σ₁ σ₂) ix + rewrite Any-resp-[σ⁻¹∘σ] σ₂ (Any-resp-↭ σ₁ ix) + rewrite Any-resp-[σ⁻¹∘σ] σ₁ ix + = refl +Any-resp-[σ⁻¹∘σ] (prep _ σ) (there ix) + rewrite Any-resp-[σ⁻¹∘σ] σ ix + = refl +Any-resp-[σ⁻¹∘σ] (swap _ _ σ) (there (there ix)) + rewrite Any-resp-[σ⁻¹∘σ] σ ix + = refl + +∈-resp-[σ⁻¹∘σ] : {xs ys : List A} {x : A} → + (σ : xs ↭ ys) → + (ix : x ∈ xs) → + ∈-resp-↭ (trans σ (↭-sym σ)) ix ≡ ix +∈-resp-[σ⁻¹∘σ] = Any-resp-[σ⁻¹∘σ] + +------------------------------------------------------------------------ +-- map + +module _ (f : A → B) where + + map⁺ : ∀ {xs ys} → xs ↭ ys → map f xs ↭ map f ys + map⁺ refl = refl + map⁺ (prep x p) = prep _ (map⁺ p) + map⁺ (swap x y p) = swap _ _ (map⁺ p) + map⁺ (trans p₁ p₂) = trans (map⁺ p₁) (map⁺ p₂) + + -- permutations preserve 'being a mapped list' + ↭-map-inv : ∀ {xs ys} → map f xs ↭ ys → ∃ λ ys′ → ys ≡ map f ys′ × xs ↭ ys′ + ↭-map-inv {[]} ρ = -, ↭-empty-inv (↭-sym ρ) , ↭-refl + ↭-map-inv {x ∷ []} ρ = -, ↭-singleton-inv (↭-sym ρ) , ↭-refl + ↭-map-inv {_ ∷ _ ∷ _} refl = -, refl , ↭-refl + ↭-map-inv {_ ∷ _ ∷ _} (prep _ ρ) with _ , refl , ρ′ ← ↭-map-inv ρ = -, refl , prep _ ρ′ + ↭-map-inv {_ ∷ _ ∷ _} (swap _ _ ρ) with _ , refl , ρ′ ← ↭-map-inv ρ = -, refl , swap _ _ ρ′ + ↭-map-inv {_ ∷ _ ∷ _} (trans ρ₁ ρ₂) with _ , refl , ρ₃ ← ↭-map-inv ρ₁ + with _ , refl , ρ₄ ← ↭-map-inv ρ₂ = -, refl , trans ρ₃ ρ₄ + +------------------------------------------------------------------------ +-- length + +↭-length : ∀ {xs ys : List A} → xs ↭ ys → length xs ≡ length ys +↭-length refl = refl +↭-length (prep x lr) = cong suc (↭-length lr) +↭-length (swap x y lr) = cong (suc ∘ suc) (↭-length lr) +↭-length (trans lr₁ lr₂) = ≡.trans (↭-length lr₁) (↭-length lr₂) + +------------------------------------------------------------------------ +-- _++_ + +++⁺ˡ : ∀ xs {ys zs : List A} → ys ↭ zs → xs ++ ys ↭ xs ++ zs +++⁺ˡ [] ys↭zs = ys↭zs +++⁺ˡ (x ∷ xs) ys↭zs = prep x (++⁺ˡ xs ys↭zs) + +++⁺ʳ : ∀ {xs ys : List A} zs → xs ↭ ys → xs ++ zs ↭ ys ++ zs +++⁺ʳ zs refl = refl +++⁺ʳ zs (prep x ↭) = prep x (++⁺ʳ zs ↭) +++⁺ʳ zs (swap x y ↭) = swap x y (++⁺ʳ zs ↭) +++⁺ʳ zs (trans ↭₁ ↭₂) = trans (++⁺ʳ zs ↭₁) (++⁺ʳ zs ↭₂) + +++⁺ : _++_ {A = A} Preserves₂ _↭_ ⟶ _↭_ ⟶ _↭_ +++⁺ ws↭xs ys↭zs = trans (++⁺ʳ _ ws↭xs) (++⁺ˡ _ ys↭zs) + +-- Some useful lemmas + +zoom : ∀ h {t xs ys : List A} → xs ↭ ys → h ++ xs ++ t ↭ h ++ ys ++ t +zoom h {t} = ++⁺ˡ h ∘ ++⁺ʳ t + +inject : ∀ (v : A) {ws xs ys zs} → ws ↭ ys → xs ↭ zs → + ws ++ [ v ] ++ xs ↭ ys ++ [ v ] ++ zs +inject v ws↭ys xs↭zs = trans (++⁺ˡ _ (prep v xs↭zs)) (++⁺ʳ _ ws↭ys) + +shift : ∀ v (xs ys : List A) → xs ++ [ v ] ++ ys ↭ v ∷ xs ++ ys +shift v [] ys = refl +shift v (x ∷ xs) ys = begin + x ∷ (xs ++ [ v ] ++ ys) <⟨ shift v xs ys ⟩ + x ∷ v ∷ xs ++ ys <<⟨ refl ⟩ + v ∷ x ∷ xs ++ ys ∎ + +drop-mid-≡ : ∀ {x : A} ws xs {ys} {zs} → + ws ++ [ x ] ++ ys ≡ xs ++ [ x ] ++ zs → + ws ++ ys ↭ xs ++ zs +drop-mid-≡ [] [] eq with cong tail eq +drop-mid-≡ [] [] eq | refl = refl +drop-mid-≡ [] (x ∷ xs) refl = shift _ xs _ +drop-mid-≡ (w ∷ ws) [] refl = ↭-sym (shift _ ws _) +drop-mid-≡ (w ∷ ws) (x ∷ xs) eq with Lₚ.∷-injective eq +... | refl , eq′ = prep w (drop-mid-≡ ws xs eq′) + +drop-mid : ∀ {x : A} ws xs {ys zs} → + ws ++ [ x ] ++ ys ↭ xs ++ [ x ] ++ zs → + ws ++ ys ↭ xs ++ zs +drop-mid {A = A} {x} ws xs p = drop-mid′ p ws xs refl refl + where + drop-mid′ : ∀ {l′ l″ : List A} → l′ ↭ l″ → + ∀ ws xs {ys zs} → + ws ++ [ x ] ++ ys ≡ l′ → + xs ++ [ x ] ++ zs ≡ l″ → + ws ++ ys ↭ xs ++ zs + drop-mid′ refl ws xs refl eq = drop-mid-≡ ws xs (≡.sym eq) + drop-mid′ (prep x p) [] [] refl eq with cong tail eq + drop-mid′ (prep x p) [] [] refl eq | refl = p + drop-mid′ (prep x p) [] (x ∷ xs) refl refl = trans p (shift _ _ _) + drop-mid′ (prep x p) (w ∷ ws) [] refl refl = trans (↭-sym (shift _ _ _)) p + drop-mid′ (prep x p) (w ∷ ws) (x ∷ xs) refl refl = prep _ (drop-mid′ p ws xs refl refl) + drop-mid′ (swap y z p) [] [] refl refl = prep _ p + drop-mid′ (swap y z p) [] (x ∷ []) refl eq with cong {B = List _} + (λ { (x ∷ _ ∷ xs) → x ∷ xs + ; _ → [] + }) + eq + drop-mid′ (swap y z p) [] (x ∷ []) refl eq | refl = prep _ p + drop-mid′ (swap y z p) [] (x ∷ _ ∷ xs) refl refl = prep _ (trans p (shift _ _ _)) + drop-mid′ (swap y z p) (w ∷ []) [] refl eq with cong tail eq + drop-mid′ (swap y z p) (w ∷ []) [] refl eq | refl = prep _ p + drop-mid′ (swap y z p) (w ∷ x ∷ ws) [] refl refl = prep _ (trans (↭-sym (shift _ _ _)) p) + drop-mid′ (swap y y p) (y ∷ []) (y ∷ []) refl refl = prep _ p + drop-mid′ (swap y z p) (y ∷ []) (z ∷ y ∷ xs) refl refl = begin + _ ∷ _ <⟨ p ⟩ + _ ∷ (xs ++ _ ∷ _) <⟨ shift _ _ _ ⟩ + _ ∷ _ ∷ xs ++ _ <<⟨ refl ⟩ + _ ∷ _ ∷ xs ++ _ ∎ + drop-mid′ (swap y z p) (y ∷ z ∷ ws) (z ∷ []) refl refl = begin + _ ∷ _ ∷ ws ++ _ <<⟨ refl ⟩ + _ ∷ (_ ∷ ws ++ _) <⟨ ↭-sym (shift _ _ _) ⟩ + _ ∷ (ws ++ _ ∷ _) <⟨ p ⟩ + _ ∷ _ ∎ + drop-mid′ (swap y z p) (y ∷ z ∷ ws) (z ∷ y ∷ xs) refl refl = swap y z (drop-mid′ p _ _ refl refl) + drop-mid′ (trans p₁ p₂) ws xs refl refl with ∈-∃++ (∈-resp-↭ p₁ (∈-insert ws)) + ... | (h , t , refl) = trans (drop-mid′ p₁ ws h refl refl) (drop-mid′ p₂ h xs refl refl) + +-- Algebraic properties + +++-identityˡ : LeftIdentity {A = List A} _↭_ [] _++_ +++-identityˡ xs = refl + +++-identityʳ : RightIdentity {A = List A} _↭_ [] _++_ +++-identityʳ xs = ↭-reflexive (Lₚ.++-identityʳ xs) + +++-identity : Identity {A = List A} _↭_ [] _++_ +++-identity = ++-identityˡ , ++-identityʳ + +++-assoc : Associative {A = List A} _↭_ _++_ +++-assoc xs ys zs = ↭-reflexive (Lₚ.++-assoc xs ys zs) + +++-comm : Commutative {A = List A} _↭_ _++_ +++-comm [] ys = ↭-sym (++-identityʳ ys) +++-comm (x ∷ xs) ys = begin + x ∷ xs ++ ys <⟨ ++-comm xs ys ⟩ + x ∷ ys ++ xs ↭⟨ shift x ys xs ⟨ + ys ++ (x ∷ xs) ∎ + +++-isMagma : IsMagma {A = List A} _↭_ _++_ +++-isMagma = record + { isEquivalence = ↭-isEquivalence + ; ∙-cong = ++⁺ + } + +++-isSemigroup : IsSemigroup {A = List A} _↭_ _++_ +++-isSemigroup = record + { isMagma = ++-isMagma + ; assoc = ++-assoc + } + +++-isMonoid : IsMonoid {A = List A} _↭_ _++_ [] +++-isMonoid = record + { isSemigroup = ++-isSemigroup + ; identity = ++-identity + } + +++-isCommutativeMonoid : IsCommutativeMonoid {A = List A} _↭_ _++_ [] +++-isCommutativeMonoid = record + { isMonoid = ++-isMonoid + ; comm = ++-comm + } + +module _ {a} {A : Set a} where + + ++-magma : Magma _ _ + ++-magma = record + { isMagma = ++-isMagma {A = A} + } + + ++-semigroup : Semigroup a _ + ++-semigroup = record + { isSemigroup = ++-isSemigroup {A = A} + } + + ++-monoid : Monoid a _ + ++-monoid = record + { isMonoid = ++-isMonoid {A = A} + } + + ++-commutativeMonoid : CommutativeMonoid _ _ + ++-commutativeMonoid = record + { isCommutativeMonoid = ++-isCommutativeMonoid {A = A} + } + +-- Another useful lemma + +shifts : ∀ xs ys {zs : List A} → xs ++ ys ++ zs ↭ ys ++ xs ++ zs +shifts xs ys {zs} = begin + xs ++ ys ++ zs ↭⟨ ++-assoc xs ys zs ⟨ + (xs ++ ys) ++ zs ↭⟨ ++⁺ʳ zs (++-comm xs ys) ⟩ + (ys ++ xs) ++ zs ↭⟨ ++-assoc ys xs zs ⟩ + ys ++ xs ++ zs ∎ + +------------------------------------------------------------------------ +-- _∷_ + +drop-∷ : ∀ {x : A} {xs ys} → x ∷ xs ↭ x ∷ ys → xs ↭ ys +drop-∷ = drop-mid [] [] + +------------------------------------------------------------------------ +-- _∷ʳ_ + +∷↭∷ʳ : ∀ (x : A) xs → x ∷ xs ↭ xs ∷ʳ x +∷↭∷ʳ x xs = ↭-sym (begin + xs ++ [ x ] ↭⟨ shift x xs [] ⟩ + x ∷ xs ++ [] ≡⟨ Lₚ.++-identityʳ _ ⟩ + x ∷ xs ∎) + +------------------------------------------------------------------------ +-- ʳ++ + +++↭ʳ++ : ∀ (xs ys : List A) → xs ++ ys ↭ xs ʳ++ ys +++↭ʳ++ [] ys = ↭-refl +++↭ʳ++ (x ∷ xs) ys = ↭-trans (↭-sym (shift x xs ys)) (++↭ʳ++ xs (x ∷ ys)) + +------------------------------------------------------------------------ +-- reverse + +↭-reverse : (xs : List A) → reverse xs ↭ xs +↭-reverse [] = ↭-refl +↭-reverse (x ∷ xs) = begin + reverse (x ∷ xs) ≡⟨ Lₚ.unfold-reverse x xs ⟩ + reverse xs ∷ʳ x ↭⟨ ∷↭∷ʳ x (reverse xs) ⟨ + x ∷ reverse xs ↭⟨ prep x (↭-reverse xs) ⟩ + x ∷ xs ∎ + where open PermutationReasoning + +------------------------------------------------------------------------ +-- merge + +module _ {ℓ} {R : Rel A ℓ} (R? : Decidable R) where + + merge-↭ : ∀ xs ys → merge R? xs ys ↭ xs ++ ys + merge-↭ [] [] = ↭-refl + merge-↭ [] (y ∷ ys) = ↭-refl + merge-↭ (x ∷ xs) [] = ↭-sym (++-identityʳ (x ∷ xs)) + merge-↭ (x ∷ xs) (y ∷ ys) + with does (R? x y) | merge-↭ xs (y ∷ ys) | merge-↭ (x ∷ xs) ys + ... | true | rec | _ = prep x rec + ... | false | _ | rec = begin + y ∷ merge R? (x ∷ xs) ys <⟨ rec ⟩ + y ∷ x ∷ xs ++ ys ↭⟨ shift y (x ∷ xs) ys ⟨ + (x ∷ xs) ++ y ∷ ys ≡⟨ Lₚ.++-assoc [ x ] xs (y ∷ ys) ⟨ + x ∷ xs ++ y ∷ ys ∎ + where open PermutationReasoning \ No newline at end of file diff --git a/Data.List.Relation.Binary.Permutation.Propositional.html b/Data.List.Relation.Binary.Permutation.Propositional.html index cd12b34a..61217b58 100644 --- a/Data.List.Relation.Binary.Permutation.Propositional.html +++ b/Data.List.Relation.Binary.Permutation.Propositional.html @@ -10,90 +10,93 @@ module Data.List.Relation.Binary.Permutation.Propositional {a} {A : Set a} where -open import Data.List.Base using (List; []; _∷_) -open import Relation.Binary -open import Relation.Binary.PropositionalEquality using (_≡_; refl) -import Relation.Binary.Reasoning.Setoid as EqReasoning - ------------------------------------------------------------------------- --- An inductive definition of permutation - --- Note that one would expect that this would be defined in terms of --- `Permutation.Setoid`. This is not currently the case as it involves --- adding in a bunch of trivial `_≡_` proofs to the constructors which --- a) adds noise and b) prevents easy access to the variables `x`, `y`. --- This may be changed in future when a better solution is found. - -infix 3 _↭_ - -data _↭_ : Rel (List A) a where - refl : ∀ {xs} → xs ↭ xs - prep : ∀ {xs ys} x → xs ↭ ys → x ∷ xs ↭ x ∷ ys - swap : ∀ {xs ys} x y → xs ↭ ys → x ∷ y ∷ xs ↭ y ∷ x ∷ ys - trans : ∀ {xs ys zs} → xs ↭ ys → ys ↭ zs → xs ↭ zs - ------------------------------------------------------------------------- --- _↭_ is an equivalence - -↭-reflexive : _≡_ ⇒ _↭_ -↭-reflexive refl = refl - -↭-refl : Reflexive _↭_ -↭-refl = refl - -↭-sym : ∀ {xs ys} → xs ↭ ys → ys ↭ xs -↭-sym refl = refl -↭-sym (prep x xs↭ys) = prep x (↭-sym xs↭ys) -↭-sym (swap x y xs↭ys) = swap y x (↭-sym xs↭ys) -↭-sym (trans xs↭ys ys↭zs) = trans (↭-sym ys↭zs) (↭-sym xs↭ys) - --- A smart version of trans that avoids unnecessary `refl`s (see #1113). -↭-trans : Transitive _↭_ -↭-trans refl ρ₂ = ρ₂ -↭-trans ρ₁ refl = ρ₁ -↭-trans ρ₁ ρ₂ = trans ρ₁ ρ₂ - -↭-isEquivalence : IsEquivalence _↭_ -↭-isEquivalence = record - { refl = refl - ; sym = ↭-sym - ; trans = ↭-trans - } - -↭-setoid : Setoid _ _ -↭-setoid = record - { isEquivalence = ↭-isEquivalence - } - ------------------------------------------------------------------------- --- A reasoning API to chain permutation proofs and allow "zooming in" --- to localised reasoning. - -module PermutationReasoning where - - private - module Base = EqReasoning ↭-setoid - - open EqReasoning ↭-setoid public - hiding (step-≈; step-≈˘) - - infixr 2 step-↭ step-↭˘ step-swap step-prep - - step-↭ = Base.step-≈ - step-↭˘ = Base.step-≈˘ - - -- Skip reasoning on the first element - step-prep : ∀ x xs {ys zs : List A} → (x ∷ ys) IsRelatedTo zs → - xs ↭ ys → (x ∷ xs) IsRelatedTo zs - step-prep x xs rel xs↭ys = relTo (trans (prep x xs↭ys) (begin rel)) - - -- Skip reasoning about the first two elements - step-swap : ∀ x y xs {ys zs : List A} → (y ∷ x ∷ ys) IsRelatedTo zs → - xs ↭ ys → (x ∷ y ∷ xs) IsRelatedTo zs - step-swap x y xs rel xs↭ys = relTo (trans (swap x y xs↭ys) (begin rel)) - - syntax step-↭ x y↭z x↭y = x ↭⟨ x↭y ⟩ y↭z - syntax step-↭˘ x y↭z y↭x = x ↭˘⟨ y↭x ⟩ y↭z - syntax step-prep x xs y↭z x↭y = x ∷ xs <⟨ x↭y ⟩ y↭z - syntax step-swap x y xs y↭z x↭y = x ∷ y ∷ xs <<⟨ x↭y ⟩ y↭z +open import Data.List.Base using (List; []; _∷_) +open import Relation.Binary.Core using (Rel; _⇒_) +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Binary.Structures using (IsEquivalence) +open import Relation.Binary.Definitions using (Reflexive; Transitive) +open import Relation.Binary.PropositionalEquality.Core using (_≡_; refl) +import Relation.Binary.Reasoning.Setoid as EqReasoning +open import Relation.Binary.Reasoning.Syntax + +------------------------------------------------------------------------ +-- An inductive definition of permutation + +-- Note that one would expect that this would be defined in terms of +-- `Permutation.Setoid`. This is not currently the case as it involves +-- adding in a bunch of trivial `_≡_` proofs to the constructors which +-- a) adds noise and b) prevents easy access to the variables `x`, `y`. +-- This may be changed in future when a better solution is found. + +infix 3 _↭_ + +data _↭_ : Rel (List A) a where + refl : ∀ {xs} → xs ↭ xs + prep : ∀ {xs ys} x → xs ↭ ys → x ∷ xs ↭ x ∷ ys + swap : ∀ {xs ys} x y → xs ↭ ys → x ∷ y ∷ xs ↭ y ∷ x ∷ ys + trans : ∀ {xs ys zs} → xs ↭ ys → ys ↭ zs → xs ↭ zs + +------------------------------------------------------------------------ +-- _↭_ is an equivalence + +↭-reflexive : _≡_ ⇒ _↭_ +↭-reflexive refl = refl + +↭-refl : Reflexive _↭_ +↭-refl = refl + +↭-sym : ∀ {xs ys} → xs ↭ ys → ys ↭ xs +↭-sym refl = refl +↭-sym (prep x xs↭ys) = prep x (↭-sym xs↭ys) +↭-sym (swap x y xs↭ys) = swap y x (↭-sym xs↭ys) +↭-sym (trans xs↭ys ys↭zs) = trans (↭-sym ys↭zs) (↭-sym xs↭ys) + +-- A smart version of trans that avoids unnecessary `refl`s (see #1113). +↭-trans : Transitive _↭_ +↭-trans refl ρ₂ = ρ₂ +↭-trans ρ₁ refl = ρ₁ +↭-trans ρ₁ ρ₂ = trans ρ₁ ρ₂ + +↭-isEquivalence : IsEquivalence _↭_ +↭-isEquivalence = record + { refl = refl + ; sym = ↭-sym + ; trans = ↭-trans + } + +↭-setoid : Setoid _ _ +↭-setoid = record + { isEquivalence = ↭-isEquivalence + } + +------------------------------------------------------------------------ +-- A reasoning API to chain permutation proofs and allow "zooming in" +-- to localised reasoning. + +module PermutationReasoning where + + private module Base = EqReasoning ↭-setoid + + open Base public + hiding (step-≈; step-≈˘; step-≈-⟩; step-≈-⟨) + renaming (≈-go to ↭-go) + + open ↭-syntax _IsRelatedTo_ _IsRelatedTo_ ↭-go ↭-sym public + + -- Some extra combinators that allow us to skip certain elements + + infixr 2 step-swap step-prep + + -- Skip reasoning on the first element + step-prep : ∀ x xs {ys zs : List A} → (x ∷ ys) IsRelatedTo zs → + xs ↭ ys → (x ∷ xs) IsRelatedTo zs + step-prep x xs rel xs↭ys = relTo (trans (prep x xs↭ys) (begin rel)) + + -- Skip reasoning about the first two elements + step-swap : ∀ x y xs {ys zs : List A} → (y ∷ x ∷ ys) IsRelatedTo zs → + xs ↭ ys → (x ∷ y ∷ xs) IsRelatedTo zs + step-swap x y xs rel xs↭ys = relTo (trans (swap x y xs↭ys) (begin rel)) + + syntax step-prep x xs y↭z x↭y = x ∷ xs <⟨ x↭y ⟩ y↭z + syntax step-swap x y xs y↭z x↭y = x ∷ y ∷ xs <<⟨ x↭y ⟩ y↭z \ No newline at end of file diff --git a/Data.List.Relation.Binary.Pointwise.Base.html b/Data.List.Relation.Binary.Pointwise.Base.html index 1f5c2dc2..83fa8724 100644 --- a/Data.List.Relation.Binary.Pointwise.Base.html +++ b/Data.List.Relation.Binary.Pointwise.Base.html @@ -9,54 +9,54 @@ module Data.List.Relation.Binary.Pointwise.Base where -open import Data.Product using (_×_; <_,_>) -open import Data.List.Base using (List; []; _∷_) -open import Level -open import Relation.Binary.Core using (REL; _⇒_) - -private - variable - a b c ℓ : Level - A : Set a - B : Set b - x y : A - xs ys : List A - R S : REL A B ℓ - ------------------------------------------------------------------------- --- Definition ------------------------------------------------------------------------- - -infixr 5 _∷_ - -data Pointwise {A : Set a} {B : Set b} (R : REL A B ℓ) - : List A → List B → Set (a ⊔ b ⊔ ℓ) where - [] : Pointwise R [] [] - _∷_ : (x∼y : R x y) (xs∼ys : Pointwise R xs ys) → - Pointwise R (x ∷ xs) (y ∷ ys) - ------------------------------------------------------------------------- --- Operations ------------------------------------------------------------------------- - -head : Pointwise R (x ∷ xs) (y ∷ ys) → R x y -head (x∼y ∷ xs∼ys) = x∼y - -tail : Pointwise R (x ∷ xs) (y ∷ ys) → Pointwise R xs ys -tail (x∼y ∷ xs∼ys) = xs∼ys - -uncons : Pointwise R (x ∷ xs) (y ∷ ys) → R x y × Pointwise R xs ys -uncons = < head , tail > - -rec : ∀ (P : ∀ {xs ys} → Pointwise R xs ys → Set c) → - (∀ {x y xs ys} {Rxsys : Pointwise R xs ys} → - (Rxy : R x y) → P Rxsys → P (Rxy ∷ Rxsys)) → - P [] → - ∀ {xs ys} (Rxsys : Pointwise R xs ys) → P Rxsys -rec P c n [] = n -rec P c n (Rxy ∷ Rxsys) = c Rxy (rec P c n Rxsys) - -map : R ⇒ S → Pointwise R ⇒ Pointwise S -map R⇒S [] = [] -map R⇒S (Rxy ∷ Rxsys) = R⇒S Rxy ∷ map R⇒S Rxsys +open import Data.Product.Base using (_×_; <_,_>) +open import Data.List.Base using (List; []; _∷_) +open import Level using (Level; _⊔_) +open import Relation.Binary.Core using (REL; _⇒_) + +private + variable + a b c ℓ : Level + A : Set a + B : Set b + x y : A + xs ys : List A + R S : REL A B ℓ + +------------------------------------------------------------------------ +-- Definition +------------------------------------------------------------------------ + +infixr 5 _∷_ + +data Pointwise {A : Set a} {B : Set b} (R : REL A B ℓ) + : List A → List B → Set (a ⊔ b ⊔ ℓ) where + [] : Pointwise R [] [] + _∷_ : (x∼y : R x y) (xs∼ys : Pointwise R xs ys) → + Pointwise R (x ∷ xs) (y ∷ ys) + +------------------------------------------------------------------------ +-- Operations +------------------------------------------------------------------------ + +head : Pointwise R (x ∷ xs) (y ∷ ys) → R x y +head (x∼y ∷ xs∼ys) = x∼y + +tail : Pointwise R (x ∷ xs) (y ∷ ys) → Pointwise R xs ys +tail (x∼y ∷ xs∼ys) = xs∼ys + +uncons : Pointwise R (x ∷ xs) (y ∷ ys) → R x y × Pointwise R xs ys +uncons = < head , tail > + +rec : ∀ (P : ∀ {xs ys} → Pointwise R xs ys → Set c) → + (∀ {x y xs ys} {Rxsys : Pointwise R xs ys} → + (Rxy : R x y) → P Rxsys → P (Rxy ∷ Rxsys)) → + P [] → + ∀ {xs ys} (Rxsys : Pointwise R xs ys) → P Rxsys +rec P c n [] = n +rec P c n (Rxy ∷ Rxsys) = c Rxy (rec P c n Rxsys) + +map : R ⇒ S → Pointwise R ⇒ Pointwise S +map R⇒S [] = [] +map R⇒S (Rxy ∷ Rxsys) = R⇒S Rxy ∷ map R⇒S Rxsys \ No newline at end of file diff --git a/Data.List.Relation.Binary.Pointwise.Properties.html b/Data.List.Relation.Binary.Pointwise.Properties.html index cd6ec2fe..93d92b7d 100644 --- a/Data.List.Relation.Binary.Pointwise.Properties.html +++ b/Data.List.Relation.Binary.Pointwise.Properties.html @@ -9,71 +9,71 @@ module Data.List.Relation.Binary.Pointwise.Properties where -open import Data.Product using (_,_; uncurry) -open import Data.List.Base using (List; []; _∷_) -open import Level -open import Relation.Binary.Core using (REL; _⇒_) -open import Relation.Binary.Definitions -import Relation.Binary.PropositionalEquality as P -open import Relation.Nullary using (yes; no; _×-dec_) -import Relation.Nullary.Decidable as Dec - -open import Data.List.Relation.Binary.Pointwise.Base - -private - variable - a b ℓ : Level - A : Set a - B : Set b - R S T : REL A B ℓ - ------------------------------------------------------------------------- --- Relational properties ------------------------------------------------------------------------- - -reflexive : R ⇒ S → Pointwise R ⇒ Pointwise S -reflexive = map - -refl : Reflexive R → Reflexive (Pointwise R) -refl rfl {[]} = [] -refl rfl {x ∷ xs} = rfl ∷ refl rfl - -symmetric : Sym R S → Sym (Pointwise R) (Pointwise S) -symmetric sym [] = [] -symmetric sym (x∼y ∷ xs∼ys) = sym x∼y ∷ symmetric sym xs∼ys - -transitive : Trans R S T → - Trans (Pointwise R) (Pointwise S) (Pointwise T) -transitive trans [] [] = [] -transitive trans (x∼y ∷ xs∼ys) (y∼z ∷ ys∼zs) = - trans x∼y y∼z ∷ transitive trans xs∼ys ys∼zs - -antisymmetric : Antisym R S T → - Antisym (Pointwise R) (Pointwise S) (Pointwise T) -antisymmetric antisym [] [] = [] -antisymmetric antisym (x∼y ∷ xs∼ys) (y∼x ∷ ys∼xs) = - antisym x∼y y∼x ∷ antisymmetric antisym xs∼ys ys∼xs - -respʳ : R Respectsʳ S → (Pointwise R) Respectsʳ (Pointwise S) -respʳ resp [] [] = [] -respʳ resp (x≈y ∷ xs≈ys) (z∼x ∷ zs∼xs) = resp x≈y z∼x ∷ respʳ resp xs≈ys zs∼xs - -respˡ : R Respectsˡ S → (Pointwise R) Respectsˡ (Pointwise S) -respˡ resp [] [] = [] -respˡ resp (x≈y ∷ xs≈ys) (x∼z ∷ xs∼zs) = resp x≈y x∼z ∷ respˡ resp xs≈ys xs∼zs - -respects₂ : R Respects₂ S → (Pointwise R) Respects₂ (Pointwise S) -respects₂ (rʳ , rˡ) = respʳ rʳ , respˡ rˡ - -decidable : Decidable R → Decidable (Pointwise R) -decidable _ [] [] = yes [] -decidable _ [] (y ∷ ys) = no λ() -decidable _ (x ∷ xs) [] = no λ() -decidable R? (x ∷ xs) (y ∷ ys) = Dec.map′ (uncurry _∷_) uncons - (R? x y ×-dec decidable R? xs ys) - -irrelevant : Irrelevant R → Irrelevant (Pointwise R) -irrelevant irr [] [] = P.refl -irrelevant irr (r ∷ rs) (r₁ ∷ rs₁) = - P.cong₂ _∷_ (irr r r₁) (irrelevant irr rs rs₁) +open import Data.Product.Base using (_,_; uncurry) +open import Data.List.Base using (List; []; _∷_) +open import Level +open import Relation.Binary.Core using (REL; _⇒_) +open import Relation.Binary.Definitions +import Relation.Binary.PropositionalEquality.Core as P +open import Relation.Nullary using (yes; no; _×-dec_) +import Relation.Nullary.Decidable as Dec + +open import Data.List.Relation.Binary.Pointwise.Base + +private + variable + a b ℓ : Level + A : Set a + B : Set b + R S T : REL A B ℓ + +------------------------------------------------------------------------ +-- Relational properties +------------------------------------------------------------------------ + +reflexive : R ⇒ S → Pointwise R ⇒ Pointwise S +reflexive = map + +refl : Reflexive R → Reflexive (Pointwise R) +refl rfl {[]} = [] +refl rfl {x ∷ xs} = rfl ∷ refl rfl + +symmetric : Sym R S → Sym (Pointwise R) (Pointwise S) +symmetric sym [] = [] +symmetric sym (x∼y ∷ xs∼ys) = sym x∼y ∷ symmetric sym xs∼ys + +transitive : Trans R S T → + Trans (Pointwise R) (Pointwise S) (Pointwise T) +transitive trans [] [] = [] +transitive trans (x∼y ∷ xs∼ys) (y∼z ∷ ys∼zs) = + trans x∼y y∼z ∷ transitive trans xs∼ys ys∼zs + +antisymmetric : Antisym R S T → + Antisym (Pointwise R) (Pointwise S) (Pointwise T) +antisymmetric antisym [] [] = [] +antisymmetric antisym (x∼y ∷ xs∼ys) (y∼x ∷ ys∼xs) = + antisym x∼y y∼x ∷ antisymmetric antisym xs∼ys ys∼xs + +respʳ : R Respectsʳ S → (Pointwise R) Respectsʳ (Pointwise S) +respʳ resp [] [] = [] +respʳ resp (x≈y ∷ xs≈ys) (z∼x ∷ zs∼xs) = resp x≈y z∼x ∷ respʳ resp xs≈ys zs∼xs + +respˡ : R Respectsˡ S → (Pointwise R) Respectsˡ (Pointwise S) +respˡ resp [] [] = [] +respˡ resp (x≈y ∷ xs≈ys) (x∼z ∷ xs∼zs) = resp x≈y x∼z ∷ respˡ resp xs≈ys xs∼zs + +respects₂ : R Respects₂ S → (Pointwise R) Respects₂ (Pointwise S) +respects₂ (rʳ , rˡ) = respʳ rʳ , respˡ rˡ + +decidable : Decidable R → Decidable (Pointwise R) +decidable _ [] [] = yes [] +decidable _ [] (y ∷ ys) = no λ() +decidable _ (x ∷ xs) [] = no λ() +decidable R? (x ∷ xs) (y ∷ ys) = Dec.map′ (uncurry _∷_) uncons + (R? x y ×-dec decidable R? xs ys) + +irrelevant : Irrelevant R → Irrelevant (Pointwise R) +irrelevant irr [] [] = P.refl +irrelevant irr (r ∷ rs) (r₁ ∷ rs₁) = + P.cong₂ _∷_ (irr r r₁) (irrelevant irr rs rs₁) \ No newline at end of file diff --git a/Data.List.Relation.Binary.Pointwise.html b/Data.List.Relation.Binary.Pointwise.html index b9de3e38..5f62444b 100644 --- a/Data.List.Relation.Binary.Pointwise.html +++ b/Data.List.Relation.Binary.Pointwise.html @@ -11,266 +11,269 @@ open import Algebra.Core using (Op₂) open import Function.Base -open import Function.Inverse using (Inverse) +open import Function.Bundles using (Inverse) open import Data.Bool.Base using (true; false) -open import Data.Product hiding (map) -open import Data.List.Base as List hiding (map; head; tail; uncons) -open import Data.List.Properties using (≡-dec; length-++) -open import Data.List.Relation.Unary.All as All using (All; []; _∷_) -open import Data.List.Relation.Unary.AllPairs using (AllPairs; []; _∷_) -open import Data.List.Relation.Unary.Any using (Any; here; there) -open import Data.Fin.Base using (Fin; toℕ; cast) renaming (zero to fzero; suc to fsuc) -open import Data.Nat.Base using (ℕ; zero; suc) -open import Data.Nat.Properties -open import Level -open import Relation.Nullary hiding (Irrelevant) -import Relation.Nullary.Decidable as Dec using (map′) -open import Relation.Unary as U using (Pred) -open import Relation.Binary renaming (Rel to Rel₂) -open import Relation.Binary.PropositionalEquality as P using (_≡_) - -private - variable - a b c d p q ℓ ℓ₁ ℓ₂ : Level - A B C D : Set d - x y z : A - ws xs ys zs : List A - R S T : REL A B ℓ - ------------------------------------------------------------------------- --- Re-exporting the definition and basic operations ------------------------------------------------------------------------- - -open import Data.List.Relation.Binary.Pointwise.Base public -open import Data.List.Relation.Binary.Pointwise.Properties public - ------------------------------------------------------------------------- --- Structures - -isEquivalence : IsEquivalence R → IsEquivalence (Pointwise R) -isEquivalence eq = record - { refl = refl Eq.refl - ; sym = symmetric Eq.sym - ; trans = transitive Eq.trans - } where module Eq = IsEquivalence eq - -isDecEquivalence : IsDecEquivalence R → IsDecEquivalence (Pointwise R) -isDecEquivalence eq = record - { isEquivalence = isEquivalence DE.isEquivalence - ; _≟_ = decidable DE._≟_ - } where module DE = IsDecEquivalence eq - -isPreorder : IsPreorder R S → IsPreorder (Pointwise R) (Pointwise S) -isPreorder pre = record - { isEquivalence = isEquivalence Pre.isEquivalence - ; reflexive = reflexive Pre.reflexive - ; trans = transitive Pre.trans - } where module Pre = IsPreorder pre - -isPartialOrder : IsPartialOrder R S → - IsPartialOrder (Pointwise R) (Pointwise S) -isPartialOrder po = record - { isPreorder = isPreorder PO.isPreorder - ; antisym = antisymmetric PO.antisym - } where module PO = IsPartialOrder po - ------------------------------------------------------------------------- --- Bundles - -setoid : Setoid a ℓ → Setoid a (a ⊔ ℓ) -setoid s = record - { isEquivalence = isEquivalence (Setoid.isEquivalence s) - } - -decSetoid : DecSetoid a ℓ → DecSetoid a (a ⊔ ℓ) -decSetoid d = record - { isDecEquivalence = isDecEquivalence (DecSetoid.isDecEquivalence d) - } - -preorder : Preorder a ℓ₁ ℓ₂ → Preorder _ _ _ -preorder p = record - { isPreorder = isPreorder (Preorder.isPreorder p) - } - -poset : Poset a ℓ₁ ℓ₂ → Poset _ _ _ -poset p = record - { isPartialOrder = isPartialOrder (Poset.isPartialOrder p) - } - ------------------------------------------------------------------------- --- Relationships to other list predicates ------------------------------------------------------------------------- - -All-resp-Pointwise : ∀ {P : Pred A p} → P Respects R → - (All P) Respects (Pointwise R) -All-resp-Pointwise resp [] [] = [] -All-resp-Pointwise resp (x∼y ∷ xs) (px ∷ pxs) = - resp x∼y px ∷ All-resp-Pointwise resp xs pxs - -Any-resp-Pointwise : ∀ {P : Pred A p} → P Respects R → - (Any P) Respects (Pointwise R) -Any-resp-Pointwise resp (x∼y ∷ xs) (here px) = here (resp x∼y px) -Any-resp-Pointwise resp (x∼y ∷ xs) (there pxs) = - there (Any-resp-Pointwise resp xs pxs) - -AllPairs-resp-Pointwise : R Respects₂ S → - (AllPairs R) Respects (Pointwise S) -AllPairs-resp-Pointwise _ [] [] = [] -AllPairs-resp-Pointwise resp@(respₗ , respᵣ) (x∼y ∷ xs) (px ∷ pxs) = - All-resp-Pointwise respₗ xs (All.map (respᵣ x∼y) px) ∷ - (AllPairs-resp-Pointwise resp xs pxs) - ------------------------------------------------------------------------- --- Relationship to functions over lists ------------------------------------------------------------------------- --- length - -Pointwise-length : Pointwise R xs ys → length xs ≡ length ys -Pointwise-length [] = P.refl -Pointwise-length (x∼y ∷ xs∼ys) = P.cong ℕ.suc (Pointwise-length xs∼ys) - ------------------------------------------------------------------------- --- tabulate - -tabulate⁺ : ∀ {n} {f : Fin n → A} {g : Fin n → B} → - (∀ i → R (f i) (g i)) → Pointwise R (tabulate f) (tabulate g) -tabulate⁺ {n = zero} f∼g = [] -tabulate⁺ {n = suc n} f∼g = f∼g fzero ∷ tabulate⁺ (f∼g ∘ fsuc) - -tabulate⁻ : ∀ {n} {f : Fin n → A} {g : Fin n → B} → - Pointwise R (tabulate f) (tabulate g) → (∀ i → R (f i) (g i)) -tabulate⁻ {n = suc n} (x∼y ∷ xs∼ys) fzero = x∼y -tabulate⁻ {n = suc n} (x∼y ∷ xs∼ys) (fsuc i) = tabulate⁻ xs∼ys i - ------------------------------------------------------------------------- --- _++_ - -++⁺ : Pointwise R ws xs → Pointwise R ys zs → - Pointwise R (ws ++ ys) (xs ++ zs) -++⁺ [] ys∼zs = ys∼zs -++⁺ (w∼x ∷ ws∼xs) ys∼zs = w∼x ∷ ++⁺ ws∼xs ys∼zs - -++-cancelˡ : ∀ xs → Pointwise R (xs ++ ys) (xs ++ zs) → Pointwise R ys zs -++-cancelˡ [] ys∼zs = ys∼zs -++-cancelˡ (x ∷ xs) (_ ∷ xs++ys∼xs++zs) = ++-cancelˡ xs xs++ys∼xs++zs - -++-cancelʳ : ∀ ys zs → Pointwise R (ys ++ xs) (zs ++ xs) → Pointwise R ys zs -++-cancelʳ [] [] _ = [] -++-cancelʳ (y ∷ ys) (z ∷ zs) (y∼z ∷ ys∼zs) = y∼z ∷ (++-cancelʳ ys zs ys∼zs) --- Impossible cases -++-cancelʳ {xs = xs} [] (z ∷ zs) eq = - contradiction (P.trans (Pointwise-length eq) (length-++ (z ∷ zs))) (m≢1+n+m (length xs)) -++-cancelʳ {xs = xs} (y ∷ ys) [] eq = - contradiction (P.trans (P.sym (length-++ (y ∷ ys))) (Pointwise-length eq)) (m≢1+n+m (length xs) ∘ P.sym) - ------------------------------------------------------------------------- --- concat - -concat⁺ : ∀ {xss yss} → Pointwise (Pointwise R) xss yss → - Pointwise R (concat xss) (concat yss) -concat⁺ [] = [] -concat⁺ (xs∼ys ∷ xss∼yss) = ++⁺ xs∼ys (concat⁺ xss∼yss) - ------------------------------------------------------------------------- --- reverse - -reverseAcc⁺ : Pointwise R ws xs → Pointwise R ys zs → - Pointwise R (reverseAcc ws ys) (reverseAcc xs zs) -reverseAcc⁺ rs′ [] = rs′ -reverseAcc⁺ rs′ (r ∷ rs) = reverseAcc⁺ (r ∷ rs′) rs - -ʳ++⁺ : Pointwise R ws xs → Pointwise R ys zs → - Pointwise R (ws ʳ++ ys) (xs ʳ++ zs) -ʳ++⁺ rs rs′ = reverseAcc⁺ rs′ rs - -reverse⁺ : Pointwise R xs ys → Pointwise R (reverse xs) (reverse ys) -reverse⁺ = reverseAcc⁺ [] - ------------------------------------------------------------------------- --- map - -map⁺ : ∀ (f : A → C) (g : B → D) → - Pointwise (λ a b → R (f a) (g b)) xs ys → - Pointwise R (List.map f xs) (List.map g ys) -map⁺ f g [] = [] -map⁺ f g (r ∷ rs) = r ∷ map⁺ f g rs - -map⁻ : ∀ (f : A → C) (g : B → D) → - Pointwise R (List.map f xs) (List.map g ys) → - Pointwise (λ a b → R (f a) (g b)) xs ys -map⁻ {xs = []} {[]} f g [] = [] -map⁻ {xs = _ ∷ _} {_ ∷ _} f g (r ∷ rs) = r ∷ map⁻ f g rs - ------------------------------------------------------------------------- --- foldr - -foldr⁺ : ∀ {_•_ : Op₂ A} {_◦_ : Op₂ B} → - (∀ {w x y z} → R w x → R y z → R (w • y) (x ◦ z)) → - ∀ {e f} → R e f → Pointwise R xs ys → - R (foldr _•_ e xs) (foldr _◦_ f ys) -foldr⁺ _ e~f [] = e~f -foldr⁺ pres e~f (x~y ∷ xs~ys) = pres x~y (foldr⁺ pres e~f xs~ys) - ------------------------------------------------------------------------- --- filter - -module _ {P : Pred A p} {Q : Pred B q} - (P? : U.Decidable P) (Q? : U.Decidable Q) - (P⇒Q : ∀ {a b} → R a b → P a → Q b) - (Q⇒P : ∀ {a b} → R a b → Q b → P a) - where - - filter⁺ : Pointwise R xs ys → - Pointwise R (filter P? xs) (filter Q? ys) - filter⁺ [] = [] - filter⁺ {x ∷ _} {y ∷ _} (r ∷ rs) with P? x | Q? y - ... | true because _ | true because _ = r ∷ filter⁺ rs - ... | false because _ | false because _ = filter⁺ rs - ... | yes p | no ¬q = contradiction (P⇒Q r p) ¬q - ... | no ¬p | yes q = contradiction (Q⇒P r q) ¬p - ------------------------------------------------------------------------- --- replicate - -replicate⁺ : R x y → ∀ n → Pointwise R (replicate n x) (replicate n y) -replicate⁺ r 0 = [] -replicate⁺ r (suc n) = r ∷ replicate⁺ r n - ------------------------------------------------------------------------- --- lookup - -lookup⁻ : length xs ≡ length ys → - (∀ {i j} → toℕ i ≡ toℕ j → R (lookup xs i) (lookup ys j)) → - Pointwise R xs ys -lookup⁻ {xs = []} {ys = []} _ _ = [] -lookup⁻ {xs = _ ∷ _} {ys = _ ∷ _} |xs|≡|ys| eq = eq {fzero} P.refl ∷ - lookup⁻ (suc-injective |xs|≡|ys|) (eq ∘ P.cong ℕ.suc) - -lookup⁺ : ∀ (Rxys : Pointwise R xs ys) → - ∀ i → (let j = cast (Pointwise-length Rxys) i) → - R (lookup xs i) (lookup ys j) -lookup⁺ (Rxy ∷ _) fzero = Rxy -lookup⁺ (_ ∷ Rxys) (fsuc i) = lookup⁺ Rxys i - ------------------------------------------------------------------------- --- Properties of propositional pointwise ------------------------------------------------------------------------- - -Pointwise-≡⇒≡ : Pointwise {A = A} _≡_ ⇒ _≡_ -Pointwise-≡⇒≡ [] = P.refl -Pointwise-≡⇒≡ (P.refl ∷ xs∼ys) with Pointwise-≡⇒≡ xs∼ys -... | P.refl = P.refl - -≡⇒Pointwise-≡ : _≡_ ⇒ Pointwise {A = A} _≡_ -≡⇒Pointwise-≡ P.refl = refl P.refl - -Pointwise-≡↔≡ : Inverse (setoid (P.setoid A)) (P.setoid (List A)) -Pointwise-≡↔≡ = record - { to = record { _⟨$⟩_ = id; cong = Pointwise-≡⇒≡ } - ; from = record { _⟨$⟩_ = id; cong = ≡⇒Pointwise-≡ } - ; inverse-of = record - { left-inverse-of = λ _ → refl P.refl - ; right-inverse-of = λ _ → P.refl - } - } +open import Data.Product.Base hiding (map) +open import Data.List.Base as List hiding (map; head; tail; uncons) +open import Data.List.Properties using (≡-dec; length-++) +open import Data.List.Relation.Unary.All as All using (All; []; _∷_) +open import Data.List.Relation.Unary.AllPairs using (AllPairs; []; _∷_) +open import Data.List.Relation.Unary.Any using (Any; here; there) +open import Data.Fin.Base using (Fin; toℕ; cast) renaming (zero to fzero; suc to fsuc) +open import Data.Nat.Base using (ℕ; zero; suc) +open import Data.Nat.Properties +open import Level +open import Relation.Nullary hiding (Irrelevant) +import Relation.Nullary.Decidable as Dec using (map′) +open import Relation.Unary as U using (Pred) +open import Relation.Binary.Core renaming (Rel to Rel₂) +open import Relation.Binary.Definitions using (_Respects_; _Respects₂_) +open import Relation.Binary.Bundles using (Setoid; DecSetoid; Preorder; Poset) +open import Relation.Binary.Structures using (IsEquivalence; IsDecEquivalence; IsPartialOrder; IsPreorder) +open import Relation.Binary.PropositionalEquality.Core as P using (_≡_) +import Relation.Binary.PropositionalEquality.Properties as P + +private + variable + a b c d p q ℓ ℓ₁ ℓ₂ : Level + A B C D : Set d + x y z : A + ws xs ys zs : List A + R S T : REL A B ℓ + +------------------------------------------------------------------------ +-- Re-exporting the definition and basic operations +------------------------------------------------------------------------ + +open import Data.List.Relation.Binary.Pointwise.Base public +open import Data.List.Relation.Binary.Pointwise.Properties public + +------------------------------------------------------------------------ +-- Structures + +isEquivalence : IsEquivalence R → IsEquivalence (Pointwise R) +isEquivalence eq = record + { refl = refl Eq.refl + ; sym = symmetric Eq.sym + ; trans = transitive Eq.trans + } where module Eq = IsEquivalence eq + +isDecEquivalence : IsDecEquivalence R → IsDecEquivalence (Pointwise R) +isDecEquivalence eq = record + { isEquivalence = isEquivalence DE.isEquivalence + ; _≟_ = decidable DE._≟_ + } where module DE = IsDecEquivalence eq + +isPreorder : IsPreorder R S → IsPreorder (Pointwise R) (Pointwise S) +isPreorder pre = record + { isEquivalence = isEquivalence Pre.isEquivalence + ; reflexive = reflexive Pre.reflexive + ; trans = transitive Pre.trans + } where module Pre = IsPreorder pre + +isPartialOrder : IsPartialOrder R S → + IsPartialOrder (Pointwise R) (Pointwise S) +isPartialOrder po = record + { isPreorder = isPreorder PO.isPreorder + ; antisym = antisymmetric PO.antisym + } where module PO = IsPartialOrder po + +------------------------------------------------------------------------ +-- Bundles + +setoid : Setoid a ℓ → Setoid a (a ⊔ ℓ) +setoid s = record + { isEquivalence = isEquivalence (Setoid.isEquivalence s) + } + +decSetoid : DecSetoid a ℓ → DecSetoid a (a ⊔ ℓ) +decSetoid d = record + { isDecEquivalence = isDecEquivalence (DecSetoid.isDecEquivalence d) + } + +preorder : Preorder a ℓ₁ ℓ₂ → Preorder _ _ _ +preorder p = record + { isPreorder = isPreorder (Preorder.isPreorder p) + } + +poset : Poset a ℓ₁ ℓ₂ → Poset _ _ _ +poset p = record + { isPartialOrder = isPartialOrder (Poset.isPartialOrder p) + } + +------------------------------------------------------------------------ +-- Relationships to other list predicates +------------------------------------------------------------------------ + +All-resp-Pointwise : ∀ {P : Pred A p} → P Respects R → + (All P) Respects (Pointwise R) +All-resp-Pointwise resp [] [] = [] +All-resp-Pointwise resp (x∼y ∷ xs) (px ∷ pxs) = + resp x∼y px ∷ All-resp-Pointwise resp xs pxs + +Any-resp-Pointwise : ∀ {P : Pred A p} → P Respects R → + (Any P) Respects (Pointwise R) +Any-resp-Pointwise resp (x∼y ∷ xs) (here px) = here (resp x∼y px) +Any-resp-Pointwise resp (x∼y ∷ xs) (there pxs) = + there (Any-resp-Pointwise resp xs pxs) + +AllPairs-resp-Pointwise : R Respects₂ S → + (AllPairs R) Respects (Pointwise S) +AllPairs-resp-Pointwise _ [] [] = [] +AllPairs-resp-Pointwise resp@(respₗ , respᵣ) (x∼y ∷ xs) (px ∷ pxs) = + All-resp-Pointwise respₗ xs (All.map (respᵣ x∼y) px) ∷ + (AllPairs-resp-Pointwise resp xs pxs) + +------------------------------------------------------------------------ +-- Relationship to functions over lists +------------------------------------------------------------------------ +-- length + +Pointwise-length : Pointwise R xs ys → length xs ≡ length ys +Pointwise-length [] = P.refl +Pointwise-length (x∼y ∷ xs∼ys) = P.cong ℕ.suc (Pointwise-length xs∼ys) + +------------------------------------------------------------------------ +-- tabulate + +tabulate⁺ : ∀ {n} {f : Fin n → A} {g : Fin n → B} → + (∀ i → R (f i) (g i)) → Pointwise R (tabulate f) (tabulate g) +tabulate⁺ {n = zero} f∼g = [] +tabulate⁺ {n = suc n} f∼g = f∼g fzero ∷ tabulate⁺ (f∼g ∘ fsuc) + +tabulate⁻ : ∀ {n} {f : Fin n → A} {g : Fin n → B} → + Pointwise R (tabulate f) (tabulate g) → (∀ i → R (f i) (g i)) +tabulate⁻ {n = suc n} (x∼y ∷ xs∼ys) fzero = x∼y +tabulate⁻ {n = suc n} (x∼y ∷ xs∼ys) (fsuc i) = tabulate⁻ xs∼ys i + +------------------------------------------------------------------------ +-- _++_ + +++⁺ : Pointwise R ws xs → Pointwise R ys zs → + Pointwise R (ws ++ ys) (xs ++ zs) +++⁺ [] ys∼zs = ys∼zs +++⁺ (w∼x ∷ ws∼xs) ys∼zs = w∼x ∷ ++⁺ ws∼xs ys∼zs + +++-cancelˡ : ∀ xs → Pointwise R (xs ++ ys) (xs ++ zs) → Pointwise R ys zs +++-cancelˡ [] ys∼zs = ys∼zs +++-cancelˡ (x ∷ xs) (_ ∷ xs++ys∼xs++zs) = ++-cancelˡ xs xs++ys∼xs++zs + +++-cancelʳ : ∀ ys zs → Pointwise R (ys ++ xs) (zs ++ xs) → Pointwise R ys zs +++-cancelʳ [] [] _ = [] +++-cancelʳ (y ∷ ys) (z ∷ zs) (y∼z ∷ ys∼zs) = y∼z ∷ (++-cancelʳ ys zs ys∼zs) +-- Impossible cases +++-cancelʳ {xs = xs} [] (z ∷ zs) eq = + contradiction (P.trans (Pointwise-length eq) (length-++ (z ∷ zs))) (m≢1+n+m (length xs)) +++-cancelʳ {xs = xs} (y ∷ ys) [] eq = + contradiction (P.trans (P.sym (length-++ (y ∷ ys))) (Pointwise-length eq)) (m≢1+n+m (length xs) ∘ P.sym) + +------------------------------------------------------------------------ +-- concat + +concat⁺ : ∀ {xss yss} → Pointwise (Pointwise R) xss yss → + Pointwise R (concat xss) (concat yss) +concat⁺ [] = [] +concat⁺ (xs∼ys ∷ xss∼yss) = ++⁺ xs∼ys (concat⁺ xss∼yss) + +------------------------------------------------------------------------ +-- reverse + +reverseAcc⁺ : Pointwise R ws xs → Pointwise R ys zs → + Pointwise R (reverseAcc ws ys) (reverseAcc xs zs) +reverseAcc⁺ rs′ [] = rs′ +reverseAcc⁺ rs′ (r ∷ rs) = reverseAcc⁺ (r ∷ rs′) rs + +ʳ++⁺ : Pointwise R ws xs → Pointwise R ys zs → + Pointwise R (ws ʳ++ ys) (xs ʳ++ zs) +ʳ++⁺ rs rs′ = reverseAcc⁺ rs′ rs + +reverse⁺ : Pointwise R xs ys → Pointwise R (reverse xs) (reverse ys) +reverse⁺ = reverseAcc⁺ [] + +------------------------------------------------------------------------ +-- map + +map⁺ : ∀ (f : A → C) (g : B → D) → + Pointwise (λ a b → R (f a) (g b)) xs ys → + Pointwise R (List.map f xs) (List.map g ys) +map⁺ f g [] = [] +map⁺ f g (r ∷ rs) = r ∷ map⁺ f g rs + +map⁻ : ∀ (f : A → C) (g : B → D) → + Pointwise R (List.map f xs) (List.map g ys) → + Pointwise (λ a b → R (f a) (g b)) xs ys +map⁻ {xs = []} {[]} f g [] = [] +map⁻ {xs = _ ∷ _} {_ ∷ _} f g (r ∷ rs) = r ∷ map⁻ f g rs + +------------------------------------------------------------------------ +-- foldr + +foldr⁺ : ∀ {_•_ : Op₂ A} {_◦_ : Op₂ B} → + (∀ {w x y z} → R w x → R y z → R (w • y) (x ◦ z)) → + ∀ {e f} → R e f → Pointwise R xs ys → + R (foldr _•_ e xs) (foldr _◦_ f ys) +foldr⁺ _ e~f [] = e~f +foldr⁺ pres e~f (x~y ∷ xs~ys) = pres x~y (foldr⁺ pres e~f xs~ys) + +------------------------------------------------------------------------ +-- filter + +module _ {P : Pred A p} {Q : Pred B q} + (P? : U.Decidable P) (Q? : U.Decidable Q) + (P⇒Q : ∀ {a b} → R a b → P a → Q b) + (Q⇒P : ∀ {a b} → R a b → Q b → P a) + where + + filter⁺ : Pointwise R xs ys → + Pointwise R (filter P? xs) (filter Q? ys) + filter⁺ [] = [] + filter⁺ {x ∷ _} {y ∷ _} (r ∷ rs) with P? x | Q? y + ... | true because _ | true because _ = r ∷ filter⁺ rs + ... | false because _ | false because _ = filter⁺ rs + ... | yes p | no ¬q = contradiction (P⇒Q r p) ¬q + ... | no ¬p | yes q = contradiction (Q⇒P r q) ¬p + +------------------------------------------------------------------------ +-- replicate + +replicate⁺ : R x y → ∀ n → Pointwise R (replicate n x) (replicate n y) +replicate⁺ r 0 = [] +replicate⁺ r (suc n) = r ∷ replicate⁺ r n + +------------------------------------------------------------------------ +-- lookup + +lookup⁻ : length xs ≡ length ys → + (∀ {i j} → toℕ i ≡ toℕ j → R (lookup xs i) (lookup ys j)) → + Pointwise R xs ys +lookup⁻ {xs = []} {ys = []} _ _ = [] +lookup⁻ {xs = _ ∷ _} {ys = _ ∷ _} |xs|≡|ys| eq = eq {fzero} P.refl ∷ + lookup⁻ (suc-injective |xs|≡|ys|) (eq ∘ P.cong ℕ.suc) + +lookup⁺ : ∀ (Rxys : Pointwise R xs ys) → + ∀ i → (let j = cast (Pointwise-length Rxys) i) → + R (lookup xs i) (lookup ys j) +lookup⁺ (Rxy ∷ _) fzero = Rxy +lookup⁺ (_ ∷ Rxys) (fsuc i) = lookup⁺ Rxys i + +------------------------------------------------------------------------ +-- Properties of propositional pointwise +------------------------------------------------------------------------ + +Pointwise-≡⇒≡ : Pointwise {A = A} _≡_ ⇒ _≡_ +Pointwise-≡⇒≡ [] = P.refl +Pointwise-≡⇒≡ (P.refl ∷ xs∼ys) with Pointwise-≡⇒≡ xs∼ys +... | P.refl = P.refl + +≡⇒Pointwise-≡ : _≡_ ⇒ Pointwise {A = A} _≡_ +≡⇒Pointwise-≡ P.refl = refl P.refl + +Pointwise-≡↔≡ : Inverse (setoid (P.setoid A)) (P.setoid (List A)) +Pointwise-≡↔≡ = record + { to = id + ; from = id + ; to-cong = Pointwise-≡⇒≡ + ; from-cong = ≡⇒Pointwise-≡ + ; inverse = Pointwise-≡⇒≡ , ≡⇒Pointwise-≡ + } \ No newline at end of file diff --git a/Data.List.Relation.Binary.Sublist.Heterogeneous.Core.html b/Data.List.Relation.Binary.Sublist.Heterogeneous.Core.html index 03875ad1..dad70e5a 100644 --- a/Data.List.Relation.Binary.Sublist.Heterogeneous.Core.html +++ b/Data.List.Relation.Binary.Sublist.Heterogeneous.Core.html @@ -14,19 +14,19 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary using (REL) +open import Relation.Binary.Core using (REL) -module Data.List.Relation.Binary.Sublist.Heterogeneous.Core - {a b r} {A : Set a} {B : Set b} (R : REL A B r) - where +module Data.List.Relation.Binary.Sublist.Heterogeneous.Core + {a b r} {A : Set a} {B : Set b} (R : REL A B r) + where -open import Level using (_⊔_) -open import Data.List.Base using (List; []; _∷_) +open import Level using (_⊔_) +open import Data.List.Base using (List; []; _∷_) -infixr 5 _∷_ _∷ʳ_ +infixr 5 _∷_ _∷ʳ_ -data Sublist : REL (List A) (List B) (a ⊔ b ⊔ r) where - [] : Sublist [] [] - _∷ʳ_ : ∀ {xs ys} → ∀ y → Sublist xs ys → Sublist xs (y ∷ ys) - _∷_ : ∀ {x xs y ys} → R x y → Sublist xs ys → Sublist (x ∷ xs) (y ∷ ys) +data Sublist : REL (List A) (List B) (a ⊔ b ⊔ r) where + [] : Sublist [] [] + _∷ʳ_ : ∀ {xs ys} → ∀ y → Sublist xs ys → Sublist xs (y ∷ ys) + _∷_ : ∀ {x xs y ys} → R x y → Sublist xs ys → Sublist (x ∷ xs) (y ∷ ys) \ No newline at end of file diff --git a/Data.List.Relation.Binary.Sublist.Heterogeneous.Properties.html b/Data.List.Relation.Binary.Sublist.Heterogeneous.Properties.html index 3674d5b0..a08b2876 100644 --- a/Data.List.Relation.Binary.Sublist.Heterogeneous.Properties.html +++ b/Data.List.Relation.Binary.Sublist.Heterogeneous.Properties.html @@ -1,713 +1,718 @@ -Data.List.Relation.Binary.Sublist.Heterogeneous.Properties
-----------------------------------------------------------------------
--- The Agda standard library
---
--- Properties of the heterogeneous sublist relation
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-module Data.List.Relation.Binary.Sublist.Heterogeneous.Properties where
-
-open import Level
-
-open import Data.Bool.Base using (true; false)
-open import Data.Empty
-open import Data.List.Relation.Unary.All using (Null; []; _∷_)
-open import Data.List.Relation.Unary.Any using (Any; here; there)
-open import Data.List.Base as List hiding (map; _∷ʳ_)
-import Data.List.Properties as Lₚ
-open import Data.List.Relation.Unary.Any.Properties
-  using (here-injective; there-injective)
-open import Data.List.Relation.Binary.Pointwise as Pw using (Pointwise; []; _∷_)
-open import Data.List.Relation.Binary.Sublist.Heterogeneous
-
-open import Data.Maybe.Relation.Unary.All as MAll using (nothing; just)
-open import Data.Nat.Base using (ℕ; _≤_; _≥_); open ℕ; open _≤_
-import Data.Nat.Properties as ℕₚ
-open import Data.Product using (∃₂; _×_; _,_; <_,_>; proj₂; uncurry)
-
-open import Function.Base
-open import Function.Bundles using (_⤖_; _⇔_ ; mk⤖; mk⇔)
-
-open import Relation.Nullary.Reflects using (invert)
-open import Relation.Nullary using (Dec; does; _because_; yes; no; ¬_)
-open import Relation.Nullary.Decidable as Dec using (¬?)
-open import Relation.Unary as U using (Pred)
-open import Relation.Binary hiding (_⇔_)
-open import Relation.Binary.PropositionalEquality as P using (_≡_)
-
-------------------------------------------------------------------------
--- Injectivity of constructors
-
-module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where
-
-  ∷-injectiveˡ : ∀ {x y xs ys} {px qx : R x y} {pxs qxs : Sublist R xs ys} →
-                 (Sublist R (x ∷ xs) (y ∷ ys) ∋ px ∷ pxs) ≡ (qx ∷ qxs) → px ≡ qx
-  ∷-injectiveˡ P.refl = P.refl
-
-  ∷-injectiveʳ : ∀ {x y xs ys} {px qx : R x y} {pxs qxs : Sublist R xs ys} →
-                 (Sublist R (x ∷ xs) (y ∷ ys) ∋ px ∷ pxs) ≡ (qx ∷ qxs) → pxs ≡ qxs
-  ∷-injectiveʳ P.refl = P.refl
-
-  ∷ʳ-injective : ∀ {y xs ys} {pxs qxs : Sublist R xs ys} →
-                 (Sublist R xs (y ∷ ys) ∋ y ∷ʳ pxs) ≡ (y ∷ʳ qxs) → pxs ≡ qxs
-  ∷ʳ-injective P.refl = P.refl
-
-module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where
-
-  length-mono-≤ : ∀ {as bs} → Sublist R as bs → length as ≤ length bs
-  length-mono-≤ []        = z≤n
-  length-mono-≤ (y ∷ʳ rs) = ℕₚ.m≤n⇒m≤1+n (length-mono-≤ rs)
-  length-mono-≤ (r ∷ rs)  = s≤s (length-mono-≤ rs)
-
-------------------------------------------------------------------------
--- Conversion to and from Pointwise (proto-reflexivity)
-
-  fromPointwise : Pointwise R ⇒ Sublist R
-  fromPointwise []       = []
-  fromPointwise (p ∷ ps) = p ∷ fromPointwise ps
-
-  toPointwise : ∀ {as bs} → length as ≡ length bs →
-                Sublist R as bs → Pointwise R as bs
-  toPointwise {bs = []}     eq []         = []
-  toPointwise {bs = b ∷ bs} eq (r ∷ rs)   = r ∷ toPointwise (ℕₚ.suc-injective eq) rs
-  toPointwise {bs = b ∷ bs} eq (b ∷ʳ rs) =
-    ⊥-elim $ ℕₚ.<-irrefl eq (s≤s (length-mono-≤ rs))
-
-------------------------------------------------------------------------
--- Various functions' outputs are sublists
-
--- These lemmas are generalisations of results of the form `f xs ⊆ xs`.
--- (where _⊆_ stands for Sublist R). If R is reflexive then we can indeed
--- obtain `f xs ⊆ xs` from `xs ⊆ ys → f xs ⊆ ys`. The other direction is
--- only true if R is both reflexive and transitive.
-
-module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where
-
-  tail-Sublist : ∀ {as bs} → Sublist R as bs →
-                 MAll.All (λ as → Sublist R as bs) (tail as)
-  tail-Sublist []        = nothing
-  tail-Sublist (b ∷ʳ ps) = MAll.map (b ∷ʳ_) (tail-Sublist ps)
-  tail-Sublist (p ∷ ps)  = just (_ ∷ʳ ps)
-
-  take-Sublist : ∀ {as bs} n → Sublist R as bs → Sublist R (take n as) bs
-  take-Sublist n       (y ∷ʳ rs) = y ∷ʳ take-Sublist n rs
-  take-Sublist zero    rs        = minimum _
-  take-Sublist (suc n) []        = []
-  take-Sublist (suc n) (r ∷ rs)  = r ∷ take-Sublist n rs
-
-  drop-Sublist : ∀ n → Sublist R ⇒ (Sublist R ∘′ drop n)
-  drop-Sublist n       (y ∷ʳ rs) = y ∷ʳ drop-Sublist n rs
-  drop-Sublist zero    rs        = rs
-  drop-Sublist (suc n) []        = []
-  drop-Sublist (suc n) (r ∷ rs)  = _ ∷ʳ drop-Sublist n rs
-
-module _ {a b r p} {A : Set a} {B : Set b}
-         {R : REL A B r} {P : Pred A p} (P? : U.Decidable P) where
-
-  takeWhile-Sublist : ∀ {as bs} → Sublist R as bs → Sublist R (takeWhile P? as) bs
-  takeWhile-Sublist []        = []
-  takeWhile-Sublist (y ∷ʳ rs) = y ∷ʳ takeWhile-Sublist rs
-  takeWhile-Sublist {a ∷ as} (r ∷ rs) with does (P? a)
-  ... | true  = r ∷ takeWhile-Sublist rs
-  ... | false = minimum _
-
-  dropWhile-Sublist : ∀ {as bs} → Sublist R as bs → Sublist R (dropWhile P? as) bs
-  dropWhile-Sublist []        = []
-  dropWhile-Sublist (y ∷ʳ rs) = y ∷ʳ dropWhile-Sublist rs
-  dropWhile-Sublist {a ∷ as} (r ∷ rs) with does (P? a)
-  ... | true  = _ ∷ʳ dropWhile-Sublist rs
-  ... | false = r ∷ rs
-
-  filter-Sublist : ∀ {as bs} → Sublist R as bs → Sublist R (filter P? as) bs
-  filter-Sublist []        = []
-  filter-Sublist (y ∷ʳ rs) = y ∷ʳ filter-Sublist rs
-  filter-Sublist {a ∷ as} (r ∷ rs) with does (P? a)
-  ... | true  = r ∷ filter-Sublist rs
-  ... | false = _ ∷ʳ filter-Sublist rs
-
-------------------------------------------------------------------------
--- Various functions are increasing wrt _⊆_
-
--- We write f⁺ for the proof that `xs ⊆ ys → f xs ⊆ f ys`
--- and f⁻ for the one that `f xs ⊆ f ys → xs ⊆ ys`.
-
-module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where
-
-------------------------------------------------------------------------
--- _∷_
-
-  ∷ˡ⁻ : ∀ {a as bs} → Sublist R (a ∷ as) bs → Sublist R as bs
-  ∷ˡ⁻ (y ∷ʳ rs) = y ∷ʳ ∷ˡ⁻ rs
-  ∷ˡ⁻ (r ∷  rs) = _ ∷ʳ rs
-
-  ∷ʳ⁻ : ∀ {a as b bs} → ¬ R a b → Sublist R (a ∷ as) (b ∷ bs) →
-        Sublist R (a ∷ as) bs
-  ∷ʳ⁻ ¬r (y ∷ʳ rs) = rs
-  ∷ʳ⁻ ¬r (r ∷  rs) = ⊥-elim (¬r r)
-
-  ∷⁻ : ∀ {a as b bs} → Sublist R (a ∷ as) (b ∷ bs) → Sublist R as bs
-  ∷⁻ (y ∷ʳ rs) = ∷ˡ⁻ rs
-  ∷⁻ (x ∷  rs) = rs
-
-module _ {a b c d r} {A : Set a} {B : Set b} {C : Set c} {D : Set d}
-         {R : REL C D r} where
-
-------------------------------------------------------------------------
--- map
-
-  map⁺ : ∀ {as bs} (f : A → C) (g : B → D) →
-         Sublist (λ a b → R (f a) (g b)) as bs →
-         Sublist R (List.map f as) (List.map g bs)
-  map⁺ f g []        = []
-  map⁺ f g (y ∷ʳ rs) = g y ∷ʳ map⁺ f g rs
-  map⁺ f g (r ∷ rs)  = r ∷ map⁺ f g rs
-
-  map⁻ : ∀ {as bs} (f : A → C) (g : B → D) →
-         Sublist R (List.map f as) (List.map g bs) →
-         Sublist (λ a b → R (f a) (g b)) as bs
-  map⁻ {[]}     {bs}     f g rs        = minimum _
-  map⁻ {a ∷ as} {b ∷ bs} f g (_ ∷ʳ rs) = b ∷ʳ map⁻ f g rs
-  map⁻ {a ∷ as} {b ∷ bs} f g (r ∷ rs)  = r ∷ map⁻ f g rs
-
-
-module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where
-
-------------------------------------------------------------------------
--- _++_
-
-  ++⁺ : ∀ {as bs cs ds} → Sublist R as bs → Sublist R cs ds →
-        Sublist R (as ++ cs) (bs ++ ds)
-  ++⁺ []         cds = cds
-  ++⁺ (y ∷ʳ abs) cds = y ∷ʳ ++⁺ abs cds
-  ++⁺ (ab ∷ abs) cds = ab ∷ ++⁺ abs cds
-
-  ++⁻ : ∀ {as bs cs ds} → length as ≡ length bs →
-        Sublist R (as ++ cs) (bs ++ ds) → Sublist R cs ds
-  ++⁻ {[]}     {[]}     eq rs = rs
-  ++⁻ {a ∷ as} {b ∷ bs} eq rs = ++⁻ (ℕₚ.suc-injective eq) (∷⁻ rs)
-
-  ++ˡ : ∀ {as bs} (cs : List B) → Sublist R as bs → Sublist R as (cs ++ bs)
-  ++ˡ zs = ++⁺ (minimum zs)
-
-  ++ʳ : ∀ {as bs} (cs : List B) → Sublist R as bs → Sublist R as (bs ++ cs)
-  ++ʳ cs []        = minimum cs
-  ++ʳ cs (y ∷ʳ rs) = y ∷ʳ ++ʳ cs rs
-  ++ʳ cs (r ∷ rs)  = r ∷ ++ʳ cs rs
-
-
-------------------------------------------------------------------------
--- concat
-
-  concat⁺ : ∀ {ass bss} → Sublist (Sublist R) ass bss →
-            Sublist R (concat ass) (concat bss)
-  concat⁺ []          = []
-  concat⁺ (y  ∷ʳ rss) = ++ˡ y (concat⁺ rss)
-  concat⁺ (rs ∷  rss) = ++⁺ rs (concat⁺ rss)
-
-------------------------------------------------------------------------
--- take / drop
-
-  take⁺ : ∀ {m n as bs} → m ≤ n → Pointwise R as bs →
-          Sublist R (take m as) (take n bs)
-  take⁺ z≤n       ps        = minimum _
-  take⁺ (s≤s m≤n) []        = []
-  take⁺ (s≤s m≤n) (p ∷  ps) = p ∷ take⁺ m≤n ps
-
-  drop⁺ : ∀ {m n as bs} → m ≥ n → Sublist R as bs →
-          Sublist R (drop m as) (drop n bs)
-  drop⁺ {m} z≤n       rs        = drop-Sublist m rs
-  drop⁺     (s≤s m≥n) []        = []
-  drop⁺     (s≤s m≥n) (y ∷ʳ rs) = drop⁺ (ℕₚ.m≤n⇒m≤1+n m≥n) rs
-  drop⁺     (s≤s m≥n) (r ∷ rs)  = drop⁺ m≥n rs
-
-  drop⁺-≥ : ∀ {m n as bs} → m ≥ n → Pointwise R as bs →
-            Sublist R (drop m as) (drop n bs)
-  drop⁺-≥ m≥n pw = drop⁺ m≥n (fromPointwise pw)
-
-  drop⁺-⊆ : ∀ {as bs} m → Sublist R as bs →
-            Sublist R (drop m as) (drop m bs)
-  drop⁺-⊆ m = drop⁺ (ℕₚ.≤-refl {m})
-
-module _ {a b r p q} {A : Set a} {B : Set b}
-         {R : REL A B r} {P : Pred A p} {Q : Pred B q}
-         (P? : U.Decidable P) (Q? : U.Decidable Q) where
-
-  ⊆-takeWhile-Sublist : ∀ {as bs} →
-    (∀ {a b} → R a b → P a → Q b) →
-    Pointwise R as bs → Sublist R (takeWhile P? as) (takeWhile Q? bs)
-  ⊆-takeWhile-Sublist rp⇒q [] = []
-  ⊆-takeWhile-Sublist {a ∷ as} {b ∷ bs} rp⇒q (p ∷ ps) with P? a | Q? b
-  ... | false because _ | _               = minimum _
-  ... | true  because _ | true  because _ = p ∷ ⊆-takeWhile-Sublist rp⇒q ps
-  ... | yes pa          | no ¬qb          = ⊥-elim $ ¬qb $ rp⇒q p pa
-
-  ⊇-dropWhile-Sublist : ∀ {as bs} →
-    (∀ {a b} → R a b → Q b → P a) →
-    Pointwise R as bs → Sublist R (dropWhile P? as) (dropWhile Q? bs)
-  ⊇-dropWhile-Sublist rq⇒p [] = []
-  ⊇-dropWhile-Sublist {a ∷ as} {b ∷ bs} rq⇒p (p ∷ ps) with P? a | Q? b
-  ... | true  because _ | true  because _ = ⊇-dropWhile-Sublist rq⇒p ps
-  ... | true  because _ | false because _ =
-    b ∷ʳ dropWhile-Sublist P? (fromPointwise ps)
-  ... | false because _ | false because _ = p ∷ fromPointwise ps
-  ... | no ¬pa          | yes qb          = ⊥-elim $ ¬pa $ rq⇒p p qb
-
-  ⊆-filter-Sublist : ∀ {as bs} → (∀ {a b} → R a b → P a → Q b) →
-                     Sublist R as bs → Sublist R (filter P? as) (filter Q? bs)
-  ⊆-filter-Sublist rp⇒q [] = []
-  ⊆-filter-Sublist rp⇒q (y ∷ʳ rs) with does (Q? y)
-  ... | true  = y ∷ʳ ⊆-filter-Sublist rp⇒q rs
-  ... | false = ⊆-filter-Sublist rp⇒q rs
-  ⊆-filter-Sublist {a ∷ as} {b ∷ bs} rp⇒q (r ∷ rs) with P? a | Q? b
-  ... | true  because _ | true  because _ = r ∷ ⊆-filter-Sublist rp⇒q rs
-  ... | false because _ | true  because _ = _ ∷ʳ ⊆-filter-Sublist rp⇒q rs
-  ... | false because _ | false because _ = ⊆-filter-Sublist rp⇒q rs
-  ... | yes pa          | no ¬qb          = ⊥-elim $ ¬qb $ rp⇒q r pa
-
-module _ {a r p} {A : Set a} {R : Rel A r} {P : Pred A p} (P? : U.Decidable P) where
-
-  takeWhile-filter : ∀ {as} → Pointwise R as as →
-                     Sublist R (takeWhile P? as) (filter P? as)
-  takeWhile-filter [] = []
-  takeWhile-filter {a ∷ as} (p ∷ ps) with does (P? a)
-  ... | true  = p ∷ takeWhile-filter ps
-  ... | false = minimum _
-
-  filter-dropWhile : ∀ {as} → Pointwise R as as →
-                     Sublist R (filter P? as) (dropWhile (¬? ∘ P?) as)
-  filter-dropWhile [] = []
-  filter-dropWhile {a ∷ as} (p ∷ ps) with does (P? a)
-  ... | true  = p ∷ filter-Sublist P? (fromPointwise ps)
-  ... | false = filter-dropWhile ps
-
-------------------------------------------------------------------------
--- reverse
-
-module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where
-
-  reverseAcc⁺ : ∀ {as bs cs ds} → Sublist R as bs → Sublist R cs ds →
-                Sublist R (reverseAcc cs as) (reverseAcc ds bs)
-  reverseAcc⁺ []         cds = cds
-  reverseAcc⁺ (y ∷ʳ abs) cds = reverseAcc⁺ abs (y ∷ʳ cds)
-  reverseAcc⁺ (r ∷ abs)  cds = reverseAcc⁺ abs (r ∷ cds)
-
-  ʳ++⁺ : ∀ {as bs cs ds} →
-         Sublist R as bs →
-         Sublist R cs ds →
-         Sublist R (as ʳ++ cs) (bs ʳ++ ds)
-  ʳ++⁺ = reverseAcc⁺
-
-  reverse⁺ : ∀ {as bs} → Sublist R as bs → Sublist R (reverse as) (reverse bs)
-  reverse⁺ rs = reverseAcc⁺ rs []
-
-  reverse⁻ : ∀ {as bs} → Sublist R (reverse as) (reverse bs) → Sublist R as bs
-  reverse⁻ {as} {bs} p = cast (reverse⁺ p) where
-    cast = P.subst₂ (Sublist R) (Lₚ.reverse-involutive as) (Lₚ.reverse-involutive bs)
-
-------------------------------------------------------------------------
--- Inversion lemmas
-
-module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} {a as b bs} where
-
-  ∷⁻¹ : R a b → Sublist R as bs ⇔ Sublist R (a ∷ as) (b ∷ bs)
-  ∷⁻¹ r = mk⇔ (r ∷_) ∷⁻
-
-  ∷ʳ⁻¹ : ¬ R a b → Sublist R (a ∷ as) bs ⇔ Sublist R (a ∷ as) (b ∷ bs)
-  ∷ʳ⁻¹ ¬r = mk⇔ (_ ∷ʳ_) (∷ʳ⁻ ¬r)
-
-------------------------------------------------------------------------
--- Irrelevant special case
-
-module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where
-
-  Sublist-[]-irrelevant : U.Irrelevant (Sublist R [])
-  Sublist-[]-irrelevant []       []        = P.refl
-  Sublist-[]-irrelevant (y ∷ʳ p) (.y ∷ʳ q) = P.cong (y ∷ʳ_) (Sublist-[]-irrelevant p q)
-
-------------------------------------------------------------------------
--- (to/from)Any is a bijection
-
-  toAny-injective : ∀ {xs x} {p q : Sublist R [ x ] xs} → toAny p ≡ toAny q → p ≡ q
-  toAny-injective {p = y ∷ʳ p} {y ∷ʳ q} =
-    P.cong (y ∷ʳ_) ∘′ toAny-injective ∘′ there-injective
-  toAny-injective {p = _ ∷ p}  {_ ∷ q}  =
-    P.cong₂ (flip _∷_) (Sublist-[]-irrelevant p q) ∘′ here-injective
-
-  fromAny-injective : ∀ {xs x} {p q : Any (R x) xs} →
-                      fromAny {R = R} p ≡ fromAny q → p ≡ q
-  fromAny-injective {p = here px} {here qx} = P.cong here ∘′ ∷-injectiveˡ
-  fromAny-injective {p = there p} {there q} =
-    P.cong there ∘′ fromAny-injective ∘′ ∷ʳ-injective
-
-  toAny∘fromAny≗id : ∀ {xs x} (p : Any (R x) xs) → toAny (fromAny {R = R} p) ≡ p
-  toAny∘fromAny≗id (here px) = P.refl
-  toAny∘fromAny≗id (there p) = P.cong there (toAny∘fromAny≗id p)
-
-  Sublist-[x]-bijection : ∀ {x xs} → (Sublist R [ x ] xs) ⤖ (Any (R x) xs)
-  Sublist-[x]-bijection = mk⤖ (toAny-injective , < fromAny , toAny∘fromAny≗id >)
-
-------------------------------------------------------------------------
--- Relational properties
-
-module Reflexivity
-    {a r} {A : Set a} {R : Rel A r}
-    (R-refl : Reflexive R) where
-
-  reflexive : _≡_ ⇒ Sublist R
-  reflexive P.refl = fromPointwise (Pw.refl R-refl)
-
-  refl : Reflexive (Sublist R)
-  refl = reflexive P.refl
-
-open Reflexivity public
-
-module Transitivity
-    {a b c r s t} {A : Set a} {B : Set b} {C : Set c}
-    {R : REL A B r} {S : REL B C s} {T : REL A C t}
-    (rs⇒t : Trans R S T) where
-
-  trans : Trans (Sublist R) (Sublist S) (Sublist T)
-  trans rs        (y ∷ʳ ss) = y ∷ʳ trans rs ss
-  trans (y ∷ʳ rs) (s ∷ ss)  = _ ∷ʳ trans rs ss
-  trans (r ∷ rs)  (s ∷ ss)  = rs⇒t r s ∷ trans rs ss
-  trans []        []        = []
-
-open Transitivity public
-
-module Antisymmetry
-    {a b r s e} {A : Set a} {B : Set b}
-    {R : REL A B r} {S : REL B A s} {E : REL A B e}
-    (rs⇒e : Antisym R S E) where
-
-  open ℕₚ.≤-Reasoning
-
-  antisym : Antisym (Sublist R) (Sublist S) (Pointwise E)
-  antisym []        []        = []
-  antisym (r ∷ rs)  (s ∷ ss)  = rs⇒e r s ∷ antisym rs ss
-  -- impossible cases
-  antisym (_∷ʳ_ {xs} {ys₁} y rs) (_∷ʳ_ {ys₂} {zs} z ss) =
-    ⊥-elim $ ℕₚ.<-irrefl P.refl $ begin
-    length (y ∷ ys₁) ≤⟨ length-mono-≤ ss ⟩
-    length zs        ≤⟨ ℕₚ.n≤1+n (length zs) ⟩
-    length (z ∷ zs)  ≤⟨ length-mono-≤ rs ⟩
-    length ys₁       ∎
-  antisym (_∷ʳ_ {xs} {ys₁} y rs) (_∷_ {y} {ys₂} {z} {zs} s ss)  =
-    ⊥-elim $ ℕₚ.<-irrefl P.refl $ begin
-    length (z ∷ zs) ≤⟨ length-mono-≤ rs ⟩
-    length ys₁      ≤⟨ length-mono-≤ ss ⟩
-    length zs       ∎
-  antisym (_∷_ {x} {xs} {y} {ys₁} r rs)  (_∷ʳ_ {ys₂} {zs} z ss) =
-    ⊥-elim $ ℕₚ.<-irrefl P.refl $ begin
-    length (y ∷ ys₁) ≤⟨ length-mono-≤ ss ⟩
-    length xs        ≤⟨ length-mono-≤ rs ⟩
-    length ys₁       ∎
-
-open Antisymmetry public
-
-module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} (R? : Decidable R) where
-
-  sublist? : Decidable (Sublist R)
-  sublist? []       ys       = yes (minimum ys)
-  sublist? (x ∷ xs) []       = no λ ()
-  sublist? (x ∷ xs) (y ∷ ys) with R? x y
-  ... | true  because  [r] =
-    Dec.map (∷⁻¹  (invert  [r])) (sublist? xs ys)
-  ... | false because [¬r] =
-    Dec.map (∷ʳ⁻¹ (invert [¬r])) (sublist? (x ∷ xs) ys)
-
-module _ {a e r} {A : Set a} {E : Rel A e} {R : Rel A r} where
-
-  isPreorder : IsPreorder E R → IsPreorder (Pointwise E) (Sublist R)
-  isPreorder ER-isPreorder = record
-    { isEquivalence = Pw.isEquivalence       ER.isEquivalence
-    ; reflexive     = fromPointwise ∘ Pw.map ER.reflexive
-    ; trans         = trans                  ER.trans
-    } where module ER = IsPreorder ER-isPreorder
-
-  isPartialOrder : IsPartialOrder E R → IsPartialOrder (Pointwise E) (Sublist R)
-  isPartialOrder ER-isPartialOrder = record
-    { isPreorder = isPreorder ER.isPreorder
-    ; antisym    = antisym    ER.antisym
-    } where module ER = IsPartialOrder ER-isPartialOrder
-
-  isDecPartialOrder : IsDecPartialOrder E R →
-                      IsDecPartialOrder (Pointwise E) (Sublist R)
-  isDecPartialOrder ER-isDecPartialOrder = record
-    { isPartialOrder = isPartialOrder ER.isPartialOrder
-    ; _≟_            = Pw.decidable   ER._≟_
-    ; _≤?_           = sublist?       ER._≤?_
-    } where module ER = IsDecPartialOrder ER-isDecPartialOrder
-
-module _ {a e r} where
-
-  preorder : Preorder a e r → Preorder _ _ _
-  preorder ER-preorder = record
-    { isPreorder = isPreorder ER.isPreorder
-    } where module ER = Preorder ER-preorder
-
-  poset : Poset a e r → Poset _ _ _
-  poset ER-poset = record
-    { isPartialOrder = isPartialOrder ER.isPartialOrder
-    } where module ER = Poset ER-poset
-
-  decPoset : DecPoset a e r → DecPoset _ _ _
-  decPoset ER-poset = record
-    { isDecPartialOrder = isDecPartialOrder ER.isDecPartialOrder
-    } where module ER = DecPoset ER-poset
-
-------------------------------------------------------------------------
--- Properties of disjoint sublists
-
-module Disjointness {a b r} {A : Set a} {B : Set b} {R : REL A B r} where
-
-  private
-    infix 4 _⊆_
-    _⊆_ = Sublist R
-
-  -- Forgetting the union
-
-  DisjointUnion→Disjoint : ∀ {xs ys zs us} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} {τ : us ⊆ zs} →
-    DisjointUnion τ₁ τ₂ τ → Disjoint τ₁ τ₂
-  DisjointUnion→Disjoint []         = []
-  DisjointUnion→Disjoint (y   ∷ₙ u) = y   ∷ₙ DisjointUnion→Disjoint u
-  DisjointUnion→Disjoint (x≈y ∷ₗ u) = x≈y ∷ₗ DisjointUnion→Disjoint u
-  DisjointUnion→Disjoint (x≈y ∷ᵣ u) = x≈y ∷ᵣ DisjointUnion→Disjoint u
-
-  -- Reconstructing the union
-
-  Disjoint→DisjointUnion : ∀ {xs ys zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} →
-    Disjoint τ₁ τ₂ → ∃₂ λ us (τ : us ⊆ zs) → DisjointUnion τ₁ τ₂ τ
-  Disjoint→DisjointUnion []         = _ , _ , []
-  Disjoint→DisjointUnion (y   ∷ₙ u) = _ , _ , y   ∷ₙ proj₂ (proj₂ (Disjoint→DisjointUnion u))
-  Disjoint→DisjointUnion (x≈y ∷ₗ u) = _ , _ , x≈y ∷ₗ proj₂ (proj₂ (Disjoint→DisjointUnion u))
-  Disjoint→DisjointUnion (x≈y ∷ᵣ u) = _ , _ , x≈y ∷ᵣ proj₂ (proj₂ (Disjoint→DisjointUnion u))
-
-  -- Disjoint is decidable
-
-  ⊆-disjoint? : ∀ {xs ys zs} (τ₁ : xs ⊆ zs) (τ₂ : ys ⊆ zs) → Dec (Disjoint τ₁ τ₂)
-  ⊆-disjoint? [] [] = yes []
-  -- Present in both sublists: not disjoint.
-  ⊆-disjoint? (x≈z ∷ τ₁) (y≈z ∷ τ₂) = no λ()
-  -- Present in either sublist: ok.
-  ⊆-disjoint? (y ∷ʳ τ₁) (x≈y ∷ τ₂) =
-    Dec.map′ (x≈y ∷ᵣ_) (λ{ (_ ∷ᵣ d) → d }) (⊆-disjoint? τ₁ τ₂)
-  ⊆-disjoint? (x≈y ∷ τ₁) (y ∷ʳ τ₂) =
-    Dec.map′ (x≈y ∷ₗ_) (λ{ (_ ∷ₗ d) → d }) (⊆-disjoint? τ₁ τ₂)
-  -- Present in neither sublist: ok.
-  ⊆-disjoint? (y ∷ʳ τ₁) (.y ∷ʳ τ₂) =
-    Dec.map′ (y ∷ₙ_) (λ{ (_ ∷ₙ d) → d }) (⊆-disjoint? τ₁ τ₂)
-
-  -- Disjoint is proof-irrelevant
-
-  Disjoint-irrelevant : ∀{xs ys zs} → Irrelevant (Disjoint {R = R} {xs} {ys} {zs})
-  Disjoint-irrelevant [] [] = P.refl
-  Disjoint-irrelevant (y   ∷ₙ d₁) (.y   ∷ₙ d₂) = P.cong (y ∷ₙ_) (Disjoint-irrelevant d₁ d₂)
-  Disjoint-irrelevant (x≈y ∷ₗ d₁) (.x≈y ∷ₗ d₂) = P.cong (x≈y ∷ₗ_) (Disjoint-irrelevant d₁ d₂)
-  Disjoint-irrelevant (x≈y ∷ᵣ d₁) (.x≈y ∷ᵣ d₂) = P.cong (x≈y ∷ᵣ_) (Disjoint-irrelevant d₁ d₂)
-
-  -- Note: DisjointUnion is not proof-irrelevant unless the underlying relation R is.
-  -- The proof is not entirely trivial, thus, we leave it for future work:
-  --
-  -- DisjointUnion-irrelevant : Irrelevant R →
-  --                            ∀{xs ys us zs} {τ : us ⊆ zs} →
-  --                            Irrelevant (λ (τ₁ : xs ⊆ zs) (τ₂ : ys ⊆ zs) → DisjointUnion τ₁ τ₂ τ)
-
-  -- Irreflexivity
-
-  Disjoint-irrefl′ : ∀{xs ys} {τ : xs ⊆ ys} → Disjoint τ τ → Null xs
-  Disjoint-irrefl′ []       = []
-  Disjoint-irrefl′ (y ∷ₙ d) = Disjoint-irrefl′ d
-
-  Disjoint-irrefl : ∀{x xs ys} → Irreflexive {A = x ∷ xs ⊆ ys } _≡_ Disjoint
-  Disjoint-irrefl P.refl x with Disjoint-irrefl′ x
-  ... | () ∷ _
-
-  -- Symmetry
-
-  DisjointUnion-sym : ∀ {xs ys xys} {zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} {τ : xys ⊆ zs} →
-                            DisjointUnion τ₁ τ₂ τ → DisjointUnion τ₂ τ₁ τ
-  DisjointUnion-sym []         = []
-  DisjointUnion-sym (y   ∷ₙ d) = y ∷ₙ DisjointUnion-sym d
-  DisjointUnion-sym (x≈y ∷ₗ d) = x≈y ∷ᵣ DisjointUnion-sym d
-  DisjointUnion-sym (x≈y ∷ᵣ d) = x≈y ∷ₗ DisjointUnion-sym d
-
-  Disjoint-sym : ∀ {xs ys} {zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} →
-                 Disjoint τ₁ τ₂ → Disjoint τ₂ τ₁
-  Disjoint-sym []         = []
-  Disjoint-sym (y   ∷ₙ d) = y ∷ₙ Disjoint-sym d
-  Disjoint-sym (x≈y ∷ₗ d) = x≈y ∷ᵣ Disjoint-sym d
-  Disjoint-sym (x≈y ∷ᵣ d) = x≈y ∷ₗ Disjoint-sym d
-
-  -- Empty sublist
-
-  DisjointUnion-[]ˡ : ∀{xs ys} {ε : [] ⊆ ys} {τ : xs ⊆ ys} → DisjointUnion ε τ τ
-  DisjointUnion-[]ˡ {ε = []}     {τ = []} = []
-  DisjointUnion-[]ˡ {ε = y ∷ʳ ε} {τ = y  ∷ʳ τ} = y   ∷ₙ DisjointUnion-[]ˡ
-  DisjointUnion-[]ˡ {ε = y ∷ʳ ε} {τ = x≈y ∷ τ} = x≈y ∷ᵣ DisjointUnion-[]ˡ
-
-  DisjointUnion-[]ʳ : ∀{xs ys} {ε : [] ⊆ ys} {τ : xs ⊆ ys} → DisjointUnion τ ε τ
-  DisjointUnion-[]ʳ {ε = []}     {τ = []} = []
-  DisjointUnion-[]ʳ {ε = y ∷ʳ ε} {τ = y  ∷ʳ τ} = y   ∷ₙ DisjointUnion-[]ʳ
-  DisjointUnion-[]ʳ {ε = y ∷ʳ ε} {τ = x≈y ∷ τ} = x≈y ∷ₗ DisjointUnion-[]ʳ
-
-  -- A sublist τ : x∷xs ⊆ ys can be split into two disjoint sublists
-  -- [x] ⊆ ys (canonical choice) and (∷ˡ⁻ τ) : xs ⊆ ys.
-
-  DisjointUnion-fromAny∘toAny-∷ˡ⁻ : ∀ {x xs ys} (τ : (x ∷ xs) ⊆ ys) → DisjointUnion (fromAny (toAny τ)) (∷ˡ⁻ τ) τ
-  DisjointUnion-fromAny∘toAny-∷ˡ⁻ (y  ∷ʳ τ) = y   ∷ₙ DisjointUnion-fromAny∘toAny-∷ˡ⁻ τ
-  DisjointUnion-fromAny∘toAny-∷ˡ⁻ (xRy ∷ τ) = xRy ∷ₗ DisjointUnion-[]ˡ
-
-  -- Disjoint union of three mutually disjoint lists.
-  --
-  -- τᵢⱼ denotes the disjoint union of τᵢ and τⱼ: DisjointUnion τᵢ τⱼ τᵢⱼ
-
-  record DisjointUnion³
-    {xs ys zs ts} (τ₁  : xs  ⊆ ts) (τ₂  : ys  ⊆ ts) (τ₃  : zs  ⊆ ts)
-    {xys xzs yzs} (τ₁₂ : xys ⊆ ts) (τ₁₃ : xzs ⊆ ts) (τ₂₃ : yzs ⊆ ts) : Set (a ⊔ b ⊔ r) where
-    field
-      {union³} : List A
-      sub³  : union³ ⊆ ts
-      join₁ : DisjointUnion τ₁ τ₂₃ sub³
-      join₂ : DisjointUnion τ₂ τ₁₃ sub³
-      join₃ : DisjointUnion τ₃ τ₁₂ sub³
-
-  infixr 5 _∷ʳ-DisjointUnion³_ _∷₁-DisjointUnion³_ _∷₂-DisjointUnion³_ _∷₃-DisjointUnion³_
-
-  -- Weakening the target list ts of a disjoint union.
-
-  _∷ʳ-DisjointUnion³_ :
-    ∀ {xs ys zs ts} {τ₁ : xs ⊆ ts} {τ₂ : ys ⊆ ts} {τ₃ : zs ⊆ ts} →
-    ∀ {xys xzs yzs} {τ₁₂ : xys ⊆ ts} {τ₁₃ : xzs ⊆ ts} {τ₂₃ : yzs ⊆ ts} →
-    ∀ y →
-    DisjointUnion³ τ₁ τ₂ τ₃ τ₁₂ τ₁₃ τ₂₃ →
-    DisjointUnion³ (y ∷ʳ τ₁) (y ∷ʳ τ₂) (y ∷ʳ τ₃) (y ∷ʳ τ₁₂) (y ∷ʳ τ₁₃) (y ∷ʳ τ₂₃)
-  y ∷ʳ-DisjointUnion³ record{ sub³ = σ ; join₁ = d₁ ; join₂ = d₂ ; join₃ = d₃ } = record
-    { sub³  = y ∷ʳ σ
-    ; join₁ = y ∷ₙ d₁
-    ; join₂ = y ∷ₙ d₂
-    ; join₃ = y ∷ₙ d₃
-    }
-
-  -- Adding an element to the first list.
-
-  _∷₁-DisjointUnion³_ :
-    ∀ {xs ys zs ts} {τ₁ : xs ⊆ ts} {τ₂ : ys ⊆ ts} {τ₃ : zs ⊆ ts} →
-    ∀ {xys xzs yzs} {τ₁₂ : xys ⊆ ts} {τ₁₃ : xzs ⊆ ts} {τ₂₃ : yzs ⊆ ts} →
-    ∀ {x y} (xRy : R x y) →
-    DisjointUnion³ τ₁ τ₂ τ₃ τ₁₂ τ₁₃ τ₂₃ →
-    DisjointUnion³ (xRy ∷ τ₁) (y ∷ʳ τ₂) (y ∷ʳ τ₃) (xRy ∷ τ₁₂) (xRy ∷ τ₁₃) (y ∷ʳ τ₂₃)
-  xRy ∷₁-DisjointUnion³ record{ sub³ = σ ; join₁ = d₁ ; join₂ = d₂ ; join₃ = d₃ } = record
-    { sub³  = xRy ∷ σ
-    ; join₁ = xRy ∷ₗ d₁
-    ; join₂ = xRy ∷ᵣ d₂
-    ; join₃ = xRy ∷ᵣ d₃
-    }
-
-  -- Adding an element to the second list.
-
-  _∷₂-DisjointUnion³_ :
-    ∀ {xs ys zs ts} {τ₁ : xs ⊆ ts} {τ₂ : ys ⊆ ts} {τ₃ : zs ⊆ ts} →
-    ∀ {xys xzs yzs} {τ₁₂ : xys ⊆ ts} {τ₁₃ : xzs ⊆ ts} {τ₂₃ : yzs ⊆ ts} →
-    ∀ {x y} (xRy : R x y) →
-    DisjointUnion³ τ₁ τ₂ τ₃ τ₁₂ τ₁₃ τ₂₃ →
-    DisjointUnion³ (y ∷ʳ τ₁) (xRy ∷ τ₂) (y ∷ʳ τ₃) (xRy ∷ τ₁₂) (y ∷ʳ τ₁₃) (xRy ∷ τ₂₃)
-  xRy ∷₂-DisjointUnion³ record{ sub³ = σ ; join₁ = d₁ ; join₂ = d₂ ; join₃ = d₃ } = record
-    { sub³  = xRy ∷ σ
-    ; join₁ = xRy ∷ᵣ d₁
-    ; join₂ = xRy ∷ₗ d₂
-    ; join₃ = xRy ∷ᵣ d₃
-    }
-
-  -- Adding an element to the third list.
-
-  _∷₃-DisjointUnion³_ :
-    ∀ {xs ys zs ts} {τ₁ : xs ⊆ ts} {τ₂ : ys ⊆ ts} {τ₃ : zs ⊆ ts} →
-    ∀ {xys xzs yzs} {τ₁₂ : xys ⊆ ts} {τ₁₃ : xzs ⊆ ts} {τ₂₃ : yzs ⊆ ts} →
-    ∀ {x y} (xRy : R x y) →
-    DisjointUnion³ τ₁ τ₂ τ₃ τ₁₂ τ₁₃ τ₂₃ →
-    DisjointUnion³ (y ∷ʳ τ₁) (y ∷ʳ τ₂) (xRy ∷ τ₃) (y ∷ʳ τ₁₂) (xRy ∷ τ₁₃) (xRy ∷ τ₂₃)
-  xRy ∷₃-DisjointUnion³ record{ sub³ = σ ; join₁ = d₁ ; join₂ = d₂ ; join₃ = d₃ } = record
-    { sub³  = xRy ∷ σ
-    ; join₁ = xRy ∷ᵣ d₁
-    ; join₂ = xRy ∷ᵣ d₂
-    ; join₃ = xRy ∷ₗ d₃
-    }
-
-  -- Computing the disjoint union of three disjoint lists.
-
-  disjointUnion³ : ∀{xs ys zs ts} {τ₁ : xs ⊆ ts} {τ₂ : ys ⊆ ts} {τ₃ : zs ⊆ ts}
-    {xys xzs yzs} {τ₁₂ : xys ⊆ ts} {τ₁₃ : xzs ⊆ ts} {τ₂₃ : yzs ⊆ ts} →
-    DisjointUnion τ₁ τ₂ τ₁₂ →
-    DisjointUnion τ₁ τ₃ τ₁₃ →
-    DisjointUnion τ₂ τ₃ τ₂₃ →
-    DisjointUnion³ τ₁ τ₂ τ₃ τ₁₂ τ₁₃ τ₂₃
-  disjointUnion³ [] [] [] = record { sub³ = [] ; join₁ = [] ; join₂ = [] ; join₃ = [] }
-  disjointUnion³ (y   ∷ₙ d₁₂) (.y  ∷ₙ d₁₃) (.y   ∷ₙ d₂₃) = y ∷ʳ-DisjointUnion³ disjointUnion³ d₁₂ d₁₃ d₂₃
-  disjointUnion³ (y   ∷ₙ d₁₂) (xRy ∷ᵣ d₁₃) (.xRy ∷ᵣ d₂₃) = xRy ∷₃-DisjointUnion³ disjointUnion³ d₁₂ d₁₃ d₂₃
-  disjointUnion³ (xRy ∷ᵣ d₁₂) (y   ∷ₙ d₁₃) (.xRy ∷ₗ d₂₃) = xRy ∷₂-DisjointUnion³ disjointUnion³ d₁₂ d₁₃ d₂₃
-  disjointUnion³ (xRy ∷ₗ d₁₂) (.xRy ∷ₗ d₁₃) (y    ∷ₙ d₂₃) = xRy ∷₁-DisjointUnion³ disjointUnion³ d₁₂ d₁₃ d₂₃
-  disjointUnion³ (xRy ∷ᵣ d₁₂) (xRy′ ∷ᵣ d₁₃) ()
-
-  -- If a sublist τ is disjoint to two lists σ₁ and σ₂,
-  -- then also to their disjoint union σ.
-
-  disjoint⇒disjoint-to-union : ∀{xs ys zs yzs ts}
-    {τ : xs ⊆ ts} {σ₁ : ys ⊆ ts} {σ₂ : zs ⊆ ts} {σ : yzs ⊆ ts} →
-    Disjoint τ σ₁ → Disjoint τ σ₂ → DisjointUnion σ₁ σ₂ σ → Disjoint τ σ
-  disjoint⇒disjoint-to-union d₁ d₂ u = let
-       _ , _ , u₁ = Disjoint→DisjointUnion d₁
-       _ , _ , u₂ = Disjoint→DisjointUnion d₂
-    in DisjointUnion→Disjoint (DisjointUnion³.join₁ (disjointUnion³ u₁ u₂ u))
-
-open Disjointness public
-
--- Monotonicity of disjointness.
-
-module DisjointnessMonotonicity
-    {a b c r s t} {A : Set a} {B : Set b} {C : Set c}
-    {R : REL A B r} {S : REL B C s} {T : REL A C t}
-    (rs⇒t : Trans R S T) where
-
-  -- We can enlarge and convert the target list of a disjoint union.
-
-  weakenDisjointUnion : ∀ {xs ys xys zs ws}
-    {τ₁ : Sublist R xs zs}
-    {τ₂ : Sublist R ys zs}
-    {τ : Sublist R xys zs} (σ : Sublist S zs ws) →
-    DisjointUnion τ₁ τ₂ τ →
-    DisjointUnion (trans rs⇒t τ₁ σ) (trans rs⇒t τ₂ σ) (trans rs⇒t τ σ)
-  weakenDisjointUnion [] [] = []
-  weakenDisjointUnion (w  ∷ʳ σ) d         = w ∷ₙ weakenDisjointUnion σ d
-  weakenDisjointUnion (_   ∷ σ) (y   ∷ₙ d) = _ ∷ₙ weakenDisjointUnion σ d
-  weakenDisjointUnion (zSw ∷ σ) (xRz ∷ₗ d) = rs⇒t xRz zSw ∷ₗ weakenDisjointUnion σ d
-  weakenDisjointUnion (zSw ∷ σ) (yRz ∷ᵣ d) = rs⇒t yRz zSw ∷ᵣ weakenDisjointUnion σ d
-
-  weakenDisjoint : ∀ {xs ys zs ws}
-    {τ₁ : Sublist R xs zs}
-    {τ₂ : Sublist R ys zs} (σ : Sublist S zs ws) →
-    Disjoint τ₁ τ₂ →
-    Disjoint (trans rs⇒t τ₁ σ) (trans rs⇒t τ₂ σ)
-  weakenDisjoint [] [] = []
-  weakenDisjoint (w  ∷ʳ σ) d         = w ∷ₙ weakenDisjoint σ d
-  weakenDisjoint (_   ∷ σ) (y   ∷ₙ d) = _ ∷ₙ weakenDisjoint σ d
-  weakenDisjoint (zSw ∷ σ) (xRz ∷ₗ d) = rs⇒t xRz zSw ∷ₗ weakenDisjoint σ d
-  weakenDisjoint (zSw ∷ σ) (yRz ∷ᵣ d) = rs⇒t yRz zSw ∷ᵣ weakenDisjoint σ d
-
-  -- Lists remain disjoint when elements are removed.
-
-  shrinkDisjoint : ∀ {us vs xs ys zs}
-                      (σ₁ : Sublist R us xs) {τ₁ : Sublist S xs zs}
-                      (σ₂ : Sublist R vs ys) {τ₂ : Sublist S ys zs} →
-                      Disjoint τ₁ τ₂ →
-                      Disjoint (trans rs⇒t σ₁ τ₁) (trans rs⇒t σ₂ τ₂)
-  shrinkDisjoint σ₁         σ₂ (y   ∷ₙ d) = y ∷ₙ shrinkDisjoint σ₁ σ₂ d
-  shrinkDisjoint (x  ∷ʳ σ₁) σ₂ (xSz ∷ₗ d) = _ ∷ₙ shrinkDisjoint σ₁ σ₂ d
-  shrinkDisjoint (uRx ∷ σ₁) σ₂ (xSz ∷ₗ d) = rs⇒t uRx xSz ∷ₗ shrinkDisjoint σ₁ σ₂ d
-  shrinkDisjoint σ₁ (y  ∷ʳ σ₂) (ySz ∷ᵣ d) = _ ∷ₙ shrinkDisjoint σ₁ σ₂ d
-  shrinkDisjoint σ₁ (vRy ∷ σ₂) (ySz ∷ᵣ d) = rs⇒t vRy ySz ∷ᵣ shrinkDisjoint σ₁ σ₂ d
-  shrinkDisjoint [] []         []         = []
-
-open DisjointnessMonotonicity public
+Data.List.Relation.Binary.Sublist.Heterogeneous.Properties
------------------------------------------------------------------------
+-- The Agda standard library
+--
+-- Properties of the heterogeneous sublist relation
+------------------------------------------------------------------------
+
+{-# OPTIONS --cubical-compatible --safe #-}
+
+module Data.List.Relation.Binary.Sublist.Heterogeneous.Properties where
+
+open import Level
+
+open import Data.Bool.Base using (true; false)
+open import Data.Empty
+open import Data.List.Relation.Unary.All using (Null; []; _∷_)
+open import Data.List.Relation.Unary.Any using (Any; here; there)
+open import Data.List.Base as List hiding (map; _∷ʳ_)
+import Data.List.Properties as Lₚ
+open import Data.List.Relation.Unary.Any.Properties
+  using (here-injective; there-injective)
+open import Data.List.Relation.Binary.Pointwise as Pw using (Pointwise; []; _∷_)
+open import Data.List.Relation.Binary.Sublist.Heterogeneous
+
+open import Data.Maybe.Relation.Unary.All as MAll using (nothing; just)
+open import Data.Nat.Base using (ℕ; _≤_; _≥_); open ℕ; open _≤_
+import Data.Nat.Properties as ℕₚ
+open import Data.Product.Base using (∃₂; _×_; _,_; <_,_>; proj₂; uncurry)
+
+open import Function.Base
+open import Function.Bundles using (_⤖_; _⇔_ ; mk⤖; mk⇔)
+open import Function.Consequences.Propositional using (strictlySurjective⇒surjective)
+open import Relation.Nullary.Reflects using (invert)
+open import Relation.Nullary using (Dec; does; _because_; yes; no; ¬_)
+open import Relation.Nullary.Decidable as Dec using (¬?)
+open import Relation.Unary as U using (Pred)
+open import Relation.Binary.Core using (Rel; REL; _⇒_)
+open import Relation.Binary.Bundles using (Preorder; Poset; DecPoset)
+open import Relation.Binary.Definitions
+  using (Reflexive; Trans; Antisym; Decidable; Irrelevant; Irreflexive)
+open import Relation.Binary.Structures
+  using (IsPreorder; IsPartialOrder; IsDecPartialOrder)
+open import Relation.Binary.PropositionalEquality.Core as P using (_≡_)
+
+------------------------------------------------------------------------
+-- Injectivity of constructors
+
+module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where
+
+  ∷-injectiveˡ : ∀ {x y xs ys} {px qx : R x y} {pxs qxs : Sublist R xs ys} →
+                 (Sublist R (x ∷ xs) (y ∷ ys) ∋ px ∷ pxs) ≡ (qx ∷ qxs) → px ≡ qx
+  ∷-injectiveˡ P.refl = P.refl
+
+  ∷-injectiveʳ : ∀ {x y xs ys} {px qx : R x y} {pxs qxs : Sublist R xs ys} →
+                 (Sublist R (x ∷ xs) (y ∷ ys) ∋ px ∷ pxs) ≡ (qx ∷ qxs) → pxs ≡ qxs
+  ∷-injectiveʳ P.refl = P.refl
+
+  ∷ʳ-injective : ∀ {y xs ys} {pxs qxs : Sublist R xs ys} →
+                 (Sublist R xs (y ∷ ys) ∋ y ∷ʳ pxs) ≡ (y ∷ʳ qxs) → pxs ≡ qxs
+  ∷ʳ-injective P.refl = P.refl
+
+module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where
+
+  length-mono-≤ : ∀ {as bs} → Sublist R as bs → length as ≤ length bs
+  length-mono-≤ []        = z≤n
+  length-mono-≤ (y ∷ʳ rs) = ℕₚ.m≤n⇒m≤1+n (length-mono-≤ rs)
+  length-mono-≤ (r ∷ rs)  = s≤s (length-mono-≤ rs)
+
+------------------------------------------------------------------------
+-- Conversion to and from Pointwise (proto-reflexivity)
+
+  fromPointwise : Pointwise R ⇒ Sublist R
+  fromPointwise []       = []
+  fromPointwise (p ∷ ps) = p ∷ fromPointwise ps
+
+  toPointwise : ∀ {as bs} → length as ≡ length bs →
+                Sublist R as bs → Pointwise R as bs
+  toPointwise {bs = []}     eq []         = []
+  toPointwise {bs = b ∷ bs} eq (r ∷ rs)   = r ∷ toPointwise (ℕₚ.suc-injective eq) rs
+  toPointwise {bs = b ∷ bs} eq (b ∷ʳ rs) =
+    ⊥-elim $ ℕₚ.<-irrefl eq (s≤s (length-mono-≤ rs))
+
+------------------------------------------------------------------------
+-- Various functions' outputs are sublists
+
+-- These lemmas are generalisations of results of the form `f xs ⊆ xs`.
+-- (where _⊆_ stands for Sublist R). If R is reflexive then we can
+-- indeed obtain `f xs ⊆ xs` from `xs ⊆ ys → f xs ⊆ ys`. The other
+-- direction is only true if R is both reflexive and transitive.
+
+module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where
+
+  tail-Sublist : ∀ {as bs} → Sublist R as bs →
+                 MAll.All (λ as → Sublist R as bs) (tail as)
+  tail-Sublist []        = nothing
+  tail-Sublist (b ∷ʳ ps) = MAll.map (b ∷ʳ_) (tail-Sublist ps)
+  tail-Sublist (p ∷ ps)  = just (_ ∷ʳ ps)
+
+  take-Sublist : ∀ {as bs} n → Sublist R as bs → Sublist R (take n as) bs
+  take-Sublist n       (y ∷ʳ rs) = y ∷ʳ take-Sublist n rs
+  take-Sublist zero    rs        = minimum _
+  take-Sublist (suc n) []        = []
+  take-Sublist (suc n) (r ∷ rs)  = r ∷ take-Sublist n rs
+
+  drop-Sublist : ∀ n → Sublist R ⇒ (Sublist R ∘′ drop n)
+  drop-Sublist n       (y ∷ʳ rs) = y ∷ʳ drop-Sublist n rs
+  drop-Sublist zero    rs        = rs
+  drop-Sublist (suc n) []        = []
+  drop-Sublist (suc n) (r ∷ rs)  = _ ∷ʳ drop-Sublist n rs
+
+module _ {a b r p} {A : Set a} {B : Set b}
+         {R : REL A B r} {P : Pred A p} (P? : U.Decidable P) where
+
+  takeWhile-Sublist : ∀ {as bs} → Sublist R as bs → Sublist R (takeWhile P? as) bs
+  takeWhile-Sublist []        = []
+  takeWhile-Sublist (y ∷ʳ rs) = y ∷ʳ takeWhile-Sublist rs
+  takeWhile-Sublist {a ∷ as} (r ∷ rs) with does (P? a)
+  ... | true  = r ∷ takeWhile-Sublist rs
+  ... | false = minimum _
+
+  dropWhile-Sublist : ∀ {as bs} → Sublist R as bs → Sublist R (dropWhile P? as) bs
+  dropWhile-Sublist []        = []
+  dropWhile-Sublist (y ∷ʳ rs) = y ∷ʳ dropWhile-Sublist rs
+  dropWhile-Sublist {a ∷ as} (r ∷ rs) with does (P? a)
+  ... | true  = _ ∷ʳ dropWhile-Sublist rs
+  ... | false = r ∷ rs
+
+  filter-Sublist : ∀ {as bs} → Sublist R as bs → Sublist R (filter P? as) bs
+  filter-Sublist []        = []
+  filter-Sublist (y ∷ʳ rs) = y ∷ʳ filter-Sublist rs
+  filter-Sublist {a ∷ as} (r ∷ rs) with does (P? a)
+  ... | true  = r ∷ filter-Sublist rs
+  ... | false = _ ∷ʳ filter-Sublist rs
+
+------------------------------------------------------------------------
+-- Various functions are increasing wrt _⊆_
+
+-- We write f⁺ for the proof that `xs ⊆ ys → f xs ⊆ f ys`
+-- and f⁻ for the one that `f xs ⊆ f ys → xs ⊆ ys`.
+
+module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where
+
+------------------------------------------------------------------------
+-- _∷_
+
+  ∷ˡ⁻ : ∀ {a as bs} → Sublist R (a ∷ as) bs → Sublist R as bs
+  ∷ˡ⁻ (y ∷ʳ rs) = y ∷ʳ ∷ˡ⁻ rs
+  ∷ˡ⁻ (r ∷  rs) = _ ∷ʳ rs
+
+  ∷ʳ⁻ : ∀ {a as b bs} → ¬ R a b → Sublist R (a ∷ as) (b ∷ bs) →
+        Sublist R (a ∷ as) bs
+  ∷ʳ⁻ ¬r (y ∷ʳ rs) = rs
+  ∷ʳ⁻ ¬r (r ∷  rs) = ⊥-elim (¬r r)
+
+  ∷⁻ : ∀ {a as b bs} → Sublist R (a ∷ as) (b ∷ bs) → Sublist R as bs
+  ∷⁻ (y ∷ʳ rs) = ∷ˡ⁻ rs
+  ∷⁻ (x ∷  rs) = rs
+
+module _ {a b c d r} {A : Set a} {B : Set b} {C : Set c} {D : Set d}
+         {R : REL C D r} where
+
+------------------------------------------------------------------------
+-- map
+
+  map⁺ : ∀ {as bs} (f : A → C) (g : B → D) →
+         Sublist (λ a b → R (f a) (g b)) as bs →
+         Sublist R (List.map f as) (List.map g bs)
+  map⁺ f g []        = []
+  map⁺ f g (y ∷ʳ rs) = g y ∷ʳ map⁺ f g rs
+  map⁺ f g (r ∷ rs)  = r ∷ map⁺ f g rs
+
+  map⁻ : ∀ {as bs} (f : A → C) (g : B → D) →
+         Sublist R (List.map f as) (List.map g bs) →
+         Sublist (λ a b → R (f a) (g b)) as bs
+  map⁻ {[]}     {bs}     f g rs        = minimum _
+  map⁻ {a ∷ as} {b ∷ bs} f g (_ ∷ʳ rs) = b ∷ʳ map⁻ f g rs
+  map⁻ {a ∷ as} {b ∷ bs} f g (r ∷ rs)  = r ∷ map⁻ f g rs
+
+
+module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where
+
+------------------------------------------------------------------------
+-- _++_
+
+  ++⁺ : ∀ {as bs cs ds} → Sublist R as bs → Sublist R cs ds →
+        Sublist R (as ++ cs) (bs ++ ds)
+  ++⁺ []         cds = cds
+  ++⁺ (y ∷ʳ abs) cds = y ∷ʳ ++⁺ abs cds
+  ++⁺ (ab ∷ abs) cds = ab ∷ ++⁺ abs cds
+
+  ++⁻ : ∀ {as bs cs ds} → length as ≡ length bs →
+        Sublist R (as ++ cs) (bs ++ ds) → Sublist R cs ds
+  ++⁻ {[]}     {[]}     eq rs = rs
+  ++⁻ {a ∷ as} {b ∷ bs} eq rs = ++⁻ (ℕₚ.suc-injective eq) (∷⁻ rs)
+
+  ++ˡ : ∀ {as bs} (cs : List B) → Sublist R as bs → Sublist R as (cs ++ bs)
+  ++ˡ zs = ++⁺ (minimum zs)
+
+  ++ʳ : ∀ {as bs} (cs : List B) → Sublist R as bs → Sublist R as (bs ++ cs)
+  ++ʳ cs []        = minimum cs
+  ++ʳ cs (y ∷ʳ rs) = y ∷ʳ ++ʳ cs rs
+  ++ʳ cs (r ∷ rs)  = r ∷ ++ʳ cs rs
+
+
+------------------------------------------------------------------------
+-- concat
+
+  concat⁺ : ∀ {ass bss} → Sublist (Sublist R) ass bss →
+            Sublist R (concat ass) (concat bss)
+  concat⁺ []          = []
+  concat⁺ (y  ∷ʳ rss) = ++ˡ y (concat⁺ rss)
+  concat⁺ (rs ∷  rss) = ++⁺ rs (concat⁺ rss)
+
+------------------------------------------------------------------------
+-- take / drop
+
+  take⁺ : ∀ {m n as bs} → m ≤ n → Pointwise R as bs →
+          Sublist R (take m as) (take n bs)
+  take⁺ z≤n       ps        = minimum _
+  take⁺ (s≤s m≤n) []        = []
+  take⁺ (s≤s m≤n) (p ∷  ps) = p ∷ take⁺ m≤n ps
+
+  drop⁺ : ∀ {m n as bs} → m ≥ n → Sublist R as bs →
+          Sublist R (drop m as) (drop n bs)
+  drop⁺ {m} z≤n       rs        = drop-Sublist m rs
+  drop⁺     (s≤s m≥n) []        = []
+  drop⁺     (s≤s m≥n) (y ∷ʳ rs) = drop⁺ (ℕₚ.m≤n⇒m≤1+n m≥n) rs
+  drop⁺     (s≤s m≥n) (r ∷ rs)  = drop⁺ m≥n rs
+
+  drop⁺-≥ : ∀ {m n as bs} → m ≥ n → Pointwise R as bs →
+            Sublist R (drop m as) (drop n bs)
+  drop⁺-≥ m≥n pw = drop⁺ m≥n (fromPointwise pw)
+
+  drop⁺-⊆ : ∀ {as bs} m → Sublist R as bs →
+            Sublist R (drop m as) (drop m bs)
+  drop⁺-⊆ m = drop⁺ (ℕₚ.≤-refl {m})
+
+module _ {a b r p q} {A : Set a} {B : Set b}
+         {R : REL A B r} {P : Pred A p} {Q : Pred B q}
+         (P? : U.Decidable P) (Q? : U.Decidable Q) where
+
+  ⊆-takeWhile-Sublist : ∀ {as bs} →
+    (∀ {a b} → R a b → P a → Q b) →
+    Pointwise R as bs → Sublist R (takeWhile P? as) (takeWhile Q? bs)
+  ⊆-takeWhile-Sublist rp⇒q [] = []
+  ⊆-takeWhile-Sublist {a ∷ as} {b ∷ bs} rp⇒q (p ∷ ps) with P? a | Q? b
+  ... | false because _ | _               = minimum _
+  ... | true  because _ | true  because _ = p ∷ ⊆-takeWhile-Sublist rp⇒q ps
+  ... | yes pa          | no ¬qb          = ⊥-elim $ ¬qb $ rp⇒q p pa
+
+  ⊇-dropWhile-Sublist : ∀ {as bs} →
+    (∀ {a b} → R a b → Q b → P a) →
+    Pointwise R as bs → Sublist R (dropWhile P? as) (dropWhile Q? bs)
+  ⊇-dropWhile-Sublist rq⇒p [] = []
+  ⊇-dropWhile-Sublist {a ∷ as} {b ∷ bs} rq⇒p (p ∷ ps) with P? a | Q? b
+  ... | true  because _ | true  because _ = ⊇-dropWhile-Sublist rq⇒p ps
+  ... | true  because _ | false because _ =
+    b ∷ʳ dropWhile-Sublist P? (fromPointwise ps)
+  ... | false because _ | false because _ = p ∷ fromPointwise ps
+  ... | no ¬pa          | yes qb          = ⊥-elim $ ¬pa $ rq⇒p p qb
+
+  ⊆-filter-Sublist : ∀ {as bs} → (∀ {a b} → R a b → P a → Q b) →
+                     Sublist R as bs → Sublist R (filter P? as) (filter Q? bs)
+  ⊆-filter-Sublist rp⇒q [] = []
+  ⊆-filter-Sublist rp⇒q (y ∷ʳ rs) with does (Q? y)
+  ... | true  = y ∷ʳ ⊆-filter-Sublist rp⇒q rs
+  ... | false = ⊆-filter-Sublist rp⇒q rs
+  ⊆-filter-Sublist {a ∷ as} {b ∷ bs} rp⇒q (r ∷ rs) with P? a | Q? b
+  ... | true  because _ | true  because _ = r ∷ ⊆-filter-Sublist rp⇒q rs
+  ... | false because _ | true  because _ = _ ∷ʳ ⊆-filter-Sublist rp⇒q rs
+  ... | false because _ | false because _ = ⊆-filter-Sublist rp⇒q rs
+  ... | yes pa          | no ¬qb          = ⊥-elim $ ¬qb $ rp⇒q r pa
+
+module _ {a r p} {A : Set a} {R : Rel A r} {P : Pred A p} (P? : U.Decidable P) where
+
+  takeWhile-filter : ∀ {as} → Pointwise R as as →
+                     Sublist R (takeWhile P? as) (filter P? as)
+  takeWhile-filter [] = []
+  takeWhile-filter {a ∷ as} (p ∷ ps) with does (P? a)
+  ... | true  = p ∷ takeWhile-filter ps
+  ... | false = minimum _
+
+  filter-dropWhile : ∀ {as} → Pointwise R as as →
+                     Sublist R (filter P? as) (dropWhile (¬? ∘ P?) as)
+  filter-dropWhile [] = []
+  filter-dropWhile {a ∷ as} (p ∷ ps) with does (P? a)
+  ... | true  = p ∷ filter-Sublist P? (fromPointwise ps)
+  ... | false = filter-dropWhile ps
+
+------------------------------------------------------------------------
+-- reverse
+
+module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where
+
+  reverseAcc⁺ : ∀ {as bs cs ds} → Sublist R as bs → Sublist R cs ds →
+                Sublist R (reverseAcc cs as) (reverseAcc ds bs)
+  reverseAcc⁺ []         cds = cds
+  reverseAcc⁺ (y ∷ʳ abs) cds = reverseAcc⁺ abs (y ∷ʳ cds)
+  reverseAcc⁺ (r ∷ abs)  cds = reverseAcc⁺ abs (r ∷ cds)
+
+  ʳ++⁺ : ∀ {as bs cs ds} →
+         Sublist R as bs →
+         Sublist R cs ds →
+         Sublist R (as ʳ++ cs) (bs ʳ++ ds)
+  ʳ++⁺ = reverseAcc⁺
+
+  reverse⁺ : ∀ {as bs} → Sublist R as bs → Sublist R (reverse as) (reverse bs)
+  reverse⁺ rs = reverseAcc⁺ rs []
+
+  reverse⁻ : ∀ {as bs} → Sublist R (reverse as) (reverse bs) → Sublist R as bs
+  reverse⁻ {as} {bs} p = cast (reverse⁺ p) where
+    cast = P.subst₂ (Sublist R) (Lₚ.reverse-involutive as) (Lₚ.reverse-involutive bs)
+
+------------------------------------------------------------------------
+-- Inversion lemmas
+
+module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} {a as b bs} where
+
+  ∷⁻¹ : R a b → Sublist R as bs ⇔ Sublist R (a ∷ as) (b ∷ bs)
+  ∷⁻¹ r = mk⇔ (r ∷_) ∷⁻
+
+  ∷ʳ⁻¹ : ¬ R a b → Sublist R (a ∷ as) bs ⇔ Sublist R (a ∷ as) (b ∷ bs)
+  ∷ʳ⁻¹ ¬r = mk⇔ (_ ∷ʳ_) (∷ʳ⁻ ¬r)
+
+------------------------------------------------------------------------
+-- Irrelevant special case
+
+module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where
+
+  Sublist-[]-irrelevant : U.Irrelevant (Sublist R [])
+  Sublist-[]-irrelevant []       []        = P.refl
+  Sublist-[]-irrelevant (y ∷ʳ p) (.y ∷ʳ q) = P.cong (y ∷ʳ_) (Sublist-[]-irrelevant p q)
+
+------------------------------------------------------------------------
+-- (to/from)Any is a bijection
+
+  toAny-injective : ∀ {xs x} {p q : Sublist R [ x ] xs} → toAny p ≡ toAny q → p ≡ q
+  toAny-injective {p = y ∷ʳ p} {y ∷ʳ q} =
+    P.cong (y ∷ʳ_) ∘′ toAny-injective ∘′ there-injective
+  toAny-injective {p = _ ∷ p}  {_ ∷ q}  =
+    P.cong₂ (flip _∷_) (Sublist-[]-irrelevant p q) ∘′ here-injective
+
+  fromAny-injective : ∀ {xs x} {p q : Any (R x) xs} →
+                      fromAny {R = R} p ≡ fromAny q → p ≡ q
+  fromAny-injective {p = here px} {here qx} = P.cong here ∘′ ∷-injectiveˡ
+  fromAny-injective {p = there p} {there q} =
+    P.cong there ∘′ fromAny-injective ∘′ ∷ʳ-injective
+
+  toAny∘fromAny≗id : ∀ {xs x} (p : Any (R x) xs) → toAny (fromAny {R = R} p) ≡ p
+  toAny∘fromAny≗id (here px) = P.refl
+  toAny∘fromAny≗id (there p) = P.cong there (toAny∘fromAny≗id p)
+
+  Sublist-[x]-bijection : ∀ {x xs} → (Sublist R [ x ] xs) ⤖ (Any (R x) xs)
+  Sublist-[x]-bijection = mk⤖ (toAny-injective , strictlySurjective⇒surjective < fromAny , toAny∘fromAny≗id >)
+
+------------------------------------------------------------------------
+-- Relational properties
+
+module Reflexivity
+    {a r} {A : Set a} {R : Rel A r}
+    (R-refl : Reflexive R) where
+
+  reflexive : _≡_ ⇒ Sublist R
+  reflexive P.refl = fromPointwise (Pw.refl R-refl)
+
+  refl : Reflexive (Sublist R)
+  refl = reflexive P.refl
+
+open Reflexivity public
+
+module Transitivity
+    {a b c r s t} {A : Set a} {B : Set b} {C : Set c}
+    {R : REL A B r} {S : REL B C s} {T : REL A C t}
+    (rs⇒t : Trans R S T) where
+
+  trans : Trans (Sublist R) (Sublist S) (Sublist T)
+  trans rs        (y ∷ʳ ss) = y ∷ʳ trans rs ss
+  trans (y ∷ʳ rs) (s ∷ ss)  = _ ∷ʳ trans rs ss
+  trans (r ∷ rs)  (s ∷ ss)  = rs⇒t r s ∷ trans rs ss
+  trans []        []        = []
+
+open Transitivity public
+
+module Antisymmetry
+    {a b r s e} {A : Set a} {B : Set b}
+    {R : REL A B r} {S : REL B A s} {E : REL A B e}
+    (rs⇒e : Antisym R S E) where
+
+  open ℕₚ.≤-Reasoning
+
+  antisym : Antisym (Sublist R) (Sublist S) (Pointwise E)
+  antisym []        []        = []
+  antisym (r ∷ rs)  (s ∷ ss)  = rs⇒e r s ∷ antisym rs ss
+  -- impossible cases
+  antisym (_∷ʳ_ {xs} {ys₁} y rs) (_∷ʳ_ {ys₂} {zs} z ss) =
+    ⊥-elim $ ℕₚ.<-irrefl P.refl $ begin
+    length (y ∷ ys₁) ≤⟨ length-mono-≤ ss ⟩
+    length zs        ≤⟨ ℕₚ.n≤1+n (length zs) ⟩
+    length (z ∷ zs)  ≤⟨ length-mono-≤ rs ⟩
+    length ys₁       ∎
+  antisym (_∷ʳ_ {xs} {ys₁} y rs) (_∷_ {y} {ys₂} {z} {zs} s ss)  =
+    ⊥-elim $ ℕₚ.<-irrefl P.refl $ begin
+    length (z ∷ zs) ≤⟨ length-mono-≤ rs ⟩
+    length ys₁      ≤⟨ length-mono-≤ ss ⟩
+    length zs       ∎
+  antisym (_∷_ {x} {xs} {y} {ys₁} r rs)  (_∷ʳ_ {ys₂} {zs} z ss) =
+    ⊥-elim $ ℕₚ.<-irrefl P.refl $ begin
+    length (y ∷ ys₁) ≤⟨ length-mono-≤ ss ⟩
+    length xs        ≤⟨ length-mono-≤ rs ⟩
+    length ys₁       ∎
+
+open Antisymmetry public
+
+module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} (R? : Decidable R) where
+
+  sublist? : Decidable (Sublist R)
+  sublist? []       ys       = yes (minimum ys)
+  sublist? (x ∷ xs) []       = no λ ()
+  sublist? (x ∷ xs) (y ∷ ys) with R? x y
+  ... | true  because  [r] =
+    Dec.map (∷⁻¹  (invert  [r])) (sublist? xs ys)
+  ... | false because [¬r] =
+    Dec.map (∷ʳ⁻¹ (invert [¬r])) (sublist? (x ∷ xs) ys)
+
+module _ {a e r} {A : Set a} {E : Rel A e} {R : Rel A r} where
+
+  isPreorder : IsPreorder E R → IsPreorder (Pointwise E) (Sublist R)
+  isPreorder ER-isPreorder = record
+    { isEquivalence = Pw.isEquivalence       ER.isEquivalence
+    ; reflexive     = fromPointwise ∘ Pw.map ER.reflexive
+    ; trans         = trans                  ER.trans
+    } where module ER = IsPreorder ER-isPreorder
+
+  isPartialOrder : IsPartialOrder E R → IsPartialOrder (Pointwise E) (Sublist R)
+  isPartialOrder ER-isPartialOrder = record
+    { isPreorder = isPreorder ER.isPreorder
+    ; antisym    = antisym    ER.antisym
+    } where module ER = IsPartialOrder ER-isPartialOrder
+
+  isDecPartialOrder : IsDecPartialOrder E R →
+                      IsDecPartialOrder (Pointwise E) (Sublist R)
+  isDecPartialOrder ER-isDecPartialOrder = record
+    { isPartialOrder = isPartialOrder ER.isPartialOrder
+    ; _≟_            = Pw.decidable   ER._≟_
+    ; _≤?_           = sublist?       ER._≤?_
+    } where module ER = IsDecPartialOrder ER-isDecPartialOrder
+
+module _ {a e r} where
+
+  preorder : Preorder a e r → Preorder _ _ _
+  preorder ER-preorder = record
+    { isPreorder = isPreorder ER.isPreorder
+    } where module ER = Preorder ER-preorder
+
+  poset : Poset a e r → Poset _ _ _
+  poset ER-poset = record
+    { isPartialOrder = isPartialOrder ER.isPartialOrder
+    } where module ER = Poset ER-poset
+
+  decPoset : DecPoset a e r → DecPoset _ _ _
+  decPoset ER-poset = record
+    { isDecPartialOrder = isDecPartialOrder ER.isDecPartialOrder
+    } where module ER = DecPoset ER-poset
+
+------------------------------------------------------------------------
+-- Properties of disjoint sublists
+
+module Disjointness {a b r} {A : Set a} {B : Set b} {R : REL A B r} where
+
+  private
+    infix 4 _⊆_
+    _⊆_ = Sublist R
+
+  -- Forgetting the union
+
+  DisjointUnion→Disjoint : ∀ {xs ys zs us} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} {τ : us ⊆ zs} →
+    DisjointUnion τ₁ τ₂ τ → Disjoint τ₁ τ₂
+  DisjointUnion→Disjoint []         = []
+  DisjointUnion→Disjoint (y   ∷ₙ u) = y   ∷ₙ DisjointUnion→Disjoint u
+  DisjointUnion→Disjoint (x≈y ∷ₗ u) = x≈y ∷ₗ DisjointUnion→Disjoint u
+  DisjointUnion→Disjoint (x≈y ∷ᵣ u) = x≈y ∷ᵣ DisjointUnion→Disjoint u
+
+  -- Reconstructing the union
+
+  Disjoint→DisjointUnion : ∀ {xs ys zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} →
+    Disjoint τ₁ τ₂ → ∃₂ λ us (τ : us ⊆ zs) → DisjointUnion τ₁ τ₂ τ
+  Disjoint→DisjointUnion []         = _ , _ , []
+  Disjoint→DisjointUnion (y   ∷ₙ u) = _ , _ , y   ∷ₙ proj₂ (proj₂ (Disjoint→DisjointUnion u))
+  Disjoint→DisjointUnion (x≈y ∷ₗ u) = _ , _ , x≈y ∷ₗ proj₂ (proj₂ (Disjoint→DisjointUnion u))
+  Disjoint→DisjointUnion (x≈y ∷ᵣ u) = _ , _ , x≈y ∷ᵣ proj₂ (proj₂ (Disjoint→DisjointUnion u))
+
+  -- Disjoint is decidable
+
+  ⊆-disjoint? : ∀ {xs ys zs} (τ₁ : xs ⊆ zs) (τ₂ : ys ⊆ zs) → Dec (Disjoint τ₁ τ₂)
+  ⊆-disjoint? [] [] = yes []
+  -- Present in both sublists: not disjoint.
+  ⊆-disjoint? (x≈z ∷ τ₁) (y≈z ∷ τ₂) = no λ()
+  -- Present in either sublist: ok.
+  ⊆-disjoint? (y ∷ʳ τ₁) (x≈y ∷ τ₂) =
+    Dec.map′ (x≈y ∷ᵣ_) (λ{ (_ ∷ᵣ d) → d }) (⊆-disjoint? τ₁ τ₂)
+  ⊆-disjoint? (x≈y ∷ τ₁) (y ∷ʳ τ₂) =
+    Dec.map′ (x≈y ∷ₗ_) (λ{ (_ ∷ₗ d) → d }) (⊆-disjoint? τ₁ τ₂)
+  -- Present in neither sublist: ok.
+  ⊆-disjoint? (y ∷ʳ τ₁) (.y ∷ʳ τ₂) =
+    Dec.map′ (y ∷ₙ_) (λ{ (_ ∷ₙ d) → d }) (⊆-disjoint? τ₁ τ₂)
+
+  -- Disjoint is proof-irrelevant
+
+  Disjoint-irrelevant : ∀{xs ys zs} → Irrelevant (Disjoint {R = R} {xs} {ys} {zs})
+  Disjoint-irrelevant [] [] = P.refl
+  Disjoint-irrelevant (y   ∷ₙ d₁) (.y   ∷ₙ d₂) = P.cong (y ∷ₙ_) (Disjoint-irrelevant d₁ d₂)
+  Disjoint-irrelevant (x≈y ∷ₗ d₁) (.x≈y ∷ₗ d₂) = P.cong (x≈y ∷ₗ_) (Disjoint-irrelevant d₁ d₂)
+  Disjoint-irrelevant (x≈y ∷ᵣ d₁) (.x≈y ∷ᵣ d₂) = P.cong (x≈y ∷ᵣ_) (Disjoint-irrelevant d₁ d₂)
+
+  -- Note: DisjointUnion is not proof-irrelevant unless the underlying relation R is.
+  -- The proof is not entirely trivial, thus, we leave it for future work:
+  --
+  -- DisjointUnion-irrelevant : Irrelevant R →
+  --                            ∀{xs ys us zs} {τ : us ⊆ zs} →
+  --                            Irrelevant (λ (τ₁ : xs ⊆ zs) (τ₂ : ys ⊆ zs) → DisjointUnion τ₁ τ₂ τ)
+
+  -- Irreflexivity
+
+  Disjoint-irrefl′ : ∀{xs ys} {τ : xs ⊆ ys} → Disjoint τ τ → Null xs
+  Disjoint-irrefl′ []       = []
+  Disjoint-irrefl′ (y ∷ₙ d) = Disjoint-irrefl′ d
+
+  Disjoint-irrefl : ∀{x xs ys} → Irreflexive {A = x ∷ xs ⊆ ys } _≡_ Disjoint
+  Disjoint-irrefl P.refl x with Disjoint-irrefl′ x
+  ... | () ∷ _
+
+  -- Symmetry
+
+  DisjointUnion-sym : ∀ {xs ys xys} {zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} {τ : xys ⊆ zs} →
+                            DisjointUnion τ₁ τ₂ τ → DisjointUnion τ₂ τ₁ τ
+  DisjointUnion-sym []         = []
+  DisjointUnion-sym (y   ∷ₙ d) = y ∷ₙ DisjointUnion-sym d
+  DisjointUnion-sym (x≈y ∷ₗ d) = x≈y ∷ᵣ DisjointUnion-sym d
+  DisjointUnion-sym (x≈y ∷ᵣ d) = x≈y ∷ₗ DisjointUnion-sym d
+
+  Disjoint-sym : ∀ {xs ys} {zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} →
+                 Disjoint τ₁ τ₂ → Disjoint τ₂ τ₁
+  Disjoint-sym []         = []
+  Disjoint-sym (y   ∷ₙ d) = y ∷ₙ Disjoint-sym d
+  Disjoint-sym (x≈y ∷ₗ d) = x≈y ∷ᵣ Disjoint-sym d
+  Disjoint-sym (x≈y ∷ᵣ d) = x≈y ∷ₗ Disjoint-sym d
+
+  -- Empty sublist
+
+  DisjointUnion-[]ˡ : ∀{xs ys} {ε : [] ⊆ ys} {τ : xs ⊆ ys} → DisjointUnion ε τ τ
+  DisjointUnion-[]ˡ {ε = []}     {τ = []} = []
+  DisjointUnion-[]ˡ {ε = y ∷ʳ ε} {τ = y  ∷ʳ τ} = y   ∷ₙ DisjointUnion-[]ˡ
+  DisjointUnion-[]ˡ {ε = y ∷ʳ ε} {τ = x≈y ∷ τ} = x≈y ∷ᵣ DisjointUnion-[]ˡ
+
+  DisjointUnion-[]ʳ : ∀{xs ys} {ε : [] ⊆ ys} {τ : xs ⊆ ys} → DisjointUnion τ ε τ
+  DisjointUnion-[]ʳ {ε = []}     {τ = []} = []
+  DisjointUnion-[]ʳ {ε = y ∷ʳ ε} {τ = y  ∷ʳ τ} = y   ∷ₙ DisjointUnion-[]ʳ
+  DisjointUnion-[]ʳ {ε = y ∷ʳ ε} {τ = x≈y ∷ τ} = x≈y ∷ₗ DisjointUnion-[]ʳ
+
+  -- A sublist τ : x∷xs ⊆ ys can be split into two disjoint sublists
+  -- [x] ⊆ ys (canonical choice) and (∷ˡ⁻ τ) : xs ⊆ ys.
+
+  DisjointUnion-fromAny∘toAny-∷ˡ⁻ : ∀ {x xs ys} (τ : (x ∷ xs) ⊆ ys) → DisjointUnion (fromAny (toAny τ)) (∷ˡ⁻ τ) τ
+  DisjointUnion-fromAny∘toAny-∷ˡ⁻ (y  ∷ʳ τ) = y   ∷ₙ DisjointUnion-fromAny∘toAny-∷ˡ⁻ τ
+  DisjointUnion-fromAny∘toAny-∷ˡ⁻ (xRy ∷ τ) = xRy ∷ₗ DisjointUnion-[]ˡ
+
+  -- Disjoint union of three mutually disjoint lists.
+  --
+  -- τᵢⱼ denotes the disjoint union of τᵢ and τⱼ: DisjointUnion τᵢ τⱼ τᵢⱼ
+
+  record DisjointUnion³
+    {xs ys zs ts} (τ₁  : xs  ⊆ ts) (τ₂  : ys  ⊆ ts) (τ₃  : zs  ⊆ ts)
+    {xys xzs yzs} (τ₁₂ : xys ⊆ ts) (τ₁₃ : xzs ⊆ ts) (τ₂₃ : yzs ⊆ ts) : Set (a ⊔ b ⊔ r) where
+    field
+      {union³} : List A
+      sub³  : union³ ⊆ ts
+      join₁ : DisjointUnion τ₁ τ₂₃ sub³
+      join₂ : DisjointUnion τ₂ τ₁₃ sub³
+      join₃ : DisjointUnion τ₃ τ₁₂ sub³
+
+  infixr 5 _∷ʳ-DisjointUnion³_ _∷₁-DisjointUnion³_ _∷₂-DisjointUnion³_ _∷₃-DisjointUnion³_
+
+  -- Weakening the target list ts of a disjoint union.
+
+  _∷ʳ-DisjointUnion³_ :
+    ∀ {xs ys zs ts} {τ₁ : xs ⊆ ts} {τ₂ : ys ⊆ ts} {τ₃ : zs ⊆ ts} →
+    ∀ {xys xzs yzs} {τ₁₂ : xys ⊆ ts} {τ₁₃ : xzs ⊆ ts} {τ₂₃ : yzs ⊆ ts} →
+    ∀ y →
+    DisjointUnion³ τ₁ τ₂ τ₃ τ₁₂ τ₁₃ τ₂₃ →
+    DisjointUnion³ (y ∷ʳ τ₁) (y ∷ʳ τ₂) (y ∷ʳ τ₃) (y ∷ʳ τ₁₂) (y ∷ʳ τ₁₃) (y ∷ʳ τ₂₃)
+  y ∷ʳ-DisjointUnion³ record{ sub³ = σ ; join₁ = d₁ ; join₂ = d₂ ; join₃ = d₃ } = record
+    { sub³  = y ∷ʳ σ
+    ; join₁ = y ∷ₙ d₁
+    ; join₂ = y ∷ₙ d₂
+    ; join₃ = y ∷ₙ d₃
+    }
+
+  -- Adding an element to the first list.
+
+  _∷₁-DisjointUnion³_ :
+    ∀ {xs ys zs ts} {τ₁ : xs ⊆ ts} {τ₂ : ys ⊆ ts} {τ₃ : zs ⊆ ts} →
+    ∀ {xys xzs yzs} {τ₁₂ : xys ⊆ ts} {τ₁₃ : xzs ⊆ ts} {τ₂₃ : yzs ⊆ ts} →
+    ∀ {x y} (xRy : R x y) →
+    DisjointUnion³ τ₁ τ₂ τ₃ τ₁₂ τ₁₃ τ₂₃ →
+    DisjointUnion³ (xRy ∷ τ₁) (y ∷ʳ τ₂) (y ∷ʳ τ₃) (xRy ∷ τ₁₂) (xRy ∷ τ₁₃) (y ∷ʳ τ₂₃)
+  xRy ∷₁-DisjointUnion³ record{ sub³ = σ ; join₁ = d₁ ; join₂ = d₂ ; join₃ = d₃ } = record
+    { sub³  = xRy ∷ σ
+    ; join₁ = xRy ∷ₗ d₁
+    ; join₂ = xRy ∷ᵣ d₂
+    ; join₃ = xRy ∷ᵣ d₃
+    }
+
+  -- Adding an element to the second list.
+
+  _∷₂-DisjointUnion³_ :
+    ∀ {xs ys zs ts} {τ₁ : xs ⊆ ts} {τ₂ : ys ⊆ ts} {τ₃ : zs ⊆ ts} →
+    ∀ {xys xzs yzs} {τ₁₂ : xys ⊆ ts} {τ₁₃ : xzs ⊆ ts} {τ₂₃ : yzs ⊆ ts} →
+    ∀ {x y} (xRy : R x y) →
+    DisjointUnion³ τ₁ τ₂ τ₃ τ₁₂ τ₁₃ τ₂₃ →
+    DisjointUnion³ (y ∷ʳ τ₁) (xRy ∷ τ₂) (y ∷ʳ τ₃) (xRy ∷ τ₁₂) (y ∷ʳ τ₁₃) (xRy ∷ τ₂₃)
+  xRy ∷₂-DisjointUnion³ record{ sub³ = σ ; join₁ = d₁ ; join₂ = d₂ ; join₃ = d₃ } = record
+    { sub³  = xRy ∷ σ
+    ; join₁ = xRy ∷ᵣ d₁
+    ; join₂ = xRy ∷ₗ d₂
+    ; join₃ = xRy ∷ᵣ d₃
+    }
+
+  -- Adding an element to the third list.
+
+  _∷₃-DisjointUnion³_ :
+    ∀ {xs ys zs ts} {τ₁ : xs ⊆ ts} {τ₂ : ys ⊆ ts} {τ₃ : zs ⊆ ts} →
+    ∀ {xys xzs yzs} {τ₁₂ : xys ⊆ ts} {τ₁₃ : xzs ⊆ ts} {τ₂₃ : yzs ⊆ ts} →
+    ∀ {x y} (xRy : R x y) →
+    DisjointUnion³ τ₁ τ₂ τ₃ τ₁₂ τ₁₃ τ₂₃ →
+    DisjointUnion³ (y ∷ʳ τ₁) (y ∷ʳ τ₂) (xRy ∷ τ₃) (y ∷ʳ τ₁₂) (xRy ∷ τ₁₃) (xRy ∷ τ₂₃)
+  xRy ∷₃-DisjointUnion³ record{ sub³ = σ ; join₁ = d₁ ; join₂ = d₂ ; join₃ = d₃ } = record
+    { sub³  = xRy ∷ σ
+    ; join₁ = xRy ∷ᵣ d₁
+    ; join₂ = xRy ∷ᵣ d₂
+    ; join₃ = xRy ∷ₗ d₃
+    }
+
+  -- Computing the disjoint union of three disjoint lists.
+
+  disjointUnion³ : ∀{xs ys zs ts} {τ₁ : xs ⊆ ts} {τ₂ : ys ⊆ ts} {τ₃ : zs ⊆ ts}
+    {xys xzs yzs} {τ₁₂ : xys ⊆ ts} {τ₁₃ : xzs ⊆ ts} {τ₂₃ : yzs ⊆ ts} →
+    DisjointUnion τ₁ τ₂ τ₁₂ →
+    DisjointUnion τ₁ τ₃ τ₁₃ →
+    DisjointUnion τ₂ τ₃ τ₂₃ →
+    DisjointUnion³ τ₁ τ₂ τ₃ τ₁₂ τ₁₃ τ₂₃
+  disjointUnion³ [] [] [] = record { sub³ = [] ; join₁ = [] ; join₂ = [] ; join₃ = [] }
+  disjointUnion³ (y   ∷ₙ d₁₂) (.y  ∷ₙ d₁₃) (.y   ∷ₙ d₂₃) = y ∷ʳ-DisjointUnion³ disjointUnion³ d₁₂ d₁₃ d₂₃
+  disjointUnion³ (y   ∷ₙ d₁₂) (xRy ∷ᵣ d₁₃) (.xRy ∷ᵣ d₂₃) = xRy ∷₃-DisjointUnion³ disjointUnion³ d₁₂ d₁₃ d₂₃
+  disjointUnion³ (xRy ∷ᵣ d₁₂) (y   ∷ₙ d₁₃) (.xRy ∷ₗ d₂₃) = xRy ∷₂-DisjointUnion³ disjointUnion³ d₁₂ d₁₃ d₂₃
+  disjointUnion³ (xRy ∷ₗ d₁₂) (.xRy ∷ₗ d₁₃) (y    ∷ₙ d₂₃) = xRy ∷₁-DisjointUnion³ disjointUnion³ d₁₂ d₁₃ d₂₃
+  disjointUnion³ (xRy ∷ᵣ d₁₂) (xRy′ ∷ᵣ d₁₃) ()
+
+  -- If a sublist τ is disjoint to two lists σ₁ and σ₂,
+  -- then also to their disjoint union σ.
+
+  disjoint⇒disjoint-to-union : ∀{xs ys zs yzs ts}
+    {τ : xs ⊆ ts} {σ₁ : ys ⊆ ts} {σ₂ : zs ⊆ ts} {σ : yzs ⊆ ts} →
+    Disjoint τ σ₁ → Disjoint τ σ₂ → DisjointUnion σ₁ σ₂ σ → Disjoint τ σ
+  disjoint⇒disjoint-to-union d₁ d₂ u = let
+       _ , _ , u₁ = Disjoint→DisjointUnion d₁
+       _ , _ , u₂ = Disjoint→DisjointUnion d₂
+    in DisjointUnion→Disjoint (DisjointUnion³.join₁ (disjointUnion³ u₁ u₂ u))
+
+open Disjointness public
+
+-- Monotonicity of disjointness.
+
+module DisjointnessMonotonicity
+    {a b c r s t} {A : Set a} {B : Set b} {C : Set c}
+    {R : REL A B r} {S : REL B C s} {T : REL A C t}
+    (rs⇒t : Trans R S T) where
+
+  -- We can enlarge and convert the target list of a disjoint union.
+
+  weakenDisjointUnion : ∀ {xs ys xys zs ws}
+    {τ₁ : Sublist R xs zs}
+    {τ₂ : Sublist R ys zs}
+    {τ : Sublist R xys zs} (σ : Sublist S zs ws) →
+    DisjointUnion τ₁ τ₂ τ →
+    DisjointUnion (trans rs⇒t τ₁ σ) (trans rs⇒t τ₂ σ) (trans rs⇒t τ σ)
+  weakenDisjointUnion [] [] = []
+  weakenDisjointUnion (w  ∷ʳ σ) d         = w ∷ₙ weakenDisjointUnion σ d
+  weakenDisjointUnion (_   ∷ σ) (y   ∷ₙ d) = _ ∷ₙ weakenDisjointUnion σ d
+  weakenDisjointUnion (zSw ∷ σ) (xRz ∷ₗ d) = rs⇒t xRz zSw ∷ₗ weakenDisjointUnion σ d
+  weakenDisjointUnion (zSw ∷ σ) (yRz ∷ᵣ d) = rs⇒t yRz zSw ∷ᵣ weakenDisjointUnion σ d
+
+  weakenDisjoint : ∀ {xs ys zs ws}
+    {τ₁ : Sublist R xs zs}
+    {τ₂ : Sublist R ys zs} (σ : Sublist S zs ws) →
+    Disjoint τ₁ τ₂ →
+    Disjoint (trans rs⇒t τ₁ σ) (trans rs⇒t τ₂ σ)
+  weakenDisjoint [] [] = []
+  weakenDisjoint (w  ∷ʳ σ) d         = w ∷ₙ weakenDisjoint σ d
+  weakenDisjoint (_   ∷ σ) (y   ∷ₙ d) = _ ∷ₙ weakenDisjoint σ d
+  weakenDisjoint (zSw ∷ σ) (xRz ∷ₗ d) = rs⇒t xRz zSw ∷ₗ weakenDisjoint σ d
+  weakenDisjoint (zSw ∷ σ) (yRz ∷ᵣ d) = rs⇒t yRz zSw ∷ᵣ weakenDisjoint σ d
+
+  -- Lists remain disjoint when elements are removed.
+
+  shrinkDisjoint : ∀ {us vs xs ys zs}
+                      (σ₁ : Sublist R us xs) {τ₁ : Sublist S xs zs}
+                      (σ₂ : Sublist R vs ys) {τ₂ : Sublist S ys zs} →
+                      Disjoint τ₁ τ₂ →
+                      Disjoint (trans rs⇒t σ₁ τ₁) (trans rs⇒t σ₂ τ₂)
+  shrinkDisjoint σ₁         σ₂ (y   ∷ₙ d) = y ∷ₙ shrinkDisjoint σ₁ σ₂ d
+  shrinkDisjoint (x  ∷ʳ σ₁) σ₂ (xSz ∷ₗ d) = _ ∷ₙ shrinkDisjoint σ₁ σ₂ d
+  shrinkDisjoint (uRx ∷ σ₁) σ₂ (xSz ∷ₗ d) = rs⇒t uRx xSz ∷ₗ shrinkDisjoint σ₁ σ₂ d
+  shrinkDisjoint σ₁ (y  ∷ʳ σ₂) (ySz ∷ᵣ d) = _ ∷ₙ shrinkDisjoint σ₁ σ₂ d
+  shrinkDisjoint σ₁ (vRy ∷ σ₂) (ySz ∷ᵣ d) = rs⇒t vRy ySz ∷ᵣ shrinkDisjoint σ₁ σ₂ d
+  shrinkDisjoint [] []         []         = []
+
+open DisjointnessMonotonicity public
 

\ No newline at end of file
diff --git a/Data.List.Relation.Binary.Sublist.Heterogeneous.html b/Data.List.Relation.Binary.Sublist.Heterogeneous.html
index 782cae8b..9eb52017 100644
--- a/Data.List.Relation.Binary.Sublist.Heterogeneous.html
+++ b/Data.List.Relation.Binary.Sublist.Heterogeneous.html
@@ -9,104 +9,105 @@
 
 {-# OPTIONS --cubical-compatible --safe #-}
 
-open import Data.List.Base using (List; []; _∷_; [_])
-open import Data.List.Relation.Unary.Any using (Any; here; there)
+open import Data.List.Base using (List; []; _∷_; [_])
+open import Data.List.Relation.Unary.Any using (Any; here; there)
 open import Level using (_⊔_)
-open import Relation.Binary
-open import Relation.Binary.PropositionalEquality as P using (_≡_)
-open import Relation.Unary using (Pred)
+open import Relation.Binary.Core using (REL; _⇒_)
+open import Relation.Binary.Definitions using (_⟶_Respects_; Min)
+open import Relation.Binary.PropositionalEquality.Core as P using (_≡_)
+open import Relation.Unary using (Pred)
 
-module Data.List.Relation.Binary.Sublist.Heterogeneous
-  {a b r} {A : Set a} {B : Set b} {R : REL A B r}
-  where
+module Data.List.Relation.Binary.Sublist.Heterogeneous
+  {a b r} {A : Set a} {B : Set b} {R : REL A B r}
+  where
 
-------------------------------------------------------------------------
--- Re-export core definitions
+------------------------------------------------------------------------
+-- Re-export core definitions
 
-open import Data.List.Relation.Binary.Sublist.Heterogeneous.Core public
+open import Data.List.Relation.Binary.Sublist.Heterogeneous.Core public
 
-------------------------------------------------------------------------
--- Type and basic combinators
+------------------------------------------------------------------------
+-- Type and basic combinators
 
-module _ {s} {S : REL A B s} where
+module _ {s} {S : REL A B s} where
 
-  map : R ⇒ S → Sublist R ⇒ Sublist S
-  map f []        = []
-  map f (y ∷ʳ rs) = y ∷ʳ map f rs
-  map f (r ∷ rs)  = f r ∷ map f rs
+  map : R ⇒ S → Sublist R ⇒ Sublist S
+  map f []        = []
+  map f (y ∷ʳ rs) = y ∷ʳ map f rs
+  map f (r ∷ rs)  = f r ∷ map f rs
 
-minimum : Min (Sublist R) []
-minimum []       = []
-minimum (x ∷ xs) = x ∷ʳ minimum xs
+minimum : Min (Sublist R) []
+minimum []       = []
+minimum (x ∷ xs) = x ∷ʳ minimum xs
 
-------------------------------------------------------------------------
--- Conversion to and from Any
+------------------------------------------------------------------------
+-- Conversion to and from Any
 
--- Special case: Sublist R [ a ] bs → Any (R a) bs
-toAny : ∀ {a as bs} → Sublist R (a ∷ as) bs → Any (R a) bs
-toAny (y ∷ʳ rs) = there (toAny rs)
-toAny (r ∷ rs)  = here r
+-- Special case: Sublist R [ a ] bs → Any (R a) bs
+toAny : ∀ {a as bs} → Sublist R (a ∷ as) bs → Any (R a) bs
+toAny (y ∷ʳ rs) = there (toAny rs)
+toAny (r ∷ rs)  = here r
 
-fromAny : ∀ {a bs} → Any (R a) bs → Sublist R [ a ] bs
-fromAny (here r)  = r ∷ minimum _
-fromAny (there p) = _ ∷ʳ fromAny p
+fromAny : ∀ {a bs} → Any (R a) bs → Sublist R [ a ] bs
+fromAny (here r)  = r ∷ minimum _
+fromAny (there p) = _ ∷ʳ fromAny p
 
-------------------------------------------------------------------------
--- Generalised lookup based on a proof of Any
+------------------------------------------------------------------------
+-- Generalised lookup based on a proof of Any
 
-module _ {p q} {P : Pred A p} {Q : Pred B q} (resp : P ⟶ Q Respects R) where
+module _ {p q} {P : Pred A p} {Q : Pred B q} (resp : P ⟶ Q Respects R) where
 
-  lookup : ∀ {xs ys} → Sublist R xs ys → Any P xs → Any Q ys
-  lookup (y ∷ʳ p)  k         = there (lookup p k)
-  lookup (rxy ∷ p) (here px) = here (resp rxy px)
-  lookup (rxy ∷ p) (there k) = there (lookup p k)
+  lookup : ∀ {xs ys} → Sublist R xs ys → Any P xs → Any Q ys
+  lookup (y ∷ʳ p)  k         = there (lookup p k)
+  lookup (rxy ∷ p) (here px) = here (resp rxy px)
+  lookup (rxy ∷ p) (there k) = there (lookup p k)
 
-------------------------------------------------------------------------
--- Disjoint sublists xs,ys ⊆ zs
---
--- NB: This does not imply that xs and ys partition zs;
--- zs may have additional elements.
+------------------------------------------------------------------------
+-- Disjoint sublists xs,ys ⊆ zs
+--
+-- NB: This does not imply that xs and ys partition zs;
+-- zs may have additional elements.
 
-private
-  infix 4 _⊆_
-  _⊆_ = Sublist R
+private
+  infix 4 _⊆_
+  _⊆_ = Sublist R
 
-infixr 5 _∷ₙ_ _∷ₗ_ _∷ᵣ_
+infixr 5 _∷ₙ_ _∷ₗ_ _∷ᵣ_
 
-data Disjoint : ∀ {xs ys zs} (τ₁ : xs ⊆ zs) (τ₂ : ys ⊆ zs) → Set (a ⊔ b ⊔ r) where
-  []   : Disjoint [] []
+data Disjoint : ∀ {xs ys zs} (τ₁ : xs ⊆ zs) (τ₂ : ys ⊆ zs) → Set (a ⊔ b ⊔ r) where
+  []   : Disjoint [] []
 
-  -- Element y of zs is neither in xs nor in ys:
-  _∷ₙ_ : ∀ {xs ys zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} →
-         (y : B)       → Disjoint τ₁ τ₂ → Disjoint (y  ∷ʳ τ₁) (y  ∷ʳ τ₂)
+  -- Element y of zs is neither in xs nor in ys:
+  _∷ₙ_ : ∀ {xs ys zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} →
+         (y : B)       → Disjoint τ₁ τ₂ → Disjoint (y  ∷ʳ τ₁) (y  ∷ʳ τ₂)
 
-  -- Element y of zs is in xs as x with x≈y:
-  _∷ₗ_ : ∀ {xs ys zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} {x y} →
-         (x≈y : R x y) → Disjoint τ₁ τ₂ → Disjoint (x≈y ∷ τ₁) (y  ∷ʳ τ₂)
+  -- Element y of zs is in xs as x with x≈y:
+  _∷ₗ_ : ∀ {xs ys zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} {x y} →
+         (x≈y : R x y) → Disjoint τ₁ τ₂ → Disjoint (x≈y ∷ τ₁) (y  ∷ʳ τ₂)
 
-  -- Element y of zs is in ys as x with x≈y:
-  _∷ᵣ_ : ∀ {xs ys zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} {x y} →
-         (x≈y : R x y) → Disjoint τ₁ τ₂ → Disjoint (y  ∷ʳ τ₁) (x≈y ∷ τ₂)
+  -- Element y of zs is in ys as x with x≈y:
+  _∷ᵣ_ : ∀ {xs ys zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} {x y} →
+         (x≈y : R x y) → Disjoint τ₁ τ₂ → Disjoint (y  ∷ʳ τ₁) (x≈y ∷ τ₂)
 
-------------------------------------------------------------------------
--- Disjoint union of two sublists xs,ys ⊆ zs
---
--- This is the Cover relation without overlap of Section 6 of
--- Conor McBride, Everybody's Got To Be Somewhere,
--- MSFP@FSCD 2018: 53-69.
+------------------------------------------------------------------------
+-- Disjoint union of two sublists xs,ys ⊆ zs
+--
+-- This is the Cover relation without overlap of Section 6 of
+-- Conor McBride, Everybody's Got To Be Somewhere,
+-- MSFP@FSCD 2018: 53-69.
 
-data DisjointUnion : ∀ {xs ys zs us} (τ₁ : xs ⊆ zs) (τ₂ : ys ⊆ zs) (τ : us ⊆ zs) →  Set (a ⊔ b ⊔ r) where
-  []   : DisjointUnion [] [] []
+data DisjointUnion : ∀ {xs ys zs us} (τ₁ : xs ⊆ zs) (τ₂ : ys ⊆ zs) (τ : us ⊆ zs) →  Set (a ⊔ b ⊔ r) where
+  []   : DisjointUnion [] [] []
 
-  -- Element y of zs is neither in xs nor in ys: skip.
-  _∷ₙ_ : ∀ {xs ys zs us} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} {τ : us ⊆ zs} →
-         (y : B)       → DisjointUnion τ₁ τ₂ τ → DisjointUnion (y  ∷ʳ τ₁) (y  ∷ʳ τ₂) (y ∷ʳ τ)
+  -- Element y of zs is neither in xs nor in ys: skip.
+  _∷ₙ_ : ∀ {xs ys zs us} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} {τ : us ⊆ zs} →
+         (y : B)       → DisjointUnion τ₁ τ₂ τ → DisjointUnion (y  ∷ʳ τ₁) (y  ∷ʳ τ₂) (y ∷ʳ τ)
 
-  -- Element y of zs is in xs as x with x≈y: add to us.
-  _∷ₗ_ : ∀ {xs ys zs us} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} {τ : us ⊆ zs} {x y} →
-         (x≈y : R x y) → DisjointUnion τ₁ τ₂ τ → DisjointUnion (x≈y ∷ τ₁) (y  ∷ʳ τ₂) (x≈y ∷ τ)
+  -- Element y of zs is in xs as x with x≈y: add to us.
+  _∷ₗ_ : ∀ {xs ys zs us} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} {τ : us ⊆ zs} {x y} →
+         (x≈y : R x y) → DisjointUnion τ₁ τ₂ τ → DisjointUnion (x≈y ∷ τ₁) (y  ∷ʳ τ₂) (x≈y ∷ τ)
 
-  -- Element y of zs is in ys as x with x≈y: add to us.
-  _∷ᵣ_ : ∀ {xs ys zs us} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} {τ : us ⊆ zs} {x y} →
-         (x≈y : R x y) → DisjointUnion τ₁ τ₂ τ → DisjointUnion (y  ∷ʳ τ₁) (x≈y ∷ τ₂) (x≈y ∷ τ)
+  -- Element y of zs is in ys as x with x≈y: add to us.
+  _∷ᵣ_ : ∀ {xs ys zs us} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} {τ : us ⊆ zs} {x y} →
+         (x≈y : R x y) → DisjointUnion τ₁ τ₂ τ → DisjointUnion (y  ∷ʳ τ₁) (x≈y ∷ τ₂) (x≈y ∷ τ)
\ No newline at end of file diff --git a/Data.List.Relation.Binary.Sublist.Propositional.Properties.html b/Data.List.Relation.Binary.Sublist.Propositional.Properties.html index b1bf8550..8b6f3b6d 100644 --- a/Data.List.Relation.Binary.Sublist.Propositional.Properties.html +++ b/Data.List.Relation.Binary.Sublist.Propositional.Properties.html @@ -10,232 +10,232 @@ module Data.List.Relation.Binary.Sublist.Propositional.Properties {a} {A : Set a} where -open import Data.List.Base using (List; []; _∷_; map) -open import Data.List.Membership.Propositional using (_∈_) -open import Data.List.Relation.Unary.All using (All; []; _∷_) -open import Data.List.Relation.Unary.Any using (Any; here; there) +open import Data.List.Base using (List; []; _∷_; map) +open import Data.List.Membership.Propositional using (_∈_) +open import Data.List.Relation.Unary.All using (All; []; _∷_) +open import Data.List.Relation.Unary.Any using (Any; here; there) open import Data.List.Relation.Unary.Any.Properties - using (here-injective; there-injective) + using (here-injective; there-injective) open import Data.List.Relation.Binary.Sublist.Propositional - hiding (map) + hiding (map) import Data.List.Relation.Binary.Sublist.Setoid.Properties as SetoidProperties -open import Data.Product using (∃; _,_; proj₂) -open import Function.Base -open import Level using (Level) -open import Relation.Binary using (_Respects_) -open import Relation.Binary.PropositionalEquality -open import Relation.Unary using (Pred) - -private - variable - b ℓ : Level - B : Set b - ------------------------------------------------------------------------- --- Re-exporting setoid properties +open import Data.Product.Base using (∃; _,_; proj₂) +open import Function.Base +open import Level using (Level) +open import Relation.Binary.Definitions using (_Respects_) +open import Relation.Binary.PropositionalEquality +open import Relation.Unary using (Pred) + +private + variable + b ℓ : Level + B : Set b + +------------------------------------------------------------------------ +-- Re-exporting setoid properties -open SetoidProperties (setoid A) public - hiding (map⁺) +open SetoidProperties (setoid A) public + hiding (map⁺) -map⁺ : ∀ {as bs} (f : A → B) → as ⊆ bs → map f as ⊆ map f bs -map⁺ {B = B} f = SetoidProperties.map⁺ (setoid A) (setoid B) (cong f) - ------------------------------------------------------------------------- --- Category laws for _⊆_ - -⊆-trans-idˡ : ∀ {xs ys : List A} {τ : xs ⊆ ys} → - ⊆-trans ⊆-refl τ ≡ τ -⊆-trans-idˡ {_} {τ = [] } = refl -⊆-trans-idˡ {_} {τ = _ ∷ _} = cong (_ ∷_ ) ⊆-trans-idˡ -⊆-trans-idˡ {[]} {τ = _ ∷ʳ _} = cong (_ ∷ʳ_) ⊆-trans-idˡ -⊆-trans-idˡ {_ ∷ _} {τ = _ ∷ʳ _} = cong (_ ∷ʳ_) ⊆-trans-idˡ - -⊆-trans-idʳ : ∀ {xs ys : List A} {τ : xs ⊆ ys} → - ⊆-trans τ ⊆-refl ≡ τ -⊆-trans-idʳ {τ = [] } = refl -⊆-trans-idʳ {τ = _ ∷ʳ _ } = cong (_ ∷ʳ_ ) ⊆-trans-idʳ -⊆-trans-idʳ {τ = refl ∷ _} = cong (refl ∷_) ⊆-trans-idʳ - --- Note: The associativity law is oriented such that rewriting with it --- may trigger reductions of ⊆-trans, which matches first on its --- second argument and then on its first argument. - -⊆-trans-assoc : ∀ {ws xs ys zs : List A} - {τ₁ : ws ⊆ xs} {τ₂ : xs ⊆ ys} {τ₃ : ys ⊆ zs} → - ⊆-trans τ₁ (⊆-trans τ₂ τ₃) ≡ ⊆-trans (⊆-trans τ₁ τ₂) τ₃ -⊆-trans-assoc {τ₁ = _} {_} {_ ∷ʳ _} = cong (_ ∷ʳ_) ⊆-trans-assoc -⊆-trans-assoc {τ₁ = _} {_ ∷ʳ _} {_ ∷ _} = cong (_ ∷ʳ_) ⊆-trans-assoc -⊆-trans-assoc {τ₁ = _ ∷ʳ _ } {_ ∷ _} {_ ∷ _} = cong (_ ∷ʳ_) ⊆-trans-assoc -⊆-trans-assoc {τ₁ = refl ∷ _} {_ ∷ _} {_ ∷ _} = cong (_ ∷_ ) ⊆-trans-assoc -⊆-trans-assoc {τ₁ = []} {[]} {[]} = refl - ------------------------------------------------------------------------- --- Laws concerning ⊆-trans and ∷ˡ⁻ - -⊆-trans-∷ˡ⁻ᵣ : ∀ {y} {xs ys zs : List A} {τ : xs ⊆ ys} {σ : (y ∷ ys) ⊆ zs} → - ⊆-trans τ (∷ˡ⁻ σ) ≡ ⊆-trans (y ∷ʳ τ) σ -⊆-trans-∷ˡ⁻ᵣ {σ = x ∷ σ} = refl -⊆-trans-∷ˡ⁻ᵣ {σ = y ∷ʳ σ} = cong (y ∷ʳ_) ⊆-trans-∷ˡ⁻ᵣ - -⊆-trans-∷ˡ⁻ₗ : ∀ {x} {xs ys zs : List A} {τ : (x ∷ xs) ⊆ ys} {σ : ys ⊆ zs} → - ⊆-trans (∷ˡ⁻ τ) σ ≡ ∷ˡ⁻ (⊆-trans τ σ) -⊆-trans-∷ˡ⁻ₗ {σ = y ∷ʳ σ} = cong (y ∷ʳ_) ⊆-trans-∷ˡ⁻ₗ -⊆-trans-∷ˡ⁻ₗ {τ = y ∷ʳ τ} {σ = refl ∷ σ} = cong (y ∷ʳ_) ⊆-trans-∷ˡ⁻ₗ -⊆-trans-∷ˡ⁻ₗ {τ = refl ∷ τ} {σ = refl ∷ σ} = refl - -⊆-∷ˡ⁻trans-∷ : ∀ {y} {xs ys zs : List A} {τ : xs ⊆ ys} {σ : (y ∷ ys) ⊆ zs} → - ∷ˡ⁻ (⊆-trans (refl ∷ τ) σ) ≡ ⊆-trans (y ∷ʳ τ) σ -⊆-∷ˡ⁻trans-∷ {σ = y ∷ʳ σ} = cong (y ∷ʳ_) ⊆-∷ˡ⁻trans-∷ -⊆-∷ˡ⁻trans-∷ {σ = refl ∷ σ} = refl - ------------------------------------------------------------------------- --- Relationships to other predicates - --- All P is a contravariant functor from _⊆_ to Set. - -All-resp-⊆ : {P : Pred A ℓ} → (All P) Respects _⊇_ -All-resp-⊆ [] [] = [] -All-resp-⊆ (_ ∷ʳ p) (_ ∷ xs) = All-resp-⊆ p xs -All-resp-⊆ (refl ∷ p) (x ∷ xs) = x ∷ All-resp-⊆ p xs - --- Any P is a covariant functor from _⊆_ to Set. - -Any-resp-⊆ : {P : Pred A ℓ} → (Any P) Respects _⊆_ -Any-resp-⊆ = lookup - ------------------------------------------------------------------------- --- Functor laws for All-resp-⊆ - --- First functor law: identity. - -All-resp-⊆-refl : ∀ {P : Pred A ℓ} {xs : List A} → - All-resp-⊆ ⊆-refl ≗ id {A = All P xs} -All-resp-⊆-refl [] = refl -All-resp-⊆-refl (p ∷ ps) = cong (p ∷_) (All-resp-⊆-refl ps) - --- Second functor law: composition. - -All-resp-⊆-trans : ∀ {P : Pred A ℓ} {xs ys zs} {τ : xs ⊆ ys} (τ′ : ys ⊆ zs) → - All-resp-⊆ {P = P} (⊆-trans τ τ′) ≗ All-resp-⊆ τ ∘ All-resp-⊆ τ′ -All-resp-⊆-trans (_ ∷ʳ τ′) (p ∷ ps) = All-resp-⊆-trans τ′ ps -All-resp-⊆-trans {τ = _ ∷ʳ _ } (refl ∷ τ′) (p ∷ ps) = All-resp-⊆-trans τ′ ps -All-resp-⊆-trans {τ = refl ∷ _} (refl ∷ τ′) (p ∷ ps) = cong (p ∷_) (All-resp-⊆-trans τ′ ps) -All-resp-⊆-trans {τ = [] } ([] ) [] = refl - ------------------------------------------------------------------------- --- Functor laws for Any-resp-⊆ / lookup - --- First functor law: identity. - -Any-resp-⊆-refl : ∀ {P : Pred A ℓ} {xs} → - Any-resp-⊆ ⊆-refl ≗ id {A = Any P xs} -Any-resp-⊆-refl (here p) = refl -Any-resp-⊆-refl (there i) = cong there (Any-resp-⊆-refl i) - -lookup-⊆-refl = Any-resp-⊆-refl - --- Second functor law: composition. - -Any-resp-⊆-trans : ∀ {P : Pred A ℓ} {xs ys zs} {τ : xs ⊆ ys} (τ′ : ys ⊆ zs) → - Any-resp-⊆ {P = P} (⊆-trans τ τ′) ≗ Any-resp-⊆ τ′ ∘ Any-resp-⊆ τ -Any-resp-⊆-trans (_ ∷ʳ τ′) i = cong there (Any-resp-⊆-trans τ′ i) -Any-resp-⊆-trans {τ = _ ∷ʳ _} (_ ∷ τ′) i = cong there (Any-resp-⊆-trans τ′ i) -Any-resp-⊆-trans {τ = _ ∷ _} (_ ∷ τ′) (there i) = cong there (Any-resp-⊆-trans τ′ i) -Any-resp-⊆-trans {τ = refl ∷ _} (_ ∷ τ′) (here _) = refl -Any-resp-⊆-trans {τ = [] } [] () - -lookup-⊆-trans = Any-resp-⊆-trans - ------------------------------------------------------------------------- --- The `lookup` function for `xs ⊆ ys` is injective. --- --- Note: `lookup` can be seen as a strictly increasing reindexing function --- for indices into `xs`, producing indices into `ys`. - -lookup-injective : ∀ {P : Pred A ℓ} {xs ys} {τ : xs ⊆ ys} {i j : Any P xs} → - lookup τ i ≡ lookup τ j → i ≡ j -lookup-injective {τ = _ ∷ʳ _} = lookup-injective ∘′ there-injective -lookup-injective {τ = x≡y ∷ _} {here _} {here _} = cong here ∘′ subst-injective x≡y ∘′ here-injective - -- Note: instead of using subst-injective, we could match x≡y against refl on the lhs. - -- However, this turns the following clause into a non-strict match. -lookup-injective {τ = _ ∷ _} {there _} {there _} = cong there ∘′ lookup-injective ∘′ there-injective - -------------------------------------------------------------------------- --- from∈ ∘ to∈ turns a sublist morphism τ : x∷xs ⊆ ys into a morphism --- [x] ⊆ ys. The same morphism is obtained by pre-composing τ with --- the canonial morphism [x] ⊆ x∷xs. --- --- Note: This lemma does not hold for Sublist.Setoid, but could hold for --- a hypothetical Sublist.Groupoid where trans refl = id. - -from∈∘to∈ : ∀ {x : A} {xs ys} (τ : x ∷ xs ⊆ ys) → - from∈ (to∈ τ) ≡ ⊆-trans (refl ∷ minimum xs) τ -from∈∘to∈ (x≡y ∷ τ) = cong (x≡y ∷_) ([]⊆-irrelevant _ _) -from∈∘to∈ (y ∷ʳ τ) = cong (y ∷ʳ_) (from∈∘to∈ τ) - -from∈∘lookup : ∀{x : A} {xs ys} (τ : xs ⊆ ys) (i : x ∈ xs) → - from∈ (lookup τ i) ≡ ⊆-trans (from∈ i) τ -from∈∘lookup (y ∷ʳ τ) i = cong (y ∷ʳ_) (from∈∘lookup τ i) -from∈∘lookup (_ ∷ τ) (there i) = cong (_ ∷ʳ_) (from∈∘lookup τ i) -from∈∘lookup (refl ∷ τ) (here refl) = cong (refl ∷_) ([]⊆-irrelevant _ _) - ------------------------------------------------------------------------- --- Weak pushout (wpo) - --- A raw pushout is a weak pushout if the pushout square commutes. - -IsWeakPushout : ∀{xs ys zs : List A} {τ : xs ⊆ ys} {σ : xs ⊆ zs} → - RawPushout τ σ → Set a -IsWeakPushout {τ = τ} {σ = σ} rpo = - ⊆-trans τ (RawPushout.leg₁ rpo) ≡ - ⊆-trans σ (RawPushout.leg₂ rpo) - --- Joining two list extensions with ⊆-pushout produces a weak pushout. - -⊆-pushoutˡ-is-wpo : ∀{xs ys zs : List A} (τ : xs ⊆ ys) (σ : xs ⊆ zs) → - IsWeakPushout (⊆-pushoutˡ τ σ) -⊆-pushoutˡ-is-wpo [] σ - rewrite ⊆-trans-idʳ {τ = σ} - = ⊆-trans-idˡ {xs = []} -⊆-pushoutˡ-is-wpo (y ∷ʳ τ) σ = cong (y ∷ʳ_) (⊆-pushoutˡ-is-wpo τ σ) -⊆-pushoutˡ-is-wpo (x≡y ∷ τ) (z ∷ʳ σ) = cong (z ∷ʳ_) (⊆-pushoutˡ-is-wpo (x≡y ∷ τ) σ) -⊆-pushoutˡ-is-wpo (refl ∷ τ) (refl ∷ σ) = cong (refl ∷_) (⊆-pushoutˡ-is-wpo τ σ) - ------------------------------------------------------------------------- --- Properties of disjointness - --- From τ₁ ⊎ τ₂ = τ, compute the injection ι₁ such that τ₁ = ⊆-trans ι₁ τ. - -DisjointUnion-inj₁ : ∀ {xs ys zs xys : List A} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} {τ : xys ⊆ zs} → - DisjointUnion τ₁ τ₂ τ → ∃ λ (ι₁ : xs ⊆ xys) → ⊆-trans ι₁ τ ≡ τ₁ -DisjointUnion-inj₁ [] = [] , refl -DisjointUnion-inj₁ (y ∷ₙ d) = _ , cong (y ∷ʳ_) (proj₂ (DisjointUnion-inj₁ d)) -DisjointUnion-inj₁ (x≈y ∷ₗ d) = refl ∷ _ , cong (x≈y ∷_) (proj₂ (DisjointUnion-inj₁ d)) -DisjointUnion-inj₁ (x≈y ∷ᵣ d) = _ ∷ʳ _ , cong (_ ∷ʳ_) (proj₂ (DisjointUnion-inj₁ d)) - --- From τ₁ ⊎ τ₂ = τ, compute the injection ι₂ such that τ₂ = ⊆-trans ι₂ τ. - -DisjointUnion-inj₂ : ∀ {xs ys zs xys : List A} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} {τ : xys ⊆ zs} → - DisjointUnion τ₁ τ₂ τ → ∃ λ (ι₂ : ys ⊆ xys) → ⊆-trans ι₂ τ ≡ τ₂ -DisjointUnion-inj₂ [] = [] , refl -DisjointUnion-inj₂ (y ∷ₙ d) = _ , cong (y ∷ʳ_) (proj₂ (DisjointUnion-inj₂ d)) -DisjointUnion-inj₂ (x≈y ∷ᵣ d) = refl ∷ _ , cong (x≈y ∷_) (proj₂ (DisjointUnion-inj₂ d)) -DisjointUnion-inj₂ (x≈y ∷ₗ d) = _ ∷ʳ _ , cong (_ ∷ʳ_) (proj₂ (DisjointUnion-inj₂ d)) - --- A sublist σ disjoint to both τ₁ and τ₂ is an equalizer --- for the separators of τ₁ and τ₂. - -equalize-separators : ∀ {us xs ys zs : List A} - {σ : us ⊆ zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} (let s = separateˡ τ₁ τ₂) → - Disjoint σ τ₁ → Disjoint σ τ₂ → - ⊆-trans σ (Separation.separator₁ s) ≡ - ⊆-trans σ (Separation.separator₂ s) -equalize-separators [] [] = refl -equalize-separators (y ∷ₙ d₁) (.y ∷ₙ d₂) = cong (y ∷ʳ_) (equalize-separators d₁ d₂) -equalize-separators (y ∷ₙ d₁) (refl ∷ᵣ d₂) = cong (y ∷ʳ_) (equalize-separators d₁ d₂) -equalize-separators (refl ∷ᵣ d₁) (y ∷ₙ d₂) = cong (y ∷ʳ_) (equalize-separators d₁ d₂) -equalize-separators {τ₁ = refl ∷ _} {τ₂ = refl ∷ _} -- match here to work around deficiency of Agda's forcing translation - (_ ∷ᵣ d₁) (_ ∷ᵣ d₂) = cong (_ ∷ʳ_) (cong (_ ∷ʳ_) (equalize-separators d₁ d₂)) -equalize-separators (x≈y ∷ₗ d₁) (.x≈y ∷ₗ d₂) = cong (trans x≈y refl ∷_) (equalize-separators d₁ d₂) +map⁺ : ∀ {as bs} (f : A → B) → as ⊆ bs → map f as ⊆ map f bs +map⁺ {B = B} f = SetoidProperties.map⁺ (setoid A) (setoid B) (cong f) + +------------------------------------------------------------------------ +-- Category laws for _⊆_ + +⊆-trans-idˡ : ∀ {xs ys : List A} {τ : xs ⊆ ys} → + ⊆-trans ⊆-refl τ ≡ τ +⊆-trans-idˡ {_} {τ = [] } = refl +⊆-trans-idˡ {_} {τ = _ ∷ _} = cong (_ ∷_ ) ⊆-trans-idˡ +⊆-trans-idˡ {[]} {τ = _ ∷ʳ _} = cong (_ ∷ʳ_) ⊆-trans-idˡ +⊆-trans-idˡ {_ ∷ _} {τ = _ ∷ʳ _} = cong (_ ∷ʳ_) ⊆-trans-idˡ + +⊆-trans-idʳ : ∀ {xs ys : List A} {τ : xs ⊆ ys} → + ⊆-trans τ ⊆-refl ≡ τ +⊆-trans-idʳ {τ = [] } = refl +⊆-trans-idʳ {τ = _ ∷ʳ _ } = cong (_ ∷ʳ_ ) ⊆-trans-idʳ +⊆-trans-idʳ {τ = refl ∷ _} = cong (refl ∷_) ⊆-trans-idʳ + +-- Note: The associativity law is oriented such that rewriting with it +-- may trigger reductions of ⊆-trans, which matches first on its +-- second argument and then on its first argument. + +⊆-trans-assoc : ∀ {ws xs ys zs : List A} + {τ₁ : ws ⊆ xs} {τ₂ : xs ⊆ ys} {τ₃ : ys ⊆ zs} → + ⊆-trans τ₁ (⊆-trans τ₂ τ₃) ≡ ⊆-trans (⊆-trans τ₁ τ₂) τ₃ +⊆-trans-assoc {τ₁ = _} {_} {_ ∷ʳ _} = cong (_ ∷ʳ_) ⊆-trans-assoc +⊆-trans-assoc {τ₁ = _} {_ ∷ʳ _} {_ ∷ _} = cong (_ ∷ʳ_) ⊆-trans-assoc +⊆-trans-assoc {τ₁ = _ ∷ʳ _ } {_ ∷ _} {_ ∷ _} = cong (_ ∷ʳ_) ⊆-trans-assoc +⊆-trans-assoc {τ₁ = refl ∷ _} {_ ∷ _} {_ ∷ _} = cong (_ ∷_ ) ⊆-trans-assoc +⊆-trans-assoc {τ₁ = []} {[]} {[]} = refl + +------------------------------------------------------------------------ +-- Laws concerning ⊆-trans and ∷ˡ⁻ + +⊆-trans-∷ˡ⁻ᵣ : ∀ {y} {xs ys zs : List A} {τ : xs ⊆ ys} {σ : (y ∷ ys) ⊆ zs} → + ⊆-trans τ (∷ˡ⁻ σ) ≡ ⊆-trans (y ∷ʳ τ) σ +⊆-trans-∷ˡ⁻ᵣ {σ = x ∷ σ} = refl +⊆-trans-∷ˡ⁻ᵣ {σ = y ∷ʳ σ} = cong (y ∷ʳ_) ⊆-trans-∷ˡ⁻ᵣ + +⊆-trans-∷ˡ⁻ₗ : ∀ {x} {xs ys zs : List A} {τ : (x ∷ xs) ⊆ ys} {σ : ys ⊆ zs} → + ⊆-trans (∷ˡ⁻ τ) σ ≡ ∷ˡ⁻ (⊆-trans τ σ) +⊆-trans-∷ˡ⁻ₗ {σ = y ∷ʳ σ} = cong (y ∷ʳ_) ⊆-trans-∷ˡ⁻ₗ +⊆-trans-∷ˡ⁻ₗ {τ = y ∷ʳ τ} {σ = refl ∷ σ} = cong (y ∷ʳ_) ⊆-trans-∷ˡ⁻ₗ +⊆-trans-∷ˡ⁻ₗ {τ = refl ∷ τ} {σ = refl ∷ σ} = refl + +⊆-∷ˡ⁻trans-∷ : ∀ {y} {xs ys zs : List A} {τ : xs ⊆ ys} {σ : (y ∷ ys) ⊆ zs} → + ∷ˡ⁻ (⊆-trans (refl ∷ τ) σ) ≡ ⊆-trans (y ∷ʳ τ) σ +⊆-∷ˡ⁻trans-∷ {σ = y ∷ʳ σ} = cong (y ∷ʳ_) ⊆-∷ˡ⁻trans-∷ +⊆-∷ˡ⁻trans-∷ {σ = refl ∷ σ} = refl + +------------------------------------------------------------------------ +-- Relationships to other predicates + +-- All P is a contravariant functor from _⊆_ to Set. + +All-resp-⊆ : {P : Pred A ℓ} → (All P) Respects _⊇_ +All-resp-⊆ [] [] = [] +All-resp-⊆ (_ ∷ʳ p) (_ ∷ xs) = All-resp-⊆ p xs +All-resp-⊆ (refl ∷ p) (x ∷ xs) = x ∷ All-resp-⊆ p xs + +-- Any P is a covariant functor from _⊆_ to Set. + +Any-resp-⊆ : {P : Pred A ℓ} → (Any P) Respects _⊆_ +Any-resp-⊆ = lookup + +------------------------------------------------------------------------ +-- Functor laws for All-resp-⊆ + +-- First functor law: identity. + +All-resp-⊆-refl : ∀ {P : Pred A ℓ} {xs : List A} → + All-resp-⊆ ⊆-refl ≗ id {A = All P xs} +All-resp-⊆-refl [] = refl +All-resp-⊆-refl (p ∷ ps) = cong (p ∷_) (All-resp-⊆-refl ps) + +-- Second functor law: composition. + +All-resp-⊆-trans : ∀ {P : Pred A ℓ} {xs ys zs} {τ : xs ⊆ ys} (τ′ : ys ⊆ zs) → + All-resp-⊆ {P = P} (⊆-trans τ τ′) ≗ All-resp-⊆ τ ∘ All-resp-⊆ τ′ +All-resp-⊆-trans (_ ∷ʳ τ′) (p ∷ ps) = All-resp-⊆-trans τ′ ps +All-resp-⊆-trans {τ = _ ∷ʳ _ } (refl ∷ τ′) (p ∷ ps) = All-resp-⊆-trans τ′ ps +All-resp-⊆-trans {τ = refl ∷ _} (refl ∷ τ′) (p ∷ ps) = cong (p ∷_) (All-resp-⊆-trans τ′ ps) +All-resp-⊆-trans {τ = [] } ([] ) [] = refl + +------------------------------------------------------------------------ +-- Functor laws for Any-resp-⊆ / lookup + +-- First functor law: identity. + +Any-resp-⊆-refl : ∀ {P : Pred A ℓ} {xs} → + Any-resp-⊆ ⊆-refl ≗ id {A = Any P xs} +Any-resp-⊆-refl (here p) = refl +Any-resp-⊆-refl (there i) = cong there (Any-resp-⊆-refl i) + +lookup-⊆-refl = Any-resp-⊆-refl + +-- Second functor law: composition. + +Any-resp-⊆-trans : ∀ {P : Pred A ℓ} {xs ys zs} {τ : xs ⊆ ys} (τ′ : ys ⊆ zs) → + Any-resp-⊆ {P = P} (⊆-trans τ τ′) ≗ Any-resp-⊆ τ′ ∘ Any-resp-⊆ τ +Any-resp-⊆-trans (_ ∷ʳ τ′) i = cong there (Any-resp-⊆-trans τ′ i) +Any-resp-⊆-trans {τ = _ ∷ʳ _} (_ ∷ τ′) i = cong there (Any-resp-⊆-trans τ′ i) +Any-resp-⊆-trans {τ = _ ∷ _} (_ ∷ τ′) (there i) = cong there (Any-resp-⊆-trans τ′ i) +Any-resp-⊆-trans {τ = refl ∷ _} (_ ∷ τ′) (here _) = refl +Any-resp-⊆-trans {τ = [] } [] () + +lookup-⊆-trans = Any-resp-⊆-trans + +------------------------------------------------------------------------ +-- The `lookup` function for `xs ⊆ ys` is injective. +-- +-- Note: `lookup` can be seen as a strictly increasing reindexing +-- function for indices into `xs`, producing indices into `ys`. + +lookup-injective : ∀ {P : Pred A ℓ} {xs ys} {τ : xs ⊆ ys} {i j : Any P xs} → + lookup τ i ≡ lookup τ j → i ≡ j +lookup-injective {τ = _ ∷ʳ _} = lookup-injective ∘′ there-injective +lookup-injective {τ = x≡y ∷ _} {here _} {here _} = cong here ∘′ subst-injective x≡y ∘′ here-injective + -- Note: instead of using subst-injective, we could match x≡y against refl on the lhs. + -- However, this turns the following clause into a non-strict match. +lookup-injective {τ = _ ∷ _} {there _} {there _} = cong there ∘′ lookup-injective ∘′ there-injective + +------------------------------------------------------------------------ +-- from∈ ∘ to∈ turns a sublist morphism τ : x∷xs ⊆ ys into a morphism +-- [x] ⊆ ys. The same morphism is obtained by pre-composing τ with +-- the canonial morphism [x] ⊆ x∷xs. +-- +-- Note: This lemma does not hold for Sublist.Setoid, but could hold for +-- a hypothetical Sublist.Groupoid where trans refl = id. + +from∈∘to∈ : ∀ {x : A} {xs ys} (τ : x ∷ xs ⊆ ys) → + from∈ (to∈ τ) ≡ ⊆-trans (refl ∷ minimum xs) τ +from∈∘to∈ (x≡y ∷ τ) = cong (x≡y ∷_) ([]⊆-irrelevant _ _) +from∈∘to∈ (y ∷ʳ τ) = cong (y ∷ʳ_) (from∈∘to∈ τ) + +from∈∘lookup : ∀{x : A} {xs ys} (τ : xs ⊆ ys) (i : x ∈ xs) → + from∈ (lookup τ i) ≡ ⊆-trans (from∈ i) τ +from∈∘lookup (y ∷ʳ τ) i = cong (y ∷ʳ_) (from∈∘lookup τ i) +from∈∘lookup (_ ∷ τ) (there i) = cong (_ ∷ʳ_) (from∈∘lookup τ i) +from∈∘lookup (refl ∷ τ) (here refl) = cong (refl ∷_) ([]⊆-irrelevant _ _) + +------------------------------------------------------------------------ +-- Weak pushout (wpo) + +-- A raw pushout is a weak pushout if the pushout square commutes. + +IsWeakPushout : ∀{xs ys zs : List A} {τ : xs ⊆ ys} {σ : xs ⊆ zs} → + RawPushout τ σ → Set a +IsWeakPushout {τ = τ} {σ = σ} rpo = + ⊆-trans τ (RawPushout.leg₁ rpo) ≡ + ⊆-trans σ (RawPushout.leg₂ rpo) + +-- Joining two list extensions with ⊆-pushout produces a weak pushout. + +⊆-pushoutˡ-is-wpo : ∀{xs ys zs : List A} (τ : xs ⊆ ys) (σ : xs ⊆ zs) → + IsWeakPushout (⊆-pushoutˡ τ σ) +⊆-pushoutˡ-is-wpo [] σ + rewrite ⊆-trans-idʳ {τ = σ} + = ⊆-trans-idˡ {xs = []} +⊆-pushoutˡ-is-wpo (y ∷ʳ τ) σ = cong (y ∷ʳ_) (⊆-pushoutˡ-is-wpo τ σ) +⊆-pushoutˡ-is-wpo (x≡y ∷ τ) (z ∷ʳ σ) = cong (z ∷ʳ_) (⊆-pushoutˡ-is-wpo (x≡y ∷ τ) σ) +⊆-pushoutˡ-is-wpo (refl ∷ τ) (refl ∷ σ) = cong (refl ∷_) (⊆-pushoutˡ-is-wpo τ σ) + +------------------------------------------------------------------------ +-- Properties of disjointness + +-- From τ₁ ⊎ τ₂ = τ, compute the injection ι₁ such that τ₁ = ⊆-trans ι₁ τ. + +DisjointUnion-inj₁ : ∀ {xs ys zs xys : List A} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} {τ : xys ⊆ zs} → + DisjointUnion τ₁ τ₂ τ → ∃ λ (ι₁ : xs ⊆ xys) → ⊆-trans ι₁ τ ≡ τ₁ +DisjointUnion-inj₁ [] = [] , refl +DisjointUnion-inj₁ (y ∷ₙ d) = _ , cong (y ∷ʳ_) (proj₂ (DisjointUnion-inj₁ d)) +DisjointUnion-inj₁ (x≈y ∷ₗ d) = refl ∷ _ , cong (x≈y ∷_) (proj₂ (DisjointUnion-inj₁ d)) +DisjointUnion-inj₁ (x≈y ∷ᵣ d) = _ ∷ʳ _ , cong (_ ∷ʳ_) (proj₂ (DisjointUnion-inj₁ d)) + +-- From τ₁ ⊎ τ₂ = τ, compute the injection ι₂ such that τ₂ = ⊆-trans ι₂ τ. + +DisjointUnion-inj₂ : ∀ {xs ys zs xys : List A} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} {τ : xys ⊆ zs} → + DisjointUnion τ₁ τ₂ τ → ∃ λ (ι₂ : ys ⊆ xys) → ⊆-trans ι₂ τ ≡ τ₂ +DisjointUnion-inj₂ [] = [] , refl +DisjointUnion-inj₂ (y ∷ₙ d) = _ , cong (y ∷ʳ_) (proj₂ (DisjointUnion-inj₂ d)) +DisjointUnion-inj₂ (x≈y ∷ᵣ d) = refl ∷ _ , cong (x≈y ∷_) (proj₂ (DisjointUnion-inj₂ d)) +DisjointUnion-inj₂ (x≈y ∷ₗ d) = _ ∷ʳ _ , cong (_ ∷ʳ_) (proj₂ (DisjointUnion-inj₂ d)) + +-- A sublist σ disjoint to both τ₁ and τ₂ is an equalizer +-- for the separators of τ₁ and τ₂. + +equalize-separators : ∀ {us xs ys zs : List A} + {σ : us ⊆ zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} (let s = separateˡ τ₁ τ₂) → + Disjoint σ τ₁ → Disjoint σ τ₂ → + ⊆-trans σ (Separation.separator₁ s) ≡ + ⊆-trans σ (Separation.separator₂ s) +equalize-separators [] [] = refl +equalize-separators (y ∷ₙ d₁) (.y ∷ₙ d₂) = cong (y ∷ʳ_) (equalize-separators d₁ d₂) +equalize-separators (y ∷ₙ d₁) (refl ∷ᵣ d₂) = cong (y ∷ʳ_) (equalize-separators d₁ d₂) +equalize-separators (refl ∷ᵣ d₁) (y ∷ₙ d₂) = cong (y ∷ʳ_) (equalize-separators d₁ d₂) +equalize-separators {τ₁ = refl ∷ _} {τ₂ = refl ∷ _} -- match here to work around deficiency of Agda's forcing translation + (_ ∷ᵣ d₁) (_ ∷ᵣ d₂) = cong (_ ∷ʳ_) (cong (_ ∷ʳ_) (equalize-separators d₁ d₂)) +equalize-separators (x≈y ∷ₗ d₁) (.x≈y ∷ₗ d₂) = cong (trans x≈y refl ∷_) (equalize-separators d₁ d₂) \ No newline at end of file diff --git a/Data.List.Relation.Binary.Sublist.Propositional.html b/Data.List.Relation.Binary.Sublist.Propositional.html index dcfa5351..70fda6c0 100644 --- a/Data.List.Relation.Binary.Sublist.Propositional.html +++ b/Data.List.Relation.Binary.Sublist.Propositional.html @@ -12,142 +12,145 @@ {a} {A : Set a} where open import Data.List.Base using (List) -open import Data.List.Relation.Binary.Equality.Propositional using (≋⇒≡) +open import Data.List.Relation.Binary.Equality.Propositional using (≋⇒≡) import Data.List.Relation.Binary.Sublist.Setoid as SetoidSublist -open import Data.List.Relation.Unary.Any using (Any) -open import Relation.Binary -open import Relation.Binary.PropositionalEquality -open import Relation.Unary using (Pred) - ------------------------------------------------------------------------- --- Re-export definition and operations from setoid sublists - -open SetoidSublist (setoid A) public - hiding - (lookup; ⊆-reflexive; ⊆-antisym - ; ⊆-isPreorder; ⊆-isPartialOrder - ; ⊆-preorder; ⊆-poset - ) - ------------------------------------------------------------------------- --- Additional operations - -module _ {p} {P : Pred A p} where - - lookup : ∀ {xs ys} → xs ⊆ ys → Any P xs → Any P ys - lookup = SetoidSublist.lookup (setoid A) (subst _) - ------------------------------------------------------------------------- --- Relational properties - -⊆-reflexive : _≡_ ⇒ _⊆_ -⊆-reflexive refl = ⊆-refl - -⊆-antisym : Antisymmetric _≡_ _⊆_ -⊆-antisym xs⊆ys ys⊆xs = ≋⇒≡ (SetoidSublist.⊆-antisym (setoid A) xs⊆ys ys⊆xs) - -⊆-isPreorder : IsPreorder _≡_ _⊆_ -⊆-isPreorder = record - { isEquivalence = isEquivalence - ; reflexive = ⊆-reflexive - ; trans = ⊆-trans - } - -⊆-isPartialOrder : IsPartialOrder _≡_ _⊆_ -⊆-isPartialOrder = record - { isPreorder = ⊆-isPreorder - ; antisym = ⊆-antisym - } - -⊆-preorder : Preorder a a a -⊆-preorder = record - { isPreorder = ⊆-isPreorder +open import Data.List.Relation.Unary.Any using (Any) +open import Relation.Binary.Core using (_⇒_) +open import Relation.Binary.Bundles using (Preorder; Poset) +open import Relation.Binary.Structures using (IsPreorder; IsPartialOrder) +open import Relation.Binary.Definitions using (Antisymmetric) +open import Relation.Binary.PropositionalEquality +open import Relation.Unary using (Pred) + +------------------------------------------------------------------------ +-- Re-export definition and operations from setoid sublists + +open SetoidSublist (setoid A) public + hiding + (lookup; ⊆-reflexive; ⊆-antisym + ; ⊆-isPreorder; ⊆-isPartialOrder + ; ⊆-preorder; ⊆-poset + ) + +------------------------------------------------------------------------ +-- Additional operations + +module _ {p} {P : Pred A p} where + + lookup : ∀ {xs ys} → xs ⊆ ys → Any P xs → Any P ys + lookup = SetoidSublist.lookup (setoid A) (subst _) + +------------------------------------------------------------------------ +-- Relational properties + +⊆-reflexive : _≡_ ⇒ _⊆_ +⊆-reflexive refl = ⊆-refl + +⊆-antisym : Antisymmetric _≡_ _⊆_ +⊆-antisym xs⊆ys ys⊆xs = ≋⇒≡ (SetoidSublist.⊆-antisym (setoid A) xs⊆ys ys⊆xs) + +⊆-isPreorder : IsPreorder _≡_ _⊆_ +⊆-isPreorder = record + { isEquivalence = isEquivalence + ; reflexive = ⊆-reflexive + ; trans = ⊆-trans } -⊆-poset : Poset a a a -⊆-poset = record - { isPartialOrder = ⊆-isPartialOrder - } - ------------------------------------------------------------------------- --- Separating two sublists --- --- Two possibly overlapping sublists τ : xs ⊆ zs and σ : ys ⊆ zs --- can be turned into disjoint lists τρ : xs ⊆ zs and τρ : ys ⊆ zs′ --- by duplicating all entries of zs that occur both in xs and ys, --- resulting in an extension ρ : zs ⊆ zs′ of zs. - -record Separation {xs ys zs} (τ₁ : xs ⊆ zs) (τ₂ : ys ⊆ zs) : Set a where - field - {inflation} : List A - separator₁ : zs ⊆ inflation - separator₂ : zs ⊆ inflation - separated₁ = ⊆-trans τ₁ separator₁ - separated₂ = ⊆-trans τ₂ separator₂ - field - disjoint : Disjoint separated₁ separated₂ - -infixr 5 _∷ₙ-Sep_ _∷ₗ-Sep_ _∷ᵣ-Sep_ - --- Empty separation - -[]-Sep : Separation [] [] -[]-Sep = record { separator₁ = [] ; separator₂ = [] ; disjoint = [] } - --- Weaken a separation - -_∷ₙ-Sep_ : ∀ {xs ys zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} → - ∀ z → Separation τ₁ τ₂ → Separation (z ∷ʳ τ₁) (z ∷ʳ τ₂) -z ∷ₙ-Sep record{ separator₁ = ρ₁; separator₂ = ρ₂; disjoint = d } = record - { separator₁ = refl ∷ ρ₁ - ; separator₂ = refl ∷ ρ₂ - ; disjoint = z ∷ₙ d - } - --- Extend a separation by an element of the first sublist. --- --- Note: this requires a category law from the underlying equality, --- trans x=z refl = x=z, thus, separation is not available for Sublist.Setoid. - -_∷ₗ-Sep_ : ∀ {xs ys zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} → - ∀ {x z} (x≡z : x ≡ z) → Separation τ₁ τ₂ → Separation (x≡z ∷ τ₁) (z ∷ʳ τ₂) -refl ∷ₗ-Sep record{ separator₁ = ρ₁; separator₂ = ρ₂; disjoint = d } = record - { separator₁ = refl ∷ ρ₁ - ; separator₂ = refl ∷ ρ₂ - ; disjoint = refl ∷ₗ d - } - --- Extend a separation by an element of the second sublist. - -_∷ᵣ-Sep_ : ∀ {xs ys zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} → - ∀ {y z} (y≡z : y ≡ z) → Separation τ₁ τ₂ → Separation (z ∷ʳ τ₁) (y≡z ∷ τ₂) -refl ∷ᵣ-Sep record{ separator₁ = ρ₁; separator₂ = ρ₂; disjoint = d } = record - { separator₁ = refl ∷ ρ₁ - ; separator₂ = refl ∷ ρ₂ - ; disjoint = refl ∷ᵣ d - } - --- Extend a separation by a common element of both sublists. --- --- Left-biased: the left separator gets the first copy --- of the common element. - -∷-Sepˡ : ∀ {xs ys zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} → - ∀ {x y z} (x≡z : x ≡ z) (y≡z : y ≡ z) → - Separation τ₁ τ₂ → Separation (x≡z ∷ τ₁) (y≡z ∷ τ₂) -∷-Sepˡ refl refl record{ separator₁ = ρ₁; separator₂ = ρ₂; disjoint = d } = record - { separator₁ = _ ∷ʳ refl ∷ ρ₁ - ; separator₂ = refl ∷ _ ∷ʳ ρ₂ - ; disjoint = refl ∷ᵣ (refl ∷ₗ d) - } - --- Left-biased separation of two sublists. Of common elements, --- the first sublist receives the first copy. - -separateˡ : ∀ {xs ys zs} (τ₁ : xs ⊆ zs) (τ₂ : ys ⊆ zs) → Separation τ₁ τ₂ -separateˡ [] [] = []-Sep -separateˡ (z ∷ʳ τ₁) (z ∷ʳ τ₂) = z ∷ₙ-Sep separateˡ τ₁ τ₂ -separateˡ (z ∷ʳ τ₁) (y≡z ∷ τ₂) = y≡z ∷ᵣ-Sep separateˡ τ₁ τ₂ -separateˡ (x≡z ∷ τ₁) (z ∷ʳ τ₂) = x≡z ∷ₗ-Sep separateˡ τ₁ τ₂ -separateˡ (x≡z ∷ τ₁) (y≡z ∷ τ₂) = ∷-Sepˡ x≡z y≡z (separateˡ τ₁ τ₂) +⊆-isPartialOrder : IsPartialOrder _≡_ _⊆_ +⊆-isPartialOrder = record + { isPreorder = ⊆-isPreorder + ; antisym = ⊆-antisym + } + +⊆-preorder : Preorder a a a +⊆-preorder = record + { isPreorder = ⊆-isPreorder + } + +⊆-poset : Poset a a a +⊆-poset = record + { isPartialOrder = ⊆-isPartialOrder + } + +------------------------------------------------------------------------ +-- Separating two sublists +-- +-- Two possibly overlapping sublists τ : xs ⊆ zs and σ : ys ⊆ zs +-- can be turned into disjoint lists τρ : xs ⊆ zs and τρ : ys ⊆ zs′ +-- by duplicating all entries of zs that occur both in xs and ys, +-- resulting in an extension ρ : zs ⊆ zs′ of zs. + +record Separation {xs ys zs} (τ₁ : xs ⊆ zs) (τ₂ : ys ⊆ zs) : Set a where + field + {inflation} : List A + separator₁ : zs ⊆ inflation + separator₂ : zs ⊆ inflation + separated₁ = ⊆-trans τ₁ separator₁ + separated₂ = ⊆-trans τ₂ separator₂ + field + disjoint : Disjoint separated₁ separated₂ + +infixr 5 _∷ₙ-Sep_ _∷ₗ-Sep_ _∷ᵣ-Sep_ + +-- Empty separation + +[]-Sep : Separation [] [] +[]-Sep = record { separator₁ = [] ; separator₂ = [] ; disjoint = [] } + +-- Weaken a separation + +_∷ₙ-Sep_ : ∀ {xs ys zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} → + ∀ z → Separation τ₁ τ₂ → Separation (z ∷ʳ τ₁) (z ∷ʳ τ₂) +z ∷ₙ-Sep record{ separator₁ = ρ₁; separator₂ = ρ₂; disjoint = d } = record + { separator₁ = refl ∷ ρ₁ + ; separator₂ = refl ∷ ρ₂ + ; disjoint = z ∷ₙ d + } + +-- Extend a separation by an element of the first sublist. +-- +-- Note: this requires a category law from the underlying equality, +-- trans x=z refl = x=z, thus, separation is not available for Sublist.Setoid. + +_∷ₗ-Sep_ : ∀ {xs ys zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} → + ∀ {x z} (x≡z : x ≡ z) → Separation τ₁ τ₂ → Separation (x≡z ∷ τ₁) (z ∷ʳ τ₂) +refl ∷ₗ-Sep record{ separator₁ = ρ₁; separator₂ = ρ₂; disjoint = d } = record + { separator₁ = refl ∷ ρ₁ + ; separator₂ = refl ∷ ρ₂ + ; disjoint = refl ∷ₗ d + } + +-- Extend a separation by an element of the second sublist. + +_∷ᵣ-Sep_ : ∀ {xs ys zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} → + ∀ {y z} (y≡z : y ≡ z) → Separation τ₁ τ₂ → Separation (z ∷ʳ τ₁) (y≡z ∷ τ₂) +refl ∷ᵣ-Sep record{ separator₁ = ρ₁; separator₂ = ρ₂; disjoint = d } = record + { separator₁ = refl ∷ ρ₁ + ; separator₂ = refl ∷ ρ₂ + ; disjoint = refl ∷ᵣ d + } + +-- Extend a separation by a common element of both sublists. +-- +-- Left-biased: the left separator gets the first copy +-- of the common element. + +∷-Sepˡ : ∀ {xs ys zs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} → + ∀ {x y z} (x≡z : x ≡ z) (y≡z : y ≡ z) → + Separation τ₁ τ₂ → Separation (x≡z ∷ τ₁) (y≡z ∷ τ₂) +∷-Sepˡ refl refl record{ separator₁ = ρ₁; separator₂ = ρ₂; disjoint = d } = record + { separator₁ = _ ∷ʳ refl ∷ ρ₁ + ; separator₂ = refl ∷ _ ∷ʳ ρ₂ + ; disjoint = refl ∷ᵣ (refl ∷ₗ d) + } + +-- Left-biased separation of two sublists. Of common elements, +-- the first sublist receives the first copy. + +separateˡ : ∀ {xs ys zs} (τ₁ : xs ⊆ zs) (τ₂ : ys ⊆ zs) → Separation τ₁ τ₂ +separateˡ [] [] = []-Sep +separateˡ (z ∷ʳ τ₁) (z ∷ʳ τ₂) = z ∷ₙ-Sep separateˡ τ₁ τ₂ +separateˡ (z ∷ʳ τ₁) (y≡z ∷ τ₂) = y≡z ∷ᵣ-Sep separateˡ τ₁ τ₂ +separateˡ (x≡z ∷ τ₁) (z ∷ʳ τ₂) = x≡z ∷ₗ-Sep separateˡ τ₁ τ₂ +separateˡ (x≡z ∷ τ₁) (y≡z ∷ τ₂) = ∷-Sepˡ x≡z y≡z (separateˡ τ₁ τ₂) \ No newline at end of file diff --git a/Data.List.Relation.Binary.Sublist.Setoid.Properties.html b/Data.List.Relation.Binary.Sublist.Setoid.Properties.html index 67da18e8..31633d70 100644 --- a/Data.List.Relation.Binary.Sublist.Setoid.Properties.html +++ b/Data.List.Relation.Binary.Sublist.Setoid.Properties.html @@ -1,291 +1,317 @@ -Data.List.Relation.Binary.Sublist.Setoid.Properties
-----------------------------------------------------------------------
--- The Agda standard library
---
--- Properties of the setoid sublist relation
-------------------------------------------------------------------------
+Data.List.Relation.Binary.Sublist.Setoid.Properties
------------------------------------------------------------------------
+-- The Agda standard library
+--
+-- Properties of the setoid sublist relation
+------------------------------------------------------------------------
 
-{-# OPTIONS --cubical-compatible --safe #-}
+{-# OPTIONS --cubical-compatible --safe #-}
 
-open import Relation.Binary using (Setoid; _⇒_; _Preserves_⟶_)
+open import Relation.Binary.Core using (Rel; _⇒_; _Preserves_⟶_)
+open import Relation.Binary.Bundles using (Setoid)
 
-module Data.List.Relation.Binary.Sublist.Setoid.Properties
-  {c ℓ} (S : Setoid c ℓ) where
+module Data.List.Relation.Binary.Sublist.Setoid.Properties
+  {c ℓ} (S : Setoid c ℓ) where
 
-open import Data.List.Base hiding (_∷ʳ_)
-open import Data.List.Relation.Unary.Any using (Any)
-import Data.Maybe.Relation.Unary.All as Maybe
-open import Data.Nat.Base using (_≤_; _≥_)
-import Data.Nat.Properties as ℕₚ
-open import Data.Product using (∃; _,_; proj₂)
-open import Function.Base
-open import Function.Bundles using (_⇔_; _⤖_)
-open import Level
-open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong)
-open import Relation.Unary using (Pred; Decidable; Irrelevant)
-open import Relation.Nullary.Negation using (¬_)
-open import Relation.Nullary.Decidable using (¬?)
+open import Data.List.Base hiding (_∷ʳ_)
+open import Data.List.Relation.Unary.Any using (Any)
+import Data.Maybe.Relation.Unary.All as Maybe
+open import Data.Nat.Base using (_≤_; _≥_)
+import Data.Nat.Properties as ℕₚ
+open import Data.Product.Base using (∃; _,_; proj₂)
+open import Function.Base
+open import Function.Bundles using (_⇔_; _⤖_)
+open import Level
+open import Relation.Binary.Definitions using () renaming (Decidable to Decidable₂)
+open import Relation.Binary.PropositionalEquality.Core using (_≡_; refl; cong)
+open import Relation.Binary.Structures using (IsDecTotalOrder)
+open import Relation.Unary using (Pred; Decidable; Irrelevant)
+open import Relation.Nullary.Negation using (¬_)
+open import Relation.Nullary.Decidable using (¬?; yes; no)
 
-import Data.List.Relation.Binary.Equality.Setoid as SetoidEquality
-import Data.List.Relation.Binary.Sublist.Setoid as SetoidSublist
-import Data.List.Relation.Binary.Sublist.Heterogeneous.Properties
-  as HeteroProperties
-import Data.List.Membership.Setoid as SetoidMembership
+import Data.List.Relation.Binary.Equality.Setoid as SetoidEquality
+import Data.List.Relation.Binary.Sublist.Setoid as SetoidSublist
+import Data.List.Relation.Binary.Sublist.Heterogeneous.Properties
+  as HeteroProperties
+import Data.List.Membership.Setoid as SetoidMembership
 
-open Setoid S using (_≈_; trans) renaming (Carrier to A; refl to ≈-refl)
-open SetoidEquality S using (_≋_; ≋-refl)
-open SetoidSublist S hiding (map)
-open SetoidMembership S using (_∈_)
+open Setoid S using (_≈_; trans) renaming (Carrier to A; refl to ≈-refl)
+open SetoidEquality S using (_≋_; ≋-refl)
+open SetoidSublist S hiding (map)
+open SetoidMembership S using (_∈_)
 
-------------------------------------------------------------------------
--- Injectivity of constructors
-------------------------------------------------------------------------
+------------------------------------------------------------------------
+-- Injectivity of constructors
+------------------------------------------------------------------------
 
-module _ {xs ys : List A} where
+module _ {xs ys : List A} where
 
-  ∷-injectiveˡ : ∀ {x y} {px qx : x ≈ y} {pxs qxs : xs ⊆ ys} →
-                 ((x ∷ xs) ⊆ (y ∷ ys) ∋ px ∷ pxs) ≡ (qx ∷ qxs) → px ≡ qx
-  ∷-injectiveˡ refl = refl
+  ∷-injectiveˡ : ∀ {x y} {px qx : x ≈ y} {pxs qxs : xs ⊆ ys} →
+                 ((x ∷ xs) ⊆ (y ∷ ys) ∋ px ∷ pxs) ≡ (qx ∷ qxs) → px ≡ qx
+  ∷-injectiveˡ refl = refl
 
-  ∷-injectiveʳ : ∀ {x y} {px qx : x ≈ y} {pxs qxs : xs ⊆ ys} →
-                 ((x ∷ xs) ⊆ (y ∷ ys) ∋ px ∷ pxs) ≡ (qx ∷ qxs) → pxs ≡ qxs
-  ∷-injectiveʳ refl = refl
+  ∷-injectiveʳ : ∀ {x y} {px qx : x ≈ y} {pxs qxs : xs ⊆ ys} →
+                 ((x ∷ xs) ⊆ (y ∷ ys) ∋ px ∷ pxs) ≡ (qx ∷ qxs) → pxs ≡ qxs
+  ∷-injectiveʳ refl = refl
 
-  ∷ʳ-injective : ∀ {y} {pxs qxs : xs ⊆ ys} → y ∷ʳ pxs ≡ y ∷ʳ qxs → pxs ≡ qxs
-  ∷ʳ-injective refl = refl
+  ∷ʳ-injective : ∀ {y} {pxs qxs : xs ⊆ ys} → y ∷ʳ pxs ≡ y ∷ʳ qxs → pxs ≡ qxs
+  ∷ʳ-injective refl = refl
 
-------------------------------------------------------------------------
--- Various functions' outputs are sublists
-------------------------------------------------------------------------
+------------------------------------------------------------------------
+-- Various functions' outputs are sublists
+------------------------------------------------------------------------
 
-tail-⊆ : ∀ xs → Maybe.All (_⊆ xs) (tail xs)
-tail-⊆ xs = HeteroProperties.tail-Sublist ⊆-refl
+tail-⊆ : ∀ xs → Maybe.All (_⊆ xs) (tail xs)
+tail-⊆ xs = HeteroProperties.tail-Sublist ⊆-refl
 
-take-⊆ : ∀ n xs → take n xs ⊆ xs
-take-⊆ n xs = HeteroProperties.take-Sublist n ⊆-refl
+take-⊆ : ∀ n xs → take n xs ⊆ xs
+take-⊆ n xs = HeteroProperties.take-Sublist n ⊆-refl
 
-drop-⊆ : ∀ n xs → drop n xs ⊆ xs
-drop-⊆ n xs = HeteroProperties.drop-Sublist n ⊆-refl
+drop-⊆ : ∀ n xs → drop n xs ⊆ xs
+drop-⊆ n xs = HeteroProperties.drop-Sublist n ⊆-refl
 
-module _ {p} {P : Pred A p} (P? : Decidable P) where
+module _ {p} {P : Pred A p} (P? : Decidable P) where
 
-  takeWhile-⊆ : ∀ xs → takeWhile P? xs ⊆ xs
-  takeWhile-⊆ xs = HeteroProperties.takeWhile-Sublist P? ⊆-refl
+  takeWhile-⊆ : ∀ xs → takeWhile P? xs ⊆ xs
+  takeWhile-⊆ xs = HeteroProperties.takeWhile-Sublist P? ⊆-refl
 
-  dropWhile-⊆ : ∀ xs → dropWhile P? xs ⊆ xs
-  dropWhile-⊆ xs = HeteroProperties.dropWhile-Sublist P? ⊆-refl
+  dropWhile-⊆ : ∀ xs → dropWhile P? xs ⊆ xs
+  dropWhile-⊆ xs = HeteroProperties.dropWhile-Sublist P? ⊆-refl
 
-  filter-⊆ : ∀ xs → filter P? xs ⊆ xs
-  filter-⊆ xs = HeteroProperties.filter-Sublist P? ⊆-refl
+  filter-⊆ : ∀ xs → filter P? xs ⊆ xs
+  filter-⊆ xs = HeteroProperties.filter-Sublist P? ⊆-refl
 
-module _ {p} {P : Pred A p} (P? : Decidable P) where
+module _ {p} {P : Pred A p} (P? : Decidable P) where
 
-  takeWhile⊆filter : ∀ xs → takeWhile P? xs ⊆ filter P? xs
-  takeWhile⊆filter xs = HeteroProperties.takeWhile-filter P? {xs} ≋-refl
+  takeWhile⊆filter : ∀ xs → takeWhile P? xs ⊆ filter P? xs
+  takeWhile⊆filter xs = HeteroProperties.takeWhile-filter P? {xs} ≋-refl
 
-  filter⊆dropWhile : ∀ xs → filter P? xs ⊆ dropWhile (¬? ∘ P?) xs
-  filter⊆dropWhile xs = HeteroProperties.filter-dropWhile P? {xs} ≋-refl
+  filter⊆dropWhile : ∀ xs → filter P? xs ⊆ dropWhile (¬? ∘ P?) xs
+  filter⊆dropWhile xs = HeteroProperties.filter-dropWhile P? {xs} ≋-refl
 
-------------------------------------------------------------------------
--- Various list functions are increasing wrt _⊆_
-------------------------------------------------------------------------
--- We write f⁺ for the proof that `xs ⊆ ys → f xs ⊆ f ys`
--- and f⁻ for the one that `f xs ⊆ f ys → xs ⊆ ys`.
+------------------------------------------------------------------------
+-- Various list functions are increasing wrt _⊆_
+------------------------------------------------------------------------
+-- We write f⁺ for the proof that `xs ⊆ ys → f xs ⊆ f ys`
+-- and f⁻ for the one that `f xs ⊆ f ys → xs ⊆ ys`.
 
-module _ {as bs : List A} where
+module _ {as bs : List A} where
 
-  ∷ˡ⁻ : ∀ {a} → a ∷ as ⊆ bs → as ⊆ bs
-  ∷ˡ⁻ = HeteroProperties.∷ˡ⁻
+  ∷ˡ⁻ : ∀ {a} → a ∷ as ⊆ bs → as ⊆ bs
+  ∷ˡ⁻ = HeteroProperties.∷ˡ⁻
 
-  ∷ʳ⁻ : ∀ {a b} → ¬ (a ≈ b) → a ∷ as ⊆ b ∷ bs → a ∷ as ⊆ bs
-  ∷ʳ⁻ = HeteroProperties.∷ʳ⁻
+  ∷ʳ⁻ : ∀ {a b} → ¬ (a ≈ b) → a ∷ as ⊆ b ∷ bs → a ∷ as ⊆ bs
+  ∷ʳ⁻ = HeteroProperties.∷ʳ⁻
 
-  ∷⁻ : ∀ {a b} → a ∷ as ⊆ b ∷ bs → as ⊆ bs
-  ∷⁻ = HeteroProperties.∷⁻
+  ∷⁻ : ∀ {a b} → a ∷ as ⊆ b ∷ bs → as ⊆ bs
+  ∷⁻ = HeteroProperties.∷⁻
 
-------------------------------------------------------------------------
--- map
+------------------------------------------------------------------------
+-- map
 
-module _ {b ℓ} (R : Setoid b ℓ) where
+module _ {b ℓ} (R : Setoid b ℓ) where
 
-  open Setoid R using () renaming (Carrier to B; _≈_ to _≈′_)
-  open SetoidSublist R using () renaming (_⊆_ to _⊆′_)
+  open Setoid R using () renaming (Carrier to B; _≈_ to _≈′_)
+  open SetoidSublist R using () renaming (_⊆_ to _⊆′_)
 
-  map⁺ : ∀ {as bs} {f : A → B} → f Preserves _≈_ ⟶ _≈′_ →
-         as ⊆ bs → map f as ⊆′ map f bs
-  map⁺ {f = f} f-resp as⊆bs =
-    HeteroProperties.map⁺ f f (SetoidSublist.map S f-resp as⊆bs)
+  map⁺ : ∀ {as bs} {f : A → B} → f Preserves _≈_ ⟶ _≈′_ →
+         as ⊆ bs → map f as ⊆′ map f bs
+  map⁺ {f = f} f-resp as⊆bs =
+    HeteroProperties.map⁺ f f (SetoidSublist.map S f-resp as⊆bs)
 
-------------------------------------------------------------------------
--- _++_
+------------------------------------------------------------------------
+-- _++_
 
-module _ {as bs : List A} where
+module _ {as bs : List A} where
 
-  ++⁺ˡ : ∀ cs → as ⊆ bs → as ⊆ cs ++ bs
-  ++⁺ˡ = HeteroProperties.++ˡ
+  ++⁺ˡ : ∀ cs → as ⊆ bs → as ⊆ cs ++ bs
+  ++⁺ˡ = HeteroProperties.++ˡ
 
-  ++⁺ʳ : ∀ cs → as ⊆ bs → as ⊆ bs ++ cs
-  ++⁺ʳ = HeteroProperties.++ʳ
+  ++⁺ʳ : ∀ cs → as ⊆ bs → as ⊆ bs ++ cs
+  ++⁺ʳ = HeteroProperties.++ʳ
 
-  ++⁺ : ∀ {cs ds} → as ⊆ bs → cs ⊆ ds → as ++ cs ⊆ bs ++ ds
-  ++⁺ = HeteroProperties.++⁺
+  ++⁺ : ∀ {cs ds} → as ⊆ bs → cs ⊆ ds → as ++ cs ⊆ bs ++ ds
+  ++⁺ = HeteroProperties.++⁺
 
-  ++⁻ : ∀ {cs ds} → length as ≡ length bs → as ++ cs ⊆ bs ++ ds → cs ⊆ ds
-  ++⁻ = HeteroProperties.++⁻
+  ++⁻ : ∀ {cs ds} → length as ≡ length bs → as ++ cs ⊆ bs ++ ds → cs ⊆ ds
+  ++⁻ = HeteroProperties.++⁻
 
-------------------------------------------------------------------------
--- take
+------------------------------------------------------------------------
+-- take
 
-module _ {m n} {xs} where
+module _ {m n} {xs} where
 
-  take⁺ : m ≤ n → take m xs ⊆ take n xs
-  take⁺ m≤n = HeteroProperties.take⁺ m≤n ≋-refl
+  take⁺ : m ≤ n → take m xs ⊆ take n xs
+  take⁺ m≤n = HeteroProperties.take⁺ m≤n ≋-refl
 
-------------------------------------------------------------------------
--- drop
+------------------------------------------------------------------------
+-- drop
 
-module _ {m n} {xs ys : List A} where
+module _ {m n} {xs ys : List A} where
 
-  drop⁺ : m ≥ n → xs ⊆ ys → drop m xs ⊆ drop n ys
-  drop⁺ = HeteroProperties.drop⁺
+  drop⁺ : m ≥ n → xs ⊆ ys → drop m xs ⊆ drop n ys
+  drop⁺ = HeteroProperties.drop⁺
 
-module _ {m n} {xs : List A} where
+module _ {m n} {xs : List A} where
 
-  drop⁺-≥ : m ≥ n → drop m xs ⊆ drop n xs
-  drop⁺-≥ m≥n = drop⁺ m≥n ⊆-refl
+  drop⁺-≥ : m ≥ n → drop m xs ⊆ drop n xs
+  drop⁺-≥ m≥n = drop⁺ m≥n ⊆-refl
 
-module _ {xs ys : List A} where
+module _ {xs ys : List A} where
 
-  drop⁺-⊆ : ∀ n → xs ⊆ ys → drop n xs ⊆ drop n ys
-  drop⁺-⊆ n xs⊆ys = drop⁺ {n} ℕₚ.≤-refl xs⊆ys
+  drop⁺-⊆ : ∀ n → xs ⊆ ys → drop n xs ⊆ drop n ys
+  drop⁺-⊆ n xs⊆ys = drop⁺ {n} ℕₚ.≤-refl xs⊆ys
 
-------------------------------------------------------------------------
--- takeWhile / dropWhile
+------------------------------------------------------------------------
+-- takeWhile / dropWhile
 
-module _ {p q} {P : Pred A p} {Q : Pred A q}
-         (P? : Decidable P) (Q? : Decidable Q) where
+module _ {p q} {P : Pred A p} {Q : Pred A q}
+         (P? : Decidable P) (Q? : Decidable Q) where
 
-  takeWhile⁺ : ∀ {xs} → (∀ {a b} → a ≈ b → P a → Q b) →
-               takeWhile P? xs ⊆ takeWhile Q? xs
-  takeWhile⁺ {xs} P⇒Q = HeteroProperties.⊆-takeWhile-Sublist P? Q? {xs} P⇒Q ≋-refl
+  takeWhile⁺ : ∀ {xs} → (∀ {a b} → a ≈ b → P a → Q b) →
+               takeWhile P? xs ⊆ takeWhile Q? xs
+  takeWhile⁺ {xs} P⇒Q = HeteroProperties.⊆-takeWhile-Sublist P? Q? {xs} P⇒Q ≋-refl
 
-  dropWhile⁺ : ∀ {xs} → (∀ {a b} → a ≈ b → Q b → P a) →
-               dropWhile P? xs ⊆ dropWhile Q? xs
-  dropWhile⁺ {xs} P⇒Q = HeteroProperties.⊇-dropWhile-Sublist P? Q? {xs} P⇒Q ≋-refl
+  dropWhile⁺ : ∀ {xs} → (∀ {a b} → a ≈ b → Q b → P a) →
+               dropWhile P? xs ⊆ dropWhile Q? xs
+  dropWhile⁺ {xs} P⇒Q = HeteroProperties.⊇-dropWhile-Sublist P? Q? {xs} P⇒Q ≋-refl
 
-------------------------------------------------------------------------
--- filter
+------------------------------------------------------------------------
+-- filter
 
-module _ {p q} {P : Pred A p} {Q : Pred A q}
-         (P? : Decidable P) (Q? : Decidable Q) where
+module _ {p q} {P : Pred A p} {Q : Pred A q}
+         (P? : Decidable P) (Q? : Decidable Q) where
 
-  filter⁺ : ∀ {as bs} → (∀ {a b} → a ≈ b → P a → Q b) →
-            as ⊆ bs → filter P? as ⊆ filter Q? bs
-  filter⁺ = HeteroProperties.⊆-filter-Sublist P? Q?
+  filter⁺ : ∀ {as bs} → (∀ {a b} → a ≈ b → P a → Q b) →
+            as ⊆ bs → filter P? as ⊆ filter Q? bs
+  filter⁺ = HeteroProperties.⊆-filter-Sublist P? Q?
 
-------------------------------------------------------------------------
--- reverse
+------------------------------------------------------------------------
+-- reverse
 
-module _ {as bs : List A} where
+module _ {as bs : List A} where
 
-  reverseAcc⁺ : ∀ {cs ds} → as ⊆ bs → cs ⊆ ds →
-                reverseAcc cs as ⊆ reverseAcc ds bs
-  reverseAcc⁺ = HeteroProperties.reverseAcc⁺
+  reverseAcc⁺ : ∀ {cs ds} → as ⊆ bs → cs ⊆ ds →
+                reverseAcc cs as ⊆ reverseAcc ds bs
+  reverseAcc⁺ = HeteroProperties.reverseAcc⁺
 
-  ʳ++⁺ : ∀ {cs ds} →
-         as ⊆ bs →
-         cs ⊆ ds →
-         as ʳ++ cs ⊆ bs ʳ++ ds
-  ʳ++⁺ = reverseAcc⁺
+  ʳ++⁺ : ∀ {cs ds} →
+         as ⊆ bs →
+         cs ⊆ ds →
+         as ʳ++ cs ⊆ bs ʳ++ ds
+  ʳ++⁺ = reverseAcc⁺
 
-  reverse⁺ : as ⊆ bs → reverse as ⊆ reverse bs
-  reverse⁺ = HeteroProperties.reverse⁺
+  reverse⁺ : as ⊆ bs → reverse as ⊆ reverse bs
+  reverse⁺ = HeteroProperties.reverse⁺
 
-  reverse⁻ : reverse as ⊆ reverse bs → as ⊆ bs
-  reverse⁻ = HeteroProperties.reverse⁻
+  reverse⁻ : reverse as ⊆ reverse bs → as ⊆ bs
+  reverse⁻ = HeteroProperties.reverse⁻
 
-------------------------------------------------------------------------
--- Inversion lemmas
-------------------------------------------------------------------------
+------------------------------------------------------------------------
+-- merge
 
-module _ {a as b bs} where
+module _ {ℓ′} {_≤_ : Rel A ℓ′} (_≤?_ : Decidable₂ _≤_) where
 
-  ∷⁻¹ : a ≈ b → as ⊆ bs ⇔ a ∷ as ⊆ b ∷ bs
-  ∷⁻¹ = HeteroProperties.∷⁻¹
+  ⊆-mergeˡ : ∀ xs ys → xs ⊆ merge _≤?_ xs ys
+  ⊆-mergeˡ []       ys = minimum ys
+  ⊆-mergeˡ (x ∷ xs) [] = ⊆-refl
+  ⊆-mergeˡ (x ∷ xs) (y ∷ ys)
+   with x ≤? y  | ⊆-mergeˡ xs (y ∷ ys)
+                      | ⊆-mergeˡ (x ∷ xs) ys
+  ... | yes x≤y | rec | _   = ≈-refl ∷ rec
+  ... | no  x≰y | _   | rec = y ∷ʳ rec
 
-  ∷ʳ⁻¹ : ¬ (a ≈ b) → a ∷ as ⊆ bs ⇔ a ∷ as ⊆ b ∷ bs
-  ∷ʳ⁻¹ = HeteroProperties.∷ʳ⁻¹
+  ⊆-mergeʳ : ∀ xs ys → ys ⊆ merge _≤?_ xs ys
+  ⊆-mergeʳ [] ys =  ⊆-refl
+  ⊆-mergeʳ (x ∷ xs) [] = minimum (merge _≤?_ (x ∷ xs) [])
+  ⊆-mergeʳ (x ∷ xs) (y ∷ ys)
+   with x ≤? y  | ⊆-mergeʳ xs (y ∷ ys)
+                      | ⊆-mergeʳ (x ∷ xs) ys
+  ... | yes x≤y | rec | _   = x ∷ʳ rec
+  ... | no  x≰y | _   | rec = ≈-refl ∷ rec
 
-------------------------------------------------------------------------
--- Other
-------------------------------------------------------------------------
+------------------------------------------------------------------------
+-- Inversion lemmas
+------------------------------------------------------------------------
 
-module _ where
+module _ {a as b bs} where
 
-  length-mono-≤ : ∀ {as bs} → as ⊆ bs → length as ≤ length bs
-  length-mono-≤ = HeteroProperties.length-mono-≤
+  ∷⁻¹ : a ≈ b → as ⊆ bs ⇔ a ∷ as ⊆ b ∷ bs
+  ∷⁻¹ = HeteroProperties.∷⁻¹
 
-------------------------------------------------------------------------
--- Conversion to and from list equality
+  ∷ʳ⁻¹ : ¬ (a ≈ b) → a ∷ as ⊆ bs ⇔ a ∷ as ⊆ b ∷ bs
+  ∷ʳ⁻¹ = HeteroProperties.∷ʳ⁻¹
 
-  to-≋ : ∀ {as bs} → length as ≡ length bs → as ⊆ bs → as ≋ bs
-  to-≋ = HeteroProperties.toPointwise
+------------------------------------------------------------------------
+-- Other
+------------------------------------------------------------------------
 
-------------------------------------------------------------------------
--- Irrelevant special case
+module _ where
 
-  []⊆-irrelevant : Irrelevant ([] ⊆_)
-  []⊆-irrelevant = HeteroProperties.Sublist-[]-irrelevant
+  length-mono-≤ : ∀ {as bs} → as ⊆ bs → length as ≤ length bs
+  length-mono-≤ = HeteroProperties.length-mono-≤
 
-------------------------------------------------------------------------
--- (to/from)∈ is a bijection
+------------------------------------------------------------------------
+-- Conversion to and from list equality
 
-module _ {x xs} where
+  to-≋ : ∀ {as bs} → length as ≡ length bs → as ⊆ bs → as ≋ bs
+  to-≋ = HeteroProperties.toPointwise
 
-  to∈-injective : ∀ {p q : [ x ] ⊆ xs} → to∈ p ≡ to∈ q → p ≡ q
-  to∈-injective = HeteroProperties.toAny-injective
+------------------------------------------------------------------------
+-- Irrelevant special case
 
-  from∈-injective : ∀ {p q : x ∈ xs} → from∈ p ≡ from∈ q → p ≡ q
-  from∈-injective = HeteroProperties.fromAny-injective
+  []⊆-irrelevant : Irrelevant ([] ⊆_)
+  []⊆-irrelevant = HeteroProperties.Sublist-[]-irrelevant
 
-  to∈∘from∈≗id : ∀ (p : x ∈ xs) → to∈ (from∈ p) ≡ p
-  to∈∘from∈≗id = HeteroProperties.toAny∘fromAny≗id
+------------------------------------------------------------------------
+-- (to/from)∈ is a bijection
 
-  [x]⊆xs⤖x∈xs : ([ x ] ⊆ xs) ⤖ (x ∈ xs)
-  [x]⊆xs⤖x∈xs = HeteroProperties.Sublist-[x]-bijection
+module _ {x xs} where
 
-------------------------------------------------------------------------
--- Properties of Disjoint(ness) and DisjointUnion
+  to∈-injective : ∀ {p q : [ x ] ⊆ xs} → to∈ p ≡ to∈ q → p ≡ q
+  to∈-injective = HeteroProperties.toAny-injective
 
-open HeteroProperties.Disjointness {R = _≈_} public
-open HeteroProperties.DisjointnessMonotonicity {R = _≈_} {S = _≈_} {T = _≈_} trans public
+  from∈-injective : ∀ {p q : x ∈ xs} → from∈ p ≡ from∈ q → p ≡ q
+  from∈-injective = HeteroProperties.fromAny-injective
 
--- Shrinking one of two disjoint lists preserves disjointness.
+  to∈∘from∈≗id : ∀ (p : x ∈ xs) → to∈ (from∈ p) ≡ p
+  to∈∘from∈≗id = HeteroProperties.toAny∘fromAny≗id
 
--- We would have liked to define  shrinkDisjointˡ σ = shrinkDisjoint σ ⊆-refl
--- but alas, this is only possible for groupoids, not setoids in general.
+  [x]⊆xs⤖x∈xs : ([ x ] ⊆ xs) ⤖ (x ∈ xs)
+  [x]⊆xs⤖x∈xs = HeteroProperties.Sublist-[x]-bijection
 
-shrinkDisjointˡ : ∀ {xs ys zs us} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} (σ : us ⊆ xs) →
-    Disjoint τ₁ τ₂ →
-    Disjoint (⊆-trans σ τ₁) τ₂
--- Not affected by σ:
-shrinkDisjointˡ σ          (y   ∷ₙ d) = y             ∷ₙ shrinkDisjointˡ σ d
-shrinkDisjointˡ σ          (y≈z ∷ᵣ d) = y≈z           ∷ᵣ shrinkDisjointˡ σ d
--- In σ: keep x.
-shrinkDisjointˡ (u≈x ∷ σ)  (x≈z ∷ₗ d) = trans u≈x x≈z ∷ₗ shrinkDisjointˡ σ d
--- Not in σ: drop x.
-shrinkDisjointˡ (x  ∷ʳ σ)  (x≈z ∷ₗ d) = _             ∷ₙ shrinkDisjointˡ σ d
-shrinkDisjointˡ []         []         = []
+------------------------------------------------------------------------
+-- Properties of Disjoint(ness) and DisjointUnion
 
-shrinkDisjointʳ : ∀ {xs ys zs vs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} (σ : vs ⊆ ys) →
-  Disjoint τ₁ τ₂ →
-  Disjoint τ₁ (⊆-trans σ τ₂)
--- Not affected by σ:
-shrinkDisjointʳ σ          (y   ∷ₙ d) = y             ∷ₙ shrinkDisjointʳ σ d
-shrinkDisjointʳ σ          (x≈z ∷ₗ d) = x≈z           ∷ₗ shrinkDisjointʳ σ d
--- In σ: keep y.
-shrinkDisjointʳ (v≈y ∷ σ)  (y≈z ∷ᵣ d) = trans v≈y y≈z ∷ᵣ shrinkDisjointʳ σ d
--- Not in σ: drop y.
-shrinkDisjointʳ (y  ∷ʳ σ)  (y≈z ∷ᵣ d) = _             ∷ₙ shrinkDisjointʳ σ d
-shrinkDisjointʳ []         []         = []
+open HeteroProperties.Disjointness {R = _≈_} public
+open HeteroProperties.DisjointnessMonotonicity {R = _≈_} {S = _≈_} {T = _≈_} trans public
+
+-- Shrinking one of two disjoint lists preserves disjointness.
+
+-- We would have liked to define  shrinkDisjointˡ σ = shrinkDisjoint σ ⊆-refl
+-- but alas, this is only possible for groupoids, not setoids in general.
+
+shrinkDisjointˡ : ∀ {xs ys zs us} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} (σ : us ⊆ xs) →
+    Disjoint τ₁ τ₂ →
+    Disjoint (⊆-trans σ τ₁) τ₂
+-- Not affected by σ:
+shrinkDisjointˡ σ          (y   ∷ₙ d) = y             ∷ₙ shrinkDisjointˡ σ d
+shrinkDisjointˡ σ          (y≈z ∷ᵣ d) = y≈z           ∷ᵣ shrinkDisjointˡ σ d
+-- In σ: keep x.
+shrinkDisjointˡ (u≈x ∷ σ)  (x≈z ∷ₗ d) = trans u≈x x≈z ∷ₗ shrinkDisjointˡ σ d
+-- Not in σ: drop x.
+shrinkDisjointˡ (x  ∷ʳ σ)  (x≈z ∷ₗ d) = _             ∷ₙ shrinkDisjointˡ σ d
+shrinkDisjointˡ []         []         = []
+
+shrinkDisjointʳ : ∀ {xs ys zs vs} {τ₁ : xs ⊆ zs} {τ₂ : ys ⊆ zs} (σ : vs ⊆ ys) →
+  Disjoint τ₁ τ₂ →
+  Disjoint τ₁ (⊆-trans σ τ₂)
+-- Not affected by σ:
+shrinkDisjointʳ σ          (y   ∷ₙ d) = y             ∷ₙ shrinkDisjointʳ σ d
+shrinkDisjointʳ σ          (x≈z ∷ₗ d) = x≈z           ∷ₗ shrinkDisjointʳ σ d
+-- In σ: keep y.
+shrinkDisjointʳ (v≈y ∷ σ)  (y≈z ∷ᵣ d) = trans v≈y y≈z ∷ᵣ shrinkDisjointʳ σ d
+-- Not in σ: drop y.
+shrinkDisjointʳ (y  ∷ʳ σ)  (y≈z ∷ᵣ d) = _             ∷ₙ shrinkDisjointʳ σ d
+shrinkDisjointʳ []         []         = []
 

\ No newline at end of file
diff --git a/Data.List.Relation.Binary.Sublist.Setoid.html b/Data.List.Relation.Binary.Sublist.Setoid.html
index 5e3ccaaf..1b71498f 100644
--- a/Data.List.Relation.Binary.Sublist.Setoid.html
+++ b/Data.List.Relation.Binary.Sublist.Setoid.html
@@ -10,267 +10,270 @@
 {-# OPTIONS --cubical-compatible --safe #-}
 {-# OPTIONS --postfix-projections #-}
 
-open import Relation.Binary using (Setoid; Rel)
+open import Relation.Binary.Core using (Rel)
+open import Relation.Binary.Bundles using (Setoid)
 
-module Data.List.Relation.Binary.Sublist.Setoid
-  {c ℓ} (S : Setoid c ℓ) where
+module Data.List.Relation.Binary.Sublist.Setoid
+  {c ℓ} (S : Setoid c ℓ) where
 
-open import Level using (_⊔_)
+open import Level using (_⊔_)
 
-open import Data.List.Base using (List; []; _∷_)
-import Data.List.Relation.Binary.Equality.Setoid as SetoidEquality
-import Data.List.Relation.Binary.Sublist.Heterogeneous as Heterogeneous
-import Data.List.Relation.Binary.Sublist.Heterogeneous.Core
-  as HeterogeneousCore
-import Data.List.Relation.Binary.Sublist.Heterogeneous.Properties
-  as HeterogeneousProperties
-open import Data.Product using (∃; ∃₂; _×_; _,_; proj₂)
+open import Data.List.Base using (List; []; _∷_)
+import Data.List.Relation.Binary.Equality.Setoid as SetoidEquality
+import Data.List.Relation.Binary.Sublist.Heterogeneous as Heterogeneous
+import Data.List.Relation.Binary.Sublist.Heterogeneous.Core
+  as HeterogeneousCore
+import Data.List.Relation.Binary.Sublist.Heterogeneous.Properties
+  as HeterogeneousProperties
+open import Data.Product.Base using (∃; ∃₂; _×_; _,_; proj₂)
 
-open import Relation.Binary
-open import Relation.Binary.PropositionalEquality as P using (_≡_)
-open import Relation.Nullary using (¬_; Dec; yes; no)
+open import Relation.Binary.Core using (_⇒_)
+open import Relation.Binary.Bundles using (Preorder; Poset)
+open import Relation.Binary.Structures using (IsPreorder; IsPartialOrder)
+open import Relation.Binary.PropositionalEquality.Core as P using (_≡_)
+open import Relation.Nullary using (¬_; Dec; yes; no)
 
-open Setoid S renaming (Carrier to A)
-open SetoidEquality S
+open Setoid S renaming (Carrier to A)
+open SetoidEquality S
 
-------------------------------------------------------------------------
--- Definition
-
-infix 4 _⊆_ _⊇_ _⊂_ _⊃_ _⊈_ _⊉_ _⊄_ _⊅_
-
-_⊆_ : Rel (List A) (c ⊔ ℓ)
-_⊆_ = Heterogeneous.Sublist _≈_
-
-_⊇_ : Rel (List A) (c ⊔ ℓ)
-xs ⊇ ys = ys ⊆ xs
-
-_⊂_ : Rel (List A) (c ⊔ ℓ)
-xs ⊂ ys = xs ⊆ ys × ¬ (xs ≋ ys)
-
-_⊃_ : Rel (List A) (c ⊔ ℓ)
-xs ⊃ ys = ys ⊂ xs
-
-_⊈_ : Rel (List A) (c ⊔ ℓ)
-xs ⊈ ys = ¬ (xs ⊆ ys)
-
-_⊉_ : Rel (List A) (c ⊔ ℓ)
-xs ⊉ ys = ¬ (xs ⊇ ys)
-
-_⊄_ : Rel (List A) (c ⊔ ℓ)
-xs ⊄ ys = ¬ (xs ⊂ ys)
-
-_⊅_ : Rel (List A) (c ⊔ ℓ)
-xs ⊅ ys = ¬ (xs ⊃ ys)
-
-------------------------------------------------------------------------
--- Re-export definitions and operations from heterogeneous sublists
-
-open HeterogeneousCore _≈_ public
-  using ([]; _∷_; _∷ʳ_)
-
-open Heterogeneous {R = _≈_} public
-  hiding (Sublist; []; _∷_; _∷ʳ_)
-  renaming
-  ( toAny   to to∈
-  ; fromAny to from∈
-  )
-
-open Disjoint public
-  using ([])
-
-open DisjointUnion public
-  using ([])
-
-------------------------------------------------------------------------
--- Relational properties holding for Setoid case
-
-⊆-reflexive : _≋_ ⇒ _⊆_
-⊆-reflexive = HeterogeneousProperties.fromPointwise
-
-open HeterogeneousProperties.Reflexivity {R = _≈_} refl public using ()
-  renaming (refl to ⊆-refl)  -- ⊆-refl : Reflexive _⊆_
-
-open HeterogeneousProperties.Transitivity {R = _≈_} {S = _≈_} {T = _≈_} trans public using ()
-  renaming (trans to ⊆-trans)  -- ⊆-trans : Transitive _⊆_
-
-open HeterogeneousProperties.Antisymmetry {R = _≈_} {S = _≈_} (λ x≈y _ → x≈y) public using ()
-  renaming (antisym to ⊆-antisym)  -- ⊆-antisym : Antisymmetric _≋_ _⊆_
-
-⊆-isPreorder : IsPreorder _≋_ _⊆_
-⊆-isPreorder = record
-  { isEquivalence = ≋-isEquivalence
-  ; reflexive     = ⊆-reflexive
-  ; trans         = ⊆-trans
-  }
-
-⊆-isPartialOrder : IsPartialOrder _≋_ _⊆_
-⊆-isPartialOrder = record
-  { isPreorder = ⊆-isPreorder
-  ; antisym    = ⊆-antisym
-  }
-
-⊆-preorder : Preorder c (c ⊔ ℓ) (c ⊔ ℓ)
-⊆-preorder = record
-  { isPreorder = ⊆-isPreorder
-  }
-
-⊆-poset : Poset c (c ⊔ ℓ) (c ⊔ ℓ)
-⊆-poset = record
-  { isPartialOrder = ⊆-isPartialOrder
-  }
-
-------------------------------------------------------------------------
--- Raw pushout
---
--- The category _⊆_ does not have proper pushouts.  For instance consider:
---
---   τᵤ : [] ⊆ (u ∷ [])
---   τᵥ : [] ⊆ (v ∷ [])
---
--- Then, there are two unrelated upper bounds (u ∷ v ∷ []) and (v ∷ u ∷ []),
--- since _⊆_ does not include permutations.
---
--- Even though there are no unique least upper bounds, we can merge two
--- extensions of a list, producing a minimial superlist of both.
---
--- For the example, the left-biased merge would produce the pair:
+------------------------------------------------------------------------
+-- Definition
+
+infix 4 _⊆_ _⊇_ _⊂_ _⊃_ _⊈_ _⊉_ _⊄_ _⊅_
+
+_⊆_ : Rel (List A) (c ⊔ ℓ)
+_⊆_ = Heterogeneous.Sublist _≈_
+
+_⊇_ : Rel (List A) (c ⊔ ℓ)
+xs ⊇ ys = ys ⊆ xs
+
+_⊂_ : Rel (List A) (c ⊔ ℓ)
+xs ⊂ ys = xs ⊆ ys × ¬ (xs ≋ ys)
+
+_⊃_ : Rel (List A) (c ⊔ ℓ)
+xs ⊃ ys = ys ⊂ xs
+
+_⊈_ : Rel (List A) (c ⊔ ℓ)
+xs ⊈ ys = ¬ (xs ⊆ ys)
+
+_⊉_ : Rel (List A) (c ⊔ ℓ)
+xs ⊉ ys = ¬ (xs ⊇ ys)
+
+_⊄_ : Rel (List A) (c ⊔ ℓ)
+xs ⊄ ys = ¬ (xs ⊂ ys)
+
+_⊅_ : Rel (List A) (c ⊔ ℓ)
+xs ⊅ ys = ¬ (xs ⊃ ys)
+
+------------------------------------------------------------------------
+-- Re-export definitions and operations from heterogeneous sublists
+
+open HeterogeneousCore _≈_ public
+  using ([]; _∷_; _∷ʳ_)
+
+open Heterogeneous {R = _≈_} public
+  hiding (Sublist; []; _∷_; _∷ʳ_)
+  renaming
+  ( toAny   to to∈
+  ; fromAny to from∈
+  )
+
+open Disjoint public
+  using ([])
+
+open DisjointUnion public
+  using ([])
+
+------------------------------------------------------------------------
+-- Relational properties holding for Setoid case
+
+⊆-reflexive : _≋_ ⇒ _⊆_
+⊆-reflexive = HeterogeneousProperties.fromPointwise
+
+open HeterogeneousProperties.Reflexivity {R = _≈_} refl public using ()
+  renaming (refl to ⊆-refl)  -- ⊆-refl : Reflexive _⊆_
+
+open HeterogeneousProperties.Transitivity {R = _≈_} {S = _≈_} {T = _≈_} trans public using ()
+  renaming (trans to ⊆-trans)  -- ⊆-trans : Transitive _⊆_
+
+open HeterogeneousProperties.Antisymmetry {R = _≈_} {S = _≈_} (λ x≈y _ → x≈y) public using ()
+  renaming (antisym to ⊆-antisym)  -- ⊆-antisym : Antisymmetric _≋_ _⊆_
+
+⊆-isPreorder : IsPreorder _≋_ _⊆_
+⊆-isPreorder = record
+  { isEquivalence = ≋-isEquivalence
+  ; reflexive     = ⊆-reflexive
+  ; trans         = ⊆-trans
+  }
+
+⊆-isPartialOrder : IsPartialOrder _≋_ _⊆_
+⊆-isPartialOrder = record
+  { isPreorder = ⊆-isPreorder
+  ; antisym    = ⊆-antisym
+  }
+
+⊆-preorder : Preorder c (c ⊔ ℓ) (c ⊔ ℓ)
+⊆-preorder = record
+  { isPreorder = ⊆-isPreorder
+  }
+
+⊆-poset : Poset c (c ⊔ ℓ) (c ⊔ ℓ)
+⊆-poset = record
+  { isPartialOrder = ⊆-isPartialOrder
+  }
+
+------------------------------------------------------------------------
+-- Raw pushout
+--
+-- The category _⊆_ does not have proper pushouts.  For instance consider:
+--
+--   τᵤ : [] ⊆ (u ∷ [])
+--   τᵥ : [] ⊆ (v ∷ [])
+--
+-- Then, there are two unrelated upper bounds (u ∷ v ∷ []) and (v ∷ u ∷ []),
+-- since _⊆_ does not include permutations.
 --
---   τᵤ′ : (u ∷ []) ⊆ (u ∷ v ∷ [])
---   τᵥ′ : (v ∷ []) ⊆ (u ∷ v ∷ [])
---
--- We call such a pair a raw pushout.  It is then a weak pushout if the
--- resulting square commutes, i.e.:
---
---   ⊆-trans τᵤ τᵤ′ ~ ⊆-trans τᵥ τᵥ′
---
--- This requires a notion of equality _~_ on sublist morphisms.
---
--- Further, commutation requires a similar commutation property
--- for the underlying equality _≈_, namely
---
---   trans x≈y (sym x≈y) == trans x≈z (sym x≈z)
---
--- for some notion of equality _==_ for equality proofs _≈_.
--- Such a property is given e.g. if _≈_ is proof irrelevant
--- or forms a groupoid.
-
-record RawPushout {xs ys zs : List A} (τ : xs ⊆ ys) (σ : xs ⊆ zs) : Set (c ⊔ ℓ) where
-  field
-    {upperBound} : List A
-    leg₁         : ys ⊆ upperBound
-    leg₂         : zs ⊆ upperBound
-
-open RawPushout
-
-------------------------------------------------------------------------
--- Extending corners of a raw pushout square
-
--- Extending the right upper corner.
-
-infixr 5 _∷ʳ₁_ _∷ʳ₂_
-
-_∷ʳ₁_ : ∀ {xs ys zs : List A} {τ : xs ⊆ ys} {σ : xs ⊆ zs} →
-        (y : A) → RawPushout τ σ → RawPushout (y ∷ʳ τ) σ
-y ∷ʳ₁ rpo = record
-  { leg₁ = refl ∷ leg₁ rpo
-  ; leg₂ = y   ∷ʳ leg₂ rpo
-  }
-
--- Extending the left lower corner.
-
-_∷ʳ₂_ : ∀ {xs ys zs : List A} {τ : xs ⊆ ys} {σ : xs ⊆ zs} →
-        (z : A) → RawPushout τ σ → RawPushout τ (z ∷ʳ σ)
-z ∷ʳ₂ rpo = record
-  { leg₁ = z   ∷ʳ leg₁ rpo
-  ; leg₂ = refl ∷ leg₂ rpo
-  }
-
--- Extending both of these corners with equal elements.
-
-∷-rpo : ∀ {x y z : A} {xs ys zs : List A} {τ : xs ⊆ ys} {σ : xs ⊆ zs} →
-        (x≈y : x ≈ y) (x≈z : x ≈ z) → RawPushout τ σ → RawPushout (x≈y ∷ τ) (x≈z ∷ σ)
-∷-rpo x≈y x≈z rpo = record
-  { leg₁ = sym x≈y ∷ leg₁ rpo
-  ; leg₂ = sym x≈z ∷ leg₂ rpo
-  }
-
-------------------------------------------------------------------------
--- Left-biased pushout: add elements of left extension first.
-
-⊆-pushoutˡ : ∀ {xs ys zs : List A} →
-             (τ : xs ⊆ ys) (σ : xs ⊆ zs) → RawPushout τ σ
-⊆-pushoutˡ []        σ         = record { leg₁ = σ ; leg₂ = ⊆-refl }
-⊆-pushoutˡ (y  ∷ʳ τ) σ         = y ∷ʳ₁ ⊆-pushoutˡ τ σ
-⊆-pushoutˡ τ@(_ ∷ _) (z  ∷ʳ σ) = z ∷ʳ₂ ⊆-pushoutˡ τ σ
-⊆-pushoutˡ (x≈y ∷ τ) (x≈z ∷ σ) = ∷-rpo x≈y x≈z (⊆-pushoutˡ τ σ)
-
--- Join two extensions, returning the upper bound and the diagonal
--- of the pushout square.
-
-⊆-joinˡ : ∀ {xs ys zs : List A} →
-          (τ : xs ⊆ ys) (σ : xs ⊆ zs) → ∃ λ us → xs ⊆ us
-⊆-joinˡ τ σ = upperBound rpo , ⊆-trans τ (leg₁ rpo)
-  where
-  rpo = ⊆-pushoutˡ τ σ
-
-
-------------------------------------------------------------------------
--- Upper bound of two sublists xs,ys ⊆ zs
-
-record UpperBound {xs ys zs} (τ : xs ⊆ zs) (σ : ys ⊆ zs) : Set (c ⊔ ℓ) where
-  field
-    {theUpperBound} : List A
-    sub  : theUpperBound ⊆ zs
-    inj₁ : xs ⊆ theUpperBound
-    inj₂ : ys ⊆ theUpperBound
-
-open UpperBound
-
-infixr 5 _∷ₗ-ub_ _∷ᵣ-ub_
-
-∷ₙ-ub : ∀ {xs ys zs} {τ : xs ⊆ zs} {σ : ys ⊆ zs} {x} →
-        UpperBound τ σ → UpperBound (x ∷ʳ τ) (x ∷ʳ σ)
-∷ₙ-ub u = record
-  { sub  = _ ∷ʳ u .sub
-  ; inj₁ = u .inj₁
-  ; inj₂ = u .inj₂
-  }
-
-_∷ₗ-ub_ : ∀ {xs ys zs} {τ : xs ⊆ zs} {σ : ys ⊆ zs} {x y} →
-         (x≈y : x ≈ y) → UpperBound τ σ → UpperBound (x≈y ∷ τ) (y ∷ʳ σ)
-x≈y ∷ₗ-ub u = record
-  { sub = refl ∷ u .sub
-  ; inj₁ = x≈y ∷ u .inj₁
-  ; inj₂ = _  ∷ʳ u .inj₂
-  }
-
-_∷ᵣ-ub_ : ∀ {xs ys zs} {τ : xs ⊆ zs} {σ : ys ⊆ zs} {x y} →
-         (x≈y : x ≈ y) → UpperBound τ σ → UpperBound (y ∷ʳ τ) (x≈y ∷ σ)
-x≈y ∷ᵣ-ub u = record
-  { sub  = refl ∷ u .sub
-  ; inj₁ = _   ∷ʳ u .inj₁
-  ; inj₂ = x≈y  ∷ u .inj₂
-  }
-
-------------------------------------------------------------------------
--- Disjoint union
---
--- Two non-overlapping sublists τ : xs ⊆ zs and σ : ys ⊆ zs
--- can be joined in a unique way if τ and σ are respected.
---
--- For instance, if τ : [x] ⊆ [x,y,x] and σ : [y] ⊆ [x,y,x]
--- then the union will be [x,y] or [y,x], depending on whether
--- τ picks the first x or the second one.
---
--- NB: If the content of τ and σ were ignored then the union would not
--- be unique.  Expressing uniqueness would require a notion of equality
--- of sublist proofs, which we do not (yet) have for the setoid case
--- (however, for the propositional case).
-
-⊆-disjoint-union : ∀ {xs ys zs} {τ : xs ⊆ zs} {σ : ys ⊆ zs} →
-                   Disjoint τ σ → UpperBound τ σ
-⊆-disjoint-union []         = record { sub = [] ; inj₁ = [] ; inj₂ = [] }
-⊆-disjoint-union (x   ∷ₙ d) = ∷ₙ-ub (⊆-disjoint-union d)
-⊆-disjoint-union (x≈y ∷ₗ d) = x≈y ∷ₗ-ub (⊆-disjoint-union d)
-⊆-disjoint-union (x≈y ∷ᵣ d) = x≈y ∷ᵣ-ub (⊆-disjoint-union d)
+-- Even though there are no unique least upper bounds, we can merge two
+-- extensions of a list, producing a minimial superlist of both.
+--
+-- For the example, the left-biased merge would produce the pair:
+--
+--   τᵤ′ : (u ∷ []) ⊆ (u ∷ v ∷ [])
+--   τᵥ′ : (v ∷ []) ⊆ (u ∷ v ∷ [])
+--
+-- We call such a pair a raw pushout.  It is then a weak pushout if the
+-- resulting square commutes, i.e.:
+--
+--   ⊆-trans τᵤ τᵤ′ ~ ⊆-trans τᵥ τᵥ′
+--
+-- This requires a notion of equality _~_ on sublist morphisms.
+--
+-- Further, commutation requires a similar commutation property
+-- for the underlying equality _≈_, namely
+--
+--   trans x≈y (sym x≈y) == trans x≈z (sym x≈z)
+--
+-- for some notion of equality _==_ for equality proofs _≈_.
+-- Such a property is given e.g. if _≈_ is proof irrelevant
+-- or forms a groupoid.
+
+record RawPushout {xs ys zs : List A} (τ : xs ⊆ ys) (σ : xs ⊆ zs) : Set (c ⊔ ℓ) where
+  field
+    {upperBound} : List A
+    leg₁         : ys ⊆ upperBound
+    leg₂         : zs ⊆ upperBound
+
+open RawPushout
+
+------------------------------------------------------------------------
+-- Extending corners of a raw pushout square
+
+-- Extending the right upper corner.
+
+infixr 5 _∷ʳ₁_ _∷ʳ₂_
+
+_∷ʳ₁_ : ∀ {xs ys zs : List A} {τ : xs ⊆ ys} {σ : xs ⊆ zs} →
+        (y : A) → RawPushout τ σ → RawPushout (y ∷ʳ τ) σ
+y ∷ʳ₁ rpo = record
+  { leg₁ = refl ∷ leg₁ rpo
+  ; leg₂ = y   ∷ʳ leg₂ rpo
+  }
+
+-- Extending the left lower corner.
+
+_∷ʳ₂_ : ∀ {xs ys zs : List A} {τ : xs ⊆ ys} {σ : xs ⊆ zs} →
+        (z : A) → RawPushout τ σ → RawPushout τ (z ∷ʳ σ)
+z ∷ʳ₂ rpo = record
+  { leg₁ = z   ∷ʳ leg₁ rpo
+  ; leg₂ = refl ∷ leg₂ rpo
+  }
+
+-- Extending both of these corners with equal elements.
+
+∷-rpo : ∀ {x y z : A} {xs ys zs : List A} {τ : xs ⊆ ys} {σ : xs ⊆ zs} →
+        (x≈y : x ≈ y) (x≈z : x ≈ z) → RawPushout τ σ → RawPushout (x≈y ∷ τ) (x≈z ∷ σ)
+∷-rpo x≈y x≈z rpo = record
+  { leg₁ = sym x≈y ∷ leg₁ rpo
+  ; leg₂ = sym x≈z ∷ leg₂ rpo
+  }
+
+------------------------------------------------------------------------
+-- Left-biased pushout: add elements of left extension first.
+
+⊆-pushoutˡ : ∀ {xs ys zs : List A} →
+             (τ : xs ⊆ ys) (σ : xs ⊆ zs) → RawPushout τ σ
+⊆-pushoutˡ []        σ         = record { leg₁ = σ ; leg₂ = ⊆-refl }
+⊆-pushoutˡ (y  ∷ʳ τ) σ         = y ∷ʳ₁ ⊆-pushoutˡ τ σ
+⊆-pushoutˡ τ@(_ ∷ _) (z  ∷ʳ σ) = z ∷ʳ₂ ⊆-pushoutˡ τ σ
+⊆-pushoutˡ (x≈y ∷ τ) (x≈z ∷ σ) = ∷-rpo x≈y x≈z (⊆-pushoutˡ τ σ)
+
+-- Join two extensions, returning the upper bound and the diagonal
+-- of the pushout square.
+
+⊆-joinˡ : ∀ {xs ys zs : List A} →
+          (τ : xs ⊆ ys) (σ : xs ⊆ zs) → ∃ λ us → xs ⊆ us
+⊆-joinˡ τ σ = upperBound rpo , ⊆-trans τ (leg₁ rpo)
+  where
+  rpo = ⊆-pushoutˡ τ σ
+
+
+------------------------------------------------------------------------
+-- Upper bound of two sublists xs,ys ⊆ zs
+
+record UpperBound {xs ys zs} (τ : xs ⊆ zs) (σ : ys ⊆ zs) : Set (c ⊔ ℓ) where
+  field
+    {theUpperBound} : List A
+    sub  : theUpperBound ⊆ zs
+    inj₁ : xs ⊆ theUpperBound
+    inj₂ : ys ⊆ theUpperBound
+
+open UpperBound
+
+infixr 5 _∷ₗ-ub_ _∷ᵣ-ub_
+
+∷ₙ-ub : ∀ {xs ys zs} {τ : xs ⊆ zs} {σ : ys ⊆ zs} {x} →
+        UpperBound τ σ → UpperBound (x ∷ʳ τ) (x ∷ʳ σ)
+∷ₙ-ub u = record
+  { sub  = _ ∷ʳ u .sub
+  ; inj₁ = u .inj₁
+  ; inj₂ = u .inj₂
+  }
+
+_∷ₗ-ub_ : ∀ {xs ys zs} {τ : xs ⊆ zs} {σ : ys ⊆ zs} {x y} →
+         (x≈y : x ≈ y) → UpperBound τ σ → UpperBound (x≈y ∷ τ) (y ∷ʳ σ)
+x≈y ∷ₗ-ub u = record
+  { sub = refl ∷ u .sub
+  ; inj₁ = x≈y ∷ u .inj₁
+  ; inj₂ = _  ∷ʳ u .inj₂
+  }
+
+_∷ᵣ-ub_ : ∀ {xs ys zs} {τ : xs ⊆ zs} {σ : ys ⊆ zs} {x y} →
+         (x≈y : x ≈ y) → UpperBound τ σ → UpperBound (y ∷ʳ τ) (x≈y ∷ σ)
+x≈y ∷ᵣ-ub u = record
+  { sub  = refl ∷ u .sub
+  ; inj₁ = _   ∷ʳ u .inj₁
+  ; inj₂ = x≈y  ∷ u .inj₂
+  }
+
+------------------------------------------------------------------------
+-- Disjoint union
+--
+-- Two non-overlapping sublists τ : xs ⊆ zs and σ : ys ⊆ zs
+-- can be joined in a unique way if τ and σ are respected.
+--
+-- For instance, if τ : [x] ⊆ [x,y,x] and σ : [y] ⊆ [x,y,x]
+-- then the union will be [x,y] or [y,x], depending on whether
+-- τ picks the first x or the second one.
+--
+-- NB: If the content of τ and σ were ignored then the union would not
+-- be unique.  Expressing uniqueness would require a notion of equality
+-- of sublist proofs, which we do not (yet) have for the setoid case
+-- (however, for the propositional case).
+
+⊆-disjoint-union : ∀ {xs ys zs} {τ : xs ⊆ zs} {σ : ys ⊆ zs} →
+                   Disjoint τ σ → UpperBound τ σ
+⊆-disjoint-union []         = record { sub = [] ; inj₁ = [] ; inj₂ = [] }
+⊆-disjoint-union (x   ∷ₙ d) = ∷ₙ-ub (⊆-disjoint-union d)
+⊆-disjoint-union (x≈y ∷ₗ d) = x≈y ∷ₗ-ub (⊆-disjoint-union d)
+⊆-disjoint-union (x≈y ∷ᵣ d) = x≈y ∷ᵣ-ub (⊆-disjoint-union d)
\ No newline at end of file diff --git a/Data.List.Relation.Binary.Subset.Propositional.html b/Data.List.Relation.Binary.Subset.Propositional.html index f3b417ba..f38108d9 100644 --- a/Data.List.Relation.Binary.Subset.Propositional.html +++ b/Data.List.Relation.Binary.Subset.Propositional.html @@ -11,10 +11,10 @@ {a} {A : Set a} where import Data.List.Relation.Binary.Subset.Setoid as SetoidSubset -open import Relation.Binary.PropositionalEquality using (setoid) +open import Relation.Binary.PropositionalEquality.Properties using (setoid) ------------------------------------------------------------------------- --- Re-export parameterised definitions from setoid sublists +------------------------------------------------------------------------ +-- Re-export parameterised definitions from setoid sublists -open SetoidSubset (setoid A) public +open SetoidSubset (setoid A) public \ No newline at end of file diff --git a/Data.List.Relation.Binary.Subset.Setoid.html b/Data.List.Relation.Binary.Subset.Setoid.html index 4616d3f2..1e63158b 100644 --- a/Data.List.Relation.Binary.Subset.Setoid.html +++ b/Data.List.Relation.Binary.Subset.Setoid.html @@ -7,33 +7,34 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Bundles using (Setoid) -module Data.List.Relation.Binary.Subset.Setoid - {c ℓ} (S : Setoid c ℓ) where +module Data.List.Relation.Binary.Subset.Setoid + {c ℓ} (S : Setoid c ℓ) where -open import Data.List.Base using (List) -open import Data.List.Membership.Setoid S using (_∈_) -open import Function.Base using (flip) -open import Level using (_⊔_) -open import Relation.Nullary.Negation using (¬_) +open import Data.List.Base using (List) +open import Data.List.Membership.Setoid S using (_∈_) +open import Function.Base using (flip) +open import Level using (_⊔_) +open import Relation.Nullary.Negation using (¬_) -open Setoid S renaming (Carrier to A) +open Setoid S renaming (Carrier to A) ------------------------------------------------------------------------- --- Definitions +------------------------------------------------------------------------ +-- Definitions -infix 4 _⊆_ _⊇_ _⊈_ _⊉_ +infix 4 _⊆_ _⊇_ _⊈_ _⊉_ -_⊆_ : Rel (List A) (c ⊔ ℓ) -xs ⊆ ys = ∀ {x} → x ∈ xs → x ∈ ys +_⊆_ : Rel (List A) (c ⊔ ℓ) +xs ⊆ ys = ∀ {x} → x ∈ xs → x ∈ ys -_⊇_ : Rel (List A) (c ⊔ ℓ) -_⊇_ = flip _⊆_ +_⊇_ : Rel (List A) (c ⊔ ℓ) +_⊇_ = flip _⊆_ -_⊈_ : Rel (List A) (c ⊔ ℓ) -xs ⊈ ys = ¬ xs ⊆ ys +_⊈_ : Rel (List A) (c ⊔ ℓ) +xs ⊈ ys = ¬ xs ⊆ ys -_⊉_ : Rel (List A) (c ⊔ ℓ) -xs ⊉ ys = ¬ xs ⊇ ys +_⊉_ : Rel (List A) (c ⊔ ℓ) +xs ⊉ ys = ¬ xs ⊇ ys \ No newline at end of file diff --git a/Data.List.Relation.Unary.All.Properties.html b/Data.List.Relation.Unary.All.Properties.html index f90e2517..6ac37e83 100644 --- a/Data.List.Relation.Unary.All.Properties.html +++ b/Data.List.Relation.Unary.All.Properties.html @@ -10,769 +10,777 @@ module Data.List.Relation.Unary.All.Properties where open import Axiom.Extensionality.Propositional using (Extensionality) -open import Data.Bool.Base using (Bool; T; true; false) -open import Data.Bool.Properties using (T-∧) +open import Data.Bool.Base using (Bool; T; true; false) +open import Data.Bool.Properties using (T-∧) open import Data.Empty -open import Data.Fin.Base using (Fin; zero; suc) -open import Data.List.Base as List hiding (lookup) -open import Data.List.Properties as Listₚ using (partition-defn) -open import Data.List.Membership.Propositional -open import Data.List.Membership.Propositional.Properties -import Data.List.Membership.Setoid as SetoidMembership -open import Data.List.Relation.Unary.All as All using - ( All; []; _∷_; lookup; updateAt - ; _[_]=_; here; there - ; Null - ) -open import Data.List.Relation.Unary.Any as Any using (Any; here; there) -import Data.List.Relation.Binary.Equality.Setoid as ListEq using (_≋_; []; _∷_) -open import Data.List.Relation.Binary.Pointwise using (Pointwise; []; _∷_) -open import Data.List.Relation.Binary.Subset.Propositional using (_⊆_) -open import Data.Maybe.Base as Maybe using (Maybe; just; nothing) -open import Data.Maybe.Relation.Unary.All as Maybe using (just; nothing) -open import Data.Nat.Base using (zero; suc; s≤s; _<_; z<s; s<s) -open import Data.Nat.Properties using (≤-refl; m≤n⇒m≤1+n) -open import Data.Product as Prod using (_×_; _,_; uncurry; uncurry′) -open import Function.Base -open import Function.Equality using (_⟨$⟩_) -open import Function.Equivalence using (_⇔_; equivalence; Equivalence) -open import Function.Inverse using (_↔_; inverse) -open import Function.Surjection using (_↠_; surjection) -open import Level using (Level) -open import Relation.Binary as B using (REL; Setoid; _Respects_) -open import Relation.Binary.PropositionalEquality - using (_≡_; refl; cong; cong₂; _≗_) -open import Relation.Nullary -open import Relation.Nullary.Reflects using (invert) -open import Relation.Nullary.Negation using (contradiction) -open import Relation.Nullary.Decidable using (¬?; decidable-stable) -open import Relation.Unary - using (Decidable; Pred; Universal; ∁; _∩_; _⟨×⟩_) renaming (_⊆_ to _⋐_) -open import Relation.Unary.Properties using (∁?) - -private - variable - a b c p q r ℓ ℓ₁ ℓ₂ : Level - A : Set a - B : Set b - C : Set c - P : Pred A p - Q : Pred B q - R : Pred C r - x y : A - xs ys : List A - ------------------------------------------------------------------------- --- Properties regarding Null - -Null⇒null : Null xs → T (null xs) -Null⇒null [] = _ - -null⇒Null : T (null xs) → Null xs -null⇒Null {xs = [] } _ = [] -null⇒Null {xs = _ ∷ _} () - ------------------------------------------------------------------------- --- Properties of the "points-to" relation _[_]=_ - --- Relation _[_]=_ is deterministic: each index points to a single value. - -[]=-injective : ∀ {px qx : P x} {pxs : All P xs} {i : x ∈ xs} → - pxs [ i ]= px → - pxs [ i ]= qx → - px ≡ qx -[]=-injective here here = refl -[]=-injective (there x↦px) (there x↦qx) = []=-injective x↦px x↦qx - --- See also Data.List.Relation.Unary.All.Properties.WithK.[]=-irrelevant. - ------------------------------------------------------------------------- --- Lemmas relating Any, All and negation. - -¬Any⇒All¬ : ∀ xs → ¬ Any P xs → All (¬_ ∘ P) xs -¬Any⇒All¬ [] ¬p = [] -¬Any⇒All¬ (x ∷ xs) ¬p = ¬p ∘ here ∷ ¬Any⇒All¬ xs (¬p ∘ there) - -All¬⇒¬Any : ∀ {xs} → All (¬_ ∘ P) xs → ¬ Any P xs -All¬⇒¬Any (¬p ∷ _) (here p) = ¬p p -All¬⇒¬Any (_ ∷ ¬p) (there p) = All¬⇒¬Any ¬p p - -¬All⇒Any¬ : Decidable P → ∀ xs → ¬ All P xs → Any (¬_ ∘ P) xs -¬All⇒Any¬ dec [] ¬∀ = ⊥-elim (¬∀ []) -¬All⇒Any¬ dec (x ∷ xs) ¬∀ with dec x -... | true because [p] = there (¬All⇒Any¬ dec xs (¬∀ ∘ _∷_ (invert [p]))) -... | false because [¬p] = here (invert [¬p]) - -Any¬⇒¬All : ∀ {xs} → Any (¬_ ∘ P) xs → ¬ All P xs -Any¬⇒¬All (here ¬p) = ¬p ∘ All.head -Any¬⇒¬All (there ¬p) = Any¬⇒¬All ¬p ∘ All.tail - -¬Any↠All¬ : ∀ {xs} → (¬ Any P xs) ↠ All (¬_ ∘ P) xs -¬Any↠All¬ = surjection (¬Any⇒All¬ _) All¬⇒¬Any to∘from - where - to∘from : ∀ {xs} (¬p : All (¬_ ∘ P) xs) → ¬Any⇒All¬ xs (All¬⇒¬Any ¬p) ≡ ¬p - to∘from [] = refl - to∘from (¬p ∷ ¬ps) = cong₂ _∷_ refl (to∘from ¬ps) - - -- If equality of functions were extensional, then the surjection - -- could be strengthened to a bijection. - - from∘to : Extensionality _ _ → - ∀ xs → (¬p : ¬ Any P xs) → All¬⇒¬Any (¬Any⇒All¬ xs ¬p) ≡ ¬p - from∘to ext [] ¬p = ext λ () - from∘to ext (x ∷ xs) ¬p = ext λ - { (here p) → refl - ; (there p) → cong (λ f → f p) $ from∘to ext xs (¬p ∘ there) - } - -Any¬⇔¬All : ∀ {xs} → Decidable P → Any (¬_ ∘ P) xs ⇔ (¬ All P xs) -Any¬⇔¬All dec = equivalence Any¬⇒¬All (¬All⇒Any¬ dec _) - -private - -- If equality of functions were extensional, then the logical - -- equivalence could be strengthened to a surjection. - to∘from : Extensionality _ _ → (dec : Decidable P) → - (¬∀ : ¬ All P xs) → Any¬⇒¬All (¬All⇒Any¬ dec xs ¬∀) ≡ ¬∀ - to∘from ext P ¬∀ = ext (⊥-elim ∘ ¬∀) - -module _ {_~_ : REL A B ℓ} where - - All-swap : ∀ {xs ys} → - All (λ x → All (x ~_) ys) xs → - All (λ y → All (_~ y) xs) ys - All-swap {ys = []} _ = [] - All-swap {ys = y ∷ ys} [] = All.universal (λ _ → []) (y ∷ ys) - All-swap {ys = y ∷ ys} ((x~y ∷ x~ys) ∷ pxs) = - (x~y ∷ (All.map All.head pxs)) ∷ - All-swap (x~ys ∷ (All.map All.tail pxs)) - ------------------------------------------------------------------------- --- Defining properties of lookup and _[_]=_ --- --- pxs [ i ]= px if and only if lookup pxs i = px. - --- `i` points to `lookup pxs i` in `pxs`. - -[]=lookup : (pxs : All P xs) (i : x ∈ xs) → - pxs [ i ]= lookup pxs i -[]=lookup (px ∷ pxs) (here refl) = here -[]=lookup (px ∷ pxs) (there i) = there ([]=lookup pxs i) - --- If `i` points to `px` in `pxs`, then `lookup pxs i ≡ px`. - -[]=⇒lookup : ∀ {px : P x} {pxs : All P xs} {i : x ∈ xs} → - pxs [ i ]= px → - lookup pxs i ≡ px -[]=⇒lookup x↦px = []=-injective ([]=lookup _ _) x↦px - --- If `lookup pxs i ≡ px`, then `i` points to `px` in `pxs`. - -lookup⇒[]= : ∀ {px : P x} (pxs : All P xs) (i : x ∈ xs) → - lookup pxs i ≡ px → - pxs [ i ]= px -lookup⇒[]= pxs i refl = []=lookup pxs i - ------------------------------------------------------------------------- --- Properties of operations over `All` ------------------------------------------------------------------------- --- map - -map-id : ∀ (pxs : All P xs) → All.map id pxs ≡ pxs -map-id [] = refl -map-id (px ∷ pxs) = cong (px ∷_) (map-id pxs) - -map-cong : ∀ {f : P ⋐ Q} {g : P ⋐ Q} (pxs : All P xs) → - (∀ {x} → f {x} ≗ g) → All.map f pxs ≡ All.map g pxs -map-cong [] _ = refl -map-cong (px ∷ pxs) feq = cong₂ _∷_ (feq px) (map-cong pxs feq) - -map-compose : ∀ {f : P ⋐ Q} {g : Q ⋐ R} (pxs : All P xs) → - All.map g (All.map f pxs) ≡ All.map (g ∘ f) pxs -map-compose [] = refl -map-compose (px ∷ pxs) = cong (_ ∷_) (map-compose pxs) - -lookup-map : ∀ {f : P ⋐ Q} (pxs : All P xs) (i : x ∈ xs) → - lookup (All.map f pxs) i ≡ f (lookup pxs i) -lookup-map (px ∷ pxs) (here refl) = refl -lookup-map (px ∷ pxs) (there i) = lookup-map pxs i - ------------------------------------------------------------------------- --- _[_]%=_ / updateAt - - -- Defining properties of updateAt: - --- (+) updateAt actually updates the element at the given index. - -updateAt-updates : ∀ (i : x ∈ xs) {f : P x → P x} {px : P x} (pxs : All P xs) → - pxs [ i ]= px → - updateAt i f pxs [ i ]= f px -updateAt-updates (here refl) (px ∷ pxs) here = here -updateAt-updates (there i) (px ∷ pxs) (there x↦px) = - there (updateAt-updates i pxs x↦px) - --- (-) updateAt i does not touch the elements at other indices. - -updateAt-minimal : ∀ (i : x ∈ xs) (j : y ∈ xs) → - ∀ {f : P y → P y} {px : P x} (pxs : All P xs) → - i ≢∈ j → - pxs [ i ]= px → - updateAt j f pxs [ i ]= px -updateAt-minimal (here .refl) (here refl) (px ∷ pxs) i≢j here = - ⊥-elim (i≢j refl refl) -updateAt-minimal (here .refl) (there j) (px ∷ pxs) i≢j here = here -updateAt-minimal (there i) (here refl) (px ∷ pxs) i≢j (there val) = there val -updateAt-minimal (there i) (there j) (px ∷ pxs) i≢j (there val) = - there (updateAt-minimal i j pxs (there-injective-≢∈ i≢j) val) - --- lookup after updateAt reduces. - --- For same index this is an easy consequence of updateAt-updates --- using []=↔lookup. - -lookup∘updateAt : ∀ (pxs : All P xs) (i : x ∈ xs) {f : P x → P x} → - lookup (updateAt i f pxs) i ≡ f (lookup pxs i) -lookup∘updateAt pxs i = - []=⇒lookup (updateAt-updates i pxs (lookup⇒[]= pxs i refl)) - --- For different indices it easily follows from updateAt-minimal. - -lookup∘updateAt′ : ∀ (i : x ∈ xs) (j : y ∈ xs) → - ∀ {f : P y → P y} {px : P x} (pxs : All P xs) → - i ≢∈ j → - lookup (updateAt j f pxs) i ≡ lookup pxs i -lookup∘updateAt′ i j pxs i≢j = - []=⇒lookup (updateAt-minimal i j pxs i≢j (lookup⇒[]= pxs i refl)) - --- The other properties are consequences of (+) and (-). --- We spell the most natural properties out. --- Direct inductive proofs are in most cases easier than just using --- the defining properties. +open import Data.Fin.Base using (Fin; zero; suc) +open import Data.List.Base as List hiding (lookup; updateAt) +open import Data.List.Properties as Listₚ using (partition-defn) +open import Data.List.Membership.Propositional +open import Data.List.Membership.Propositional.Properties +import Data.List.Membership.Setoid as SetoidMembership +open import Data.List.Relation.Unary.All as All using + ( All; []; _∷_; lookup; updateAt + ; _[_]=_; here; there + ; Null + ) +open import Data.List.Relation.Unary.Any as Any using (Any; here; there) +import Data.List.Relation.Binary.Equality.Setoid as ListEq using (_≋_; []; _∷_) +open import Data.List.Relation.Binary.Pointwise.Base using (Pointwise; []; _∷_) +open import Data.List.Relation.Binary.Subset.Propositional using (_⊆_) +open import Data.Maybe.Base as Maybe using (Maybe; just; nothing) +open import Data.Maybe.Relation.Unary.All as Maybe using (just; nothing) +open import Data.Nat.Base using (zero; suc; s≤s; _<_; z<s; s<s) +open import Data.Nat.Properties using (≤-refl; m≤n⇒m≤1+n) +open import Data.Product.Base as Prod using (_×_; _,_; uncurry; uncurry′) +open import Function.Base +open import Function.Bundles +open import Level using (Level) +open import Relation.Binary.Core using (REL) +open import Relation.Binary.Bundles using (Setoid) +import Relation.Binary.Definitions as B +open import Relation.Binary.PropositionalEquality + using (_≡_; refl; cong; cong₂; _≗_) +open import Relation.Nullary +open import Relation.Nullary.Reflects using (invert) +open import Relation.Nullary.Negation using (contradiction) +open import Relation.Nullary.Decidable using (¬?; decidable-stable) +open import Relation.Unary + using (Decidable; Pred; Universal; ∁; _∩_; _⟨×⟩_) renaming (_⊆_ to _⋐_) +open import Relation.Unary.Properties using (∁?) + +private + variable + a b c p q r ℓ ℓ₁ ℓ₂ : Level + A : Set a + B : Set b + C : Set c + P : Pred A p + Q : Pred B q + R : Pred C r + x y : A + xs ys : List A + +------------------------------------------------------------------------ +-- Properties regarding Null + +Null⇒null : Null xs → T (null xs) +Null⇒null [] = _ + +null⇒Null : T (null xs) → Null xs +null⇒Null {xs = [] } _ = [] +null⇒Null {xs = _ ∷ _} () + +------------------------------------------------------------------------ +-- Properties of the "points-to" relation _[_]=_ + +-- Relation _[_]=_ is deterministic: each index points to a single value. + +[]=-injective : ∀ {px qx : P x} {pxs : All P xs} {i : x ∈ xs} → + pxs [ i ]= px → + pxs [ i ]= qx → + px ≡ qx +[]=-injective here here = refl +[]=-injective (there x↦px) (there x↦qx) = []=-injective x↦px x↦qx + +-- See also Data.List.Relation.Unary.All.Properties.WithK.[]=-irrelevant. + +------------------------------------------------------------------------ +-- Lemmas relating Any, All and negation. + +¬Any⇒All¬ : ∀ xs → ¬ Any P xs → All (¬_ ∘ P) xs +¬Any⇒All¬ [] ¬p = [] +¬Any⇒All¬ (x ∷ xs) ¬p = ¬p ∘ here ∷ ¬Any⇒All¬ xs (¬p ∘ there) + +All¬⇒¬Any : ∀ {xs} → All (¬_ ∘ P) xs → ¬ Any P xs +All¬⇒¬Any (¬p ∷ _) (here p) = ¬p p +All¬⇒¬Any (_ ∷ ¬p) (there p) = All¬⇒¬Any ¬p p + +¬All⇒Any¬ : Decidable P → ∀ xs → ¬ All P xs → Any (¬_ ∘ P) xs +¬All⇒Any¬ dec [] ¬∀ = ⊥-elim (¬∀ []) +¬All⇒Any¬ dec (x ∷ xs) ¬∀ with dec x +... | true because [p] = there (¬All⇒Any¬ dec xs (¬∀ ∘ _∷_ (invert [p]))) +... | false because [¬p] = here (invert [¬p]) + +Any¬⇒¬All : ∀ {xs} → Any (¬_ ∘ P) xs → ¬ All P xs +Any¬⇒¬All (here ¬p) = ¬p ∘ All.head +Any¬⇒¬All (there ¬p) = Any¬⇒¬All ¬p ∘ All.tail + +¬Any↠All¬ : ∀ {xs} → (¬ Any P xs) ↠ All (¬_ ∘ P) xs +¬Any↠All¬ = mk↠ₛ {to = ¬Any⇒All¬ _} (λ y → All¬⇒¬Any y , to∘from y) + where + to∘from : ∀ {xs} (¬p : All (¬_ ∘ P) xs) → ¬Any⇒All¬ xs (All¬⇒¬Any ¬p) ≡ ¬p + to∘from [] = refl + to∘from (¬p ∷ ¬ps) = cong₂ _∷_ refl (to∘from ¬ps) + + -- If equality of functions were extensional, then the surjection + -- could be strengthened to a bijection. + + from∘to : Extensionality _ _ → + ∀ xs → (¬p : ¬ Any P xs) → All¬⇒¬Any (¬Any⇒All¬ xs ¬p) ≡ ¬p + from∘to ext [] ¬p = ext λ () + from∘to ext (x ∷ xs) ¬p = ext λ + { (here p) → refl + ; (there p) → cong (λ f → f p) $ from∘to ext xs (¬p ∘ there) + } + +Any¬⇔¬All : ∀ {xs} → Decidable P → Any (¬_ ∘ P) xs ⇔ (¬ All P xs) +Any¬⇔¬All dec = mk⇔ Any¬⇒¬All (¬All⇒Any¬ dec _) + +private + -- If equality of functions were extensional, then the logical + -- equivalence could be strengthened to a surjection. + to∘from : Extensionality _ _ → (dec : Decidable P) → + (¬∀ : ¬ All P xs) → Any¬⇒¬All (¬All⇒Any¬ dec xs ¬∀) ≡ ¬∀ + to∘from ext P ¬∀ = ext (⊥-elim ∘ ¬∀) + +module _ {_~_ : REL A B ℓ} where + + All-swap : ∀ {xs ys} → + All (λ x → All (x ~_) ys) xs → + All (λ y → All (_~ y) xs) ys + All-swap {ys = []} _ = [] + All-swap {ys = y ∷ ys} [] = All.universal (λ _ → []) (y ∷ ys) + All-swap {ys = y ∷ ys} ((x~y ∷ x~ys) ∷ pxs) = + (x~y ∷ (All.map All.head pxs)) ∷ + All-swap (x~ys ∷ (All.map All.tail pxs)) + +------------------------------------------------------------------------ +-- Defining properties of lookup and _[_]=_ +-- +-- pxs [ i ]= px if and only if lookup pxs i = px. + +-- `i` points to `lookup pxs i` in `pxs`. + +[]=lookup : (pxs : All P xs) (i : x ∈ xs) → + pxs [ i ]= lookup pxs i +[]=lookup (px ∷ pxs) (here refl) = here +[]=lookup (px ∷ pxs) (there i) = there ([]=lookup pxs i) + +-- If `i` points to `px` in `pxs`, then `lookup pxs i ≡ px`. + +[]=⇒lookup : ∀ {px : P x} {pxs : All P xs} {i : x ∈ xs} → + pxs [ i ]= px → + lookup pxs i ≡ px +[]=⇒lookup x↦px = []=-injective ([]=lookup _ _) x↦px + +-- If `lookup pxs i ≡ px`, then `i` points to `px` in `pxs`. + +lookup⇒[]= : ∀ {px : P x} (pxs : All P xs) (i : x ∈ xs) → + lookup pxs i ≡ px → + pxs [ i ]= px +lookup⇒[]= pxs i refl = []=lookup pxs i + +------------------------------------------------------------------------ +-- Properties of operations over `All` +------------------------------------------------------------------------ +-- map + +map-id : ∀ (pxs : All P xs) → All.map id pxs ≡ pxs +map-id [] = refl +map-id (px ∷ pxs) = cong (px ∷_) (map-id pxs) + +map-cong : ∀ {f : P ⋐ Q} {g : P ⋐ Q} (pxs : All P xs) → + (∀ {x} → f {x} ≗ g) → All.map f pxs ≡ All.map g pxs +map-cong [] _ = refl +map-cong (px ∷ pxs) feq = cong₂ _∷_ (feq px) (map-cong pxs feq) + +map-compose : ∀ {f : P ⋐ Q} {g : Q ⋐ R} (pxs : All P xs) → + All.map g (All.map f pxs) ≡ All.map (g ∘ f) pxs +map-compose [] = refl +map-compose (px ∷ pxs) = cong (_ ∷_) (map-compose pxs) + +lookup-map : ∀ {f : P ⋐ Q} (pxs : All P xs) (i : x ∈ xs) → + lookup (All.map f pxs) i ≡ f (lookup pxs i) +lookup-map (px ∷ pxs) (here refl) = refl +lookup-map (px ∷ pxs) (there i) = lookup-map pxs i + +------------------------------------------------------------------------ +-- _[_]%=_ / updateAt + + -- Defining properties of updateAt: + +-- (+) updateAt actually updates the element at the given index. + +updateAt-updates : ∀ (i : x ∈ xs) {f : P x → P x} {px : P x} (pxs : All P xs) → + pxs [ i ]= px → + updateAt i f pxs [ i ]= f px +updateAt-updates (here refl) (px ∷ pxs) here = here +updateAt-updates (there i) (px ∷ pxs) (there x↦px) = + there (updateAt-updates i pxs x↦px) + +-- (-) updateAt i does not touch the elements at other indices. + +updateAt-minimal : ∀ (i : x ∈ xs) (j : y ∈ xs) → + ∀ {f : P y → P y} {px : P x} (pxs : All P xs) → + i ≢∈ j → + pxs [ i ]= px → + updateAt j f pxs [ i ]= px +updateAt-minimal (here .refl) (here refl) (px ∷ pxs) i≢j here = + ⊥-elim (i≢j refl refl) +updateAt-minimal (here .refl) (there j) (px ∷ pxs) i≢j here = here +updateAt-minimal (there i) (here refl) (px ∷ pxs) i≢j (there val) = there val +updateAt-minimal (there i) (there j) (px ∷ pxs) i≢j (there val) = + there (updateAt-minimal i j pxs (there-injective-≢∈ i≢j) val) + +-- lookup after updateAt reduces. + +-- For same index this is an easy consequence of updateAt-updates +-- using []=↔lookup. + +lookup∘updateAt : ∀ (pxs : All P xs) (i : x ∈ xs) {f : P x → P x} → + lookup (updateAt i f pxs) i ≡ f (lookup pxs i) +lookup∘updateAt pxs i = + []=⇒lookup (updateAt-updates i pxs (lookup⇒[]= pxs i refl)) + +-- For different indices it easily follows from updateAt-minimal. + +lookup∘updateAt′ : ∀ (i : x ∈ xs) (j : y ∈ xs) → + ∀ {f : P y → P y} {px : P x} (pxs : All P xs) → + i ≢∈ j → + lookup (updateAt j f pxs) i ≡ lookup pxs i +lookup∘updateAt′ i j pxs i≢j = + []=⇒lookup (updateAt-minimal i j pxs i≢j (lookup⇒[]= pxs i refl)) + +-- The other properties are consequences of (+) and (-). +-- We spell the most natural properties out. +-- Direct inductive proofs are in most cases easier than just using +-- the defining properties. --- In the explanations, we make use of shorthand f = g ↾ x --- meaning that f and g agree locally at point x, i.e. f x ≡ g x. +-- In the explanations, we make use of shorthand f = g ↾ x +-- meaning that f and g agree locally at point x, i.e. f x ≡ g x. --- updateAt (i : x ∈ xs) is a morphism --- from the monoid of endofunctions P x → P x --- to the monoid of endofunctions All P xs → All P xs. +-- updateAt (i : x ∈ xs) is a morphism +-- from the monoid of endofunctions P x → P x +-- to the monoid of endofunctions All P xs → All P xs. --- 1a. local identity: f = id ↾ (lookup pxs i) --- implies updateAt i f = id ↾ pxs +-- 1a. local identity: f = id ↾ (lookup pxs i) +-- implies updateAt i f = id ↾ pxs -updateAt-id-local : ∀ (i : x ∈ xs) {f : P x → P x} (pxs : All P xs) → - f (lookup pxs i) ≡ lookup pxs i → - updateAt i f pxs ≡ pxs -updateAt-id-local (here refl)(px ∷ pxs) eq = cong (_∷ pxs) eq -updateAt-id-local (there i) (px ∷ pxs) eq = cong (px ∷_) (updateAt-id-local i pxs eq) +updateAt-id-local : ∀ (i : x ∈ xs) {f : P x → P x} (pxs : All P xs) → + f (lookup pxs i) ≡ lookup pxs i → + updateAt i f pxs ≡ pxs +updateAt-id-local (here refl)(px ∷ pxs) eq = cong (_∷ pxs) eq +updateAt-id-local (there i) (px ∷ pxs) eq = cong (px ∷_) (updateAt-id-local i pxs eq) --- 1b. identity: updateAt i id ≗ id +-- 1b. identity: updateAt i id ≗ id -updateAt-id : ∀ (i : x ∈ xs) (pxs : All P xs) → updateAt i id pxs ≡ pxs -updateAt-id i pxs = updateAt-id-local i pxs refl +updateAt-id : ∀ (i : x ∈ xs) (pxs : All P xs) → updateAt i id pxs ≡ pxs +updateAt-id i pxs = updateAt-id-local i pxs refl --- 2a. relative composition: f ∘ g = h ↾ (lookup i pxs) --- implies updateAt i f ∘ updateAt i g = updateAt i h ↾ pxs +-- 2a. relative composition: f ∘ g = h ↾ (lookup i pxs) +-- implies updateAt i f ∘ updateAt i g = updateAt i h ↾ pxs -updateAt-∘-local : ∀ (i : x ∈ xs) {f g h : P x → P x} (pxs : All P xs) → - f (g (lookup pxs i)) ≡ h (lookup pxs i) → - updateAt i f (updateAt i g pxs) ≡ updateAt i h pxs -updateAt-∘-local (here refl) (px ∷ pxs) fg=h = cong (_∷ pxs) fg=h -updateAt-∘-local (there i) (px ∷ pxs) fg=h = cong (px ∷_) (updateAt-∘-local i pxs fg=h) +updateAt-∘-local : ∀ (i : x ∈ xs) {f g h : P x → P x} (pxs : All P xs) → + f (g (lookup pxs i)) ≡ h (lookup pxs i) → + updateAt i f (updateAt i g pxs) ≡ updateAt i h pxs +updateAt-∘-local (here refl) (px ∷ pxs) fg=h = cong (_∷ pxs) fg=h +updateAt-∘-local (there i) (px ∷ pxs) fg=h = cong (px ∷_) (updateAt-∘-local i pxs fg=h) --- 2b. composition: updateAt i f ∘ updateAt i g ≗ updateAt i (f ∘ g) +-- 2b. composition: updateAt i f ∘ updateAt i g ≗ updateAt i (f ∘ g) -updateAt-∘ : ∀ (i : x ∈ xs) {f g : P x → P x} → - updateAt {P = P} i f ∘ updateAt i g ≗ updateAt i (f ∘ g) -updateAt-∘ i pxs = updateAt-∘-local i pxs refl +updateAt-∘ : ∀ (i : x ∈ xs) {f g : P x → P x} → + updateAt {P = P} i f ∘ updateAt i g ≗ updateAt i (f ∘ g) +updateAt-∘ i pxs = updateAt-∘-local i pxs refl --- 3. congruence: updateAt i is a congruence wrt. extensional equality. +-- 3. congruence: updateAt i is a congruence wrt. extensional equality. --- 3a. If f = g ↾ (lookup pxs i) --- then updateAt i f = updateAt i g ↾ pxs +-- 3a. If f = g ↾ (lookup pxs i) +-- then updateAt i f = updateAt i g ↾ pxs -updateAt-cong-local : ∀ (i : x ∈ xs) {f g : P x → P x} (pxs : All P xs) → - f (lookup pxs i) ≡ g (lookup pxs i) → - updateAt i f pxs ≡ updateAt i g pxs -updateAt-cong-local (here refl) (px ∷ pxs) f=g = cong (_∷ pxs) f=g -updateAt-cong-local (there i) (px ∷ pxs) f=g = cong (px ∷_) (updateAt-cong-local i pxs f=g) +updateAt-cong-local : ∀ (i : x ∈ xs) {f g : P x → P x} (pxs : All P xs) → + f (lookup pxs i) ≡ g (lookup pxs i) → + updateAt i f pxs ≡ updateAt i g pxs +updateAt-cong-local (here refl) (px ∷ pxs) f=g = cong (_∷ pxs) f=g +updateAt-cong-local (there i) (px ∷ pxs) f=g = cong (px ∷_) (updateAt-cong-local i pxs f=g) --- 3b. congruence: f ≗ g → updateAt i f ≗ updateAt i g +-- 3b. congruence: f ≗ g → updateAt i f ≗ updateAt i g -updateAt-cong : ∀ (i : x ∈ xs) {f g : P x → P x} → - f ≗ g → updateAt {P = P} i f ≗ updateAt i g -updateAt-cong i f≗g pxs = updateAt-cong-local i pxs (f≗g (lookup pxs i)) +updateAt-cong : ∀ (i : x ∈ xs) {f g : P x → P x} → + f ≗ g → updateAt {P = P} i f ≗ updateAt i g +updateAt-cong i f≗g pxs = updateAt-cong-local i pxs (f≗g (lookup pxs i)) --- The order of updates at different indices i ≢ j does not matter. +-- The order of updates at different indices i ≢ j does not matter. --- This a consequence of updateAt-updates and updateAt-minimal --- but easier to prove inductively. +-- This a consequence of updateAt-updates and updateAt-minimal +-- but easier to prove inductively. -updateAt-commutes : ∀ (i : x ∈ xs) (j : y ∈ xs) → - ∀ {f : P x → P x} {g : P y → P y} → - i ≢∈ j → - updateAt {P = P} i f ∘ updateAt j g ≗ updateAt j g ∘ updateAt i f -updateAt-commutes (here refl) (here refl) i≢j (px ∷ pxs) = - ⊥-elim (i≢j refl refl) -updateAt-commutes (here refl) (there j) i≢j (px ∷ pxs) = refl -updateAt-commutes (there i) (here refl) i≢j (px ∷ pxs) = refl -updateAt-commutes (there i) (there j) i≢j (px ∷ pxs) = - cong (px ∷_) (updateAt-commutes i j (there-injective-≢∈ i≢j) pxs) +updateAt-commutes : ∀ (i : x ∈ xs) (j : y ∈ xs) → + ∀ {f : P x → P x} {g : P y → P y} → + i ≢∈ j → + updateAt {P = P} i f ∘ updateAt j g ≗ updateAt j g ∘ updateAt i f +updateAt-commutes (here refl) (here refl) i≢j (px ∷ pxs) = + ⊥-elim (i≢j refl refl) +updateAt-commutes (here refl) (there j) i≢j (px ∷ pxs) = refl +updateAt-commutes (there i) (here refl) i≢j (px ∷ pxs) = refl +updateAt-commutes (there i) (there j) i≢j (px ∷ pxs) = + cong (px ∷_) (updateAt-commutes i j (there-injective-≢∈ i≢j) pxs) -map-updateAt : ∀ {f : P ⋐ Q} {g : P x → P x} {h : Q x → Q x} - (pxs : All P xs) (i : x ∈ xs) → - f (g (lookup pxs i)) ≡ h (f (lookup pxs i)) → - All.map f (pxs All.[ i ]%= g) ≡ (All.map f pxs) All.[ i ]%= h -map-updateAt (px ∷ pxs) (here refl) = cong (_∷ _) -map-updateAt (px ∷ pxs) (there i) feq = cong (_ ∷_) (map-updateAt pxs i feq) +map-updateAt : ∀ {f : P ⋐ Q} {g : P x → P x} {h : Q x → Q x} + (pxs : All P xs) (i : x ∈ xs) → + f (g (lookup pxs i)) ≡ h (f (lookup pxs i)) → + All.map f (pxs All.[ i ]%= g) ≡ (All.map f pxs) All.[ i ]%= h +map-updateAt (px ∷ pxs) (here refl) = cong (_∷ _) +map-updateAt (px ∷ pxs) (there i) feq = cong (_ ∷_) (map-updateAt pxs i feq) ------------------------------------------------------------------------- --- Introduction (⁺) and elimination (⁻) rules for list operations ------------------------------------------------------------------------- --- singleton +------------------------------------------------------------------------ +-- Introduction (⁺) and elimination (⁻) rules for list operations +------------------------------------------------------------------------ +-- singleton -singleton⁻ : All P [ x ] → P x -singleton⁻ (px ∷ []) = px +singleton⁻ : All P [ x ] → P x +singleton⁻ (px ∷ []) = px --- head +-- head -head⁺ : All P xs → Maybe.All P (head xs) -head⁺ [] = nothing -head⁺ (px ∷ _) = just px +head⁺ : All P xs → Maybe.All P (head xs) +head⁺ [] = nothing +head⁺ (px ∷ _) = just px --- tail +-- tail -tail⁺ : All P xs → Maybe.All (All P) (tail xs) -tail⁺ [] = nothing -tail⁺ (_ ∷ pxs) = just pxs +tail⁺ : All P xs → Maybe.All (All P) (tail xs) +tail⁺ [] = nothing +tail⁺ (_ ∷ pxs) = just pxs --- last +-- last -last⁺ : All P xs → Maybe.All P (last xs) -last⁺ [] = nothing -last⁺ (px ∷ []) = just px -last⁺ (px ∷ pxs@(_ ∷ _)) = last⁺ pxs +last⁺ : All P xs → Maybe.All P (last xs) +last⁺ [] = nothing +last⁺ (px ∷ []) = just px +last⁺ (px ∷ pxs@(_ ∷ _)) = last⁺ pxs --- uncons +-- uncons -uncons⁺ : All P xs → Maybe.All (P ⟨×⟩ All P) (uncons xs) -uncons⁺ [] = nothing -uncons⁺ (px ∷ pxs) = just (px , pxs) +uncons⁺ : All P xs → Maybe.All (P ⟨×⟩ All P) (uncons xs) +uncons⁺ [] = nothing +uncons⁺ (px ∷ pxs) = just (px , pxs) -uncons⁻ : Maybe.All (P ⟨×⟩ All P) (uncons xs) → All P xs -uncons⁻ {xs = []} nothing = [] -uncons⁻ {xs = x ∷ xs} (just (px , pxs)) = px ∷ pxs +uncons⁻ : Maybe.All (P ⟨×⟩ All P) (uncons xs) → All P xs +uncons⁻ {xs = []} nothing = [] +uncons⁻ {xs = x ∷ xs} (just (px , pxs)) = px ∷ pxs --- map +-- map -map⁺ : ∀ {f : A → B} → All (P ∘ f) xs → All P (map f xs) -map⁺ [] = [] -map⁺ (p ∷ ps) = p ∷ map⁺ ps +map⁺ : ∀ {f : A → B} → All (P ∘ f) xs → All P (map f xs) +map⁺ [] = [] +map⁺ (p ∷ ps) = p ∷ map⁺ ps -map⁻ : ∀ {f : A → B} → All P (map f xs) → All (P ∘ f) xs -map⁻ {xs = []} [] = [] -map⁻ {xs = _ ∷ _} (p ∷ ps) = p ∷ map⁻ ps +map⁻ : ∀ {f : A → B} → All P (map f xs) → All (P ∘ f) xs +map⁻ {xs = []} [] = [] +map⁻ {xs = _ ∷ _} (p ∷ ps) = p ∷ map⁻ ps --- A variant of All.map. +-- A variant of All.map. -gmap : ∀ {f : A → B} → P ⋐ Q ∘ f → All P ⋐ All Q ∘ map f -gmap g = map⁺ ∘ All.map g +gmap⁺ : ∀ {f : A → B} → P ⋐ Q ∘ f → All P ⋐ All Q ∘ map f +gmap⁺ g = map⁺ ∘ All.map g ------------------------------------------------------------------------- --- mapMaybe +gmap⁻ : ∀ {f : A → B} → Q ∘ f ⋐ P → All Q ∘ map f ⋐ All P +gmap⁻ g = All.map g ∘ map⁻ -mapMaybe⁺ : ∀ {f : A → Maybe B} → - All (Maybe.All P) (map f xs) → All P (mapMaybe f xs) -mapMaybe⁺ {xs = []} {f = f} [] = [] -mapMaybe⁺ {xs = x ∷ xs} {f = f} (px ∷ pxs) with f x -... | nothing = mapMaybe⁺ pxs -... | just v with px -... | just pv = pv ∷ mapMaybe⁺ pxs - ------------------------------------------------------------------------- --- _++_ - -++⁺ : All P xs → All P ys → All P (xs ++ ys) -++⁺ [] pys = pys -++⁺ (px ∷ pxs) pys = px ∷ ++⁺ pxs pys - -++⁻ˡ : ∀ xs {ys} → All P (xs ++ ys) → All P xs -++⁻ˡ [] p = [] -++⁻ˡ (x ∷ xs) (px ∷ pxs) = px ∷ (++⁻ˡ _ pxs) - -++⁻ʳ : ∀ xs {ys} → All P (xs ++ ys) → All P ys -++⁻ʳ [] p = p -++⁻ʳ (x ∷ xs) (px ∷ pxs) = ++⁻ʳ xs pxs - -++⁻ : ∀ xs {ys} → All P (xs ++ ys) → All P xs × All P ys -++⁻ [] p = [] , p -++⁻ (x ∷ xs) (px ∷ pxs) = Prod.map (px ∷_) id (++⁻ _ pxs) - -++↔ : (All P xs × All P ys) ↔ All P (xs ++ ys) -++↔ {xs = zs} = inverse (uncurry ++⁺) (++⁻ zs) ++⁻∘++⁺ (++⁺∘++⁻ zs) - where - ++⁺∘++⁻ : ∀ xs (p : All P (xs ++ ys)) → uncurry′ ++⁺ (++⁻ xs p) ≡ p - ++⁺∘++⁻ [] p = refl - ++⁺∘++⁻ (x ∷ xs) (px ∷ pxs) = cong (_∷_ px) $ ++⁺∘++⁻ xs pxs - - ++⁻∘++⁺ : ∀ (p : All P xs × All P ys) → ++⁻ xs (uncurry ++⁺ p) ≡ p - ++⁻∘++⁺ ([] , pys) = refl - ++⁻∘++⁺ (px ∷ pxs , pys) rewrite ++⁻∘++⁺ (pxs , pys) = refl - ------------------------------------------------------------------------- --- concat - -concat⁺ : ∀ {xss} → All (All P) xss → All P (concat xss) -concat⁺ [] = [] -concat⁺ (pxs ∷ pxss) = ++⁺ pxs (concat⁺ pxss) - -concat⁻ : ∀ {xss} → All P (concat xss) → All (All P) xss -concat⁻ {xss = []} [] = [] -concat⁻ {xss = xs ∷ xss} pxs = ++⁻ˡ xs pxs ∷ concat⁻ (++⁻ʳ xs pxs) - ------------------------------------------------------------------------- --- snoc - -∷ʳ⁺ : All P xs → P x → All P (xs ∷ʳ x) -∷ʳ⁺ pxs px = ++⁺ pxs (px ∷ []) - -∷ʳ⁻ : All P (xs ∷ʳ x) → All P xs × P x -∷ʳ⁻ pxs = Prod.map₂ singleton⁻ $ ++⁻ _ pxs - --- unsnoc - -unsnoc⁺ : All P xs → Maybe.All (All P ⟨×⟩ P) (unsnoc xs) -unsnoc⁺ {xs = xs} pxs with initLast xs -unsnoc⁺ {xs = .[]} pxs | [] = nothing -unsnoc⁺ {xs = .(xs ∷ʳ x)} pxs | xs ∷ʳ′ x = just (∷ʳ⁻ pxs) - -unsnoc⁻ : Maybe.All (All P ⟨×⟩ P) (unsnoc xs) → All P xs -unsnoc⁻ {xs = xs} pxs with initLast xs -unsnoc⁻ {xs = .[]} nothing | [] = [] -unsnoc⁻ {xs = .(xs ∷ʳ x)} (just (pxs , px)) | xs ∷ʳ′ x = ∷ʳ⁺ pxs px - ------------------------------------------------------------------------- --- cartesianProductWith and cartesianProduct - -module _ (S₁ : Setoid a ℓ₁) (S₂ : Setoid b ℓ₂) where - open SetoidMembership S₁ using () renaming (_∈_ to _∈₁_) - open SetoidMembership S₂ using () renaming (_∈_ to _∈₂_) - - cartesianProductWith⁺ : ∀ f xs ys → - (∀ {x y} → x ∈₁ xs → y ∈₂ ys → P (f x y)) → - All P (cartesianProductWith f xs ys) - cartesianProductWith⁺ f [] ys pres = [] - cartesianProductWith⁺ f (x ∷ xs) ys pres = ++⁺ - (map⁺ (All.tabulateₛ S₂ (pres (here (Setoid.refl S₁))))) - (cartesianProductWith⁺ f xs ys (pres ∘ there)) - - cartesianProduct⁺ : ∀ xs ys → - (∀ {x y} → x ∈₁ xs → y ∈₂ ys → P (x , y)) → - All P (cartesianProduct xs ys) - cartesianProduct⁺ = cartesianProductWith⁺ _,_ - ------------------------------------------------------------------------- --- take and drop - -drop⁺ : ∀ n → All P xs → All P (drop n xs) -drop⁺ zero pxs = pxs -drop⁺ (suc n) [] = [] -drop⁺ (suc n) (px ∷ pxs) = drop⁺ n pxs - -dropWhile⁺ : (Q? : Decidable Q) → All P xs → All P (dropWhile Q? xs) -dropWhile⁺ Q? [] = [] -dropWhile⁺ {xs = x ∷ xs} Q? (px ∷ pxs) with does (Q? x) -... | true = dropWhile⁺ Q? pxs -... | false = px ∷ pxs - -dropWhile⁻ : (P? : Decidable P) → dropWhile P? xs ≡ [] → All P xs -dropWhile⁻ {xs = []} P? eq = [] -dropWhile⁻ {xs = x ∷ xs} P? eq with P? x -... | yes px = px ∷ (dropWhile⁻ P? eq) -... | no ¬px = case eq of λ () - -all-head-dropWhile : (P? : Decidable P) → - ∀ xs → Maybe.All (∁ P) (head (dropWhile P? xs)) -all-head-dropWhile P? [] = nothing -all-head-dropWhile P? (x ∷ xs) with P? x -... | yes px = all-head-dropWhile P? xs -... | no ¬px = just ¬px - -take⁺ : ∀ n → All P xs → All P (take n xs) -take⁺ zero pxs = [] -take⁺ (suc n) [] = [] -take⁺ (suc n) (px ∷ pxs) = px ∷ take⁺ n pxs - -takeWhile⁺ : (Q? : Decidable Q) → All P xs → All P (takeWhile Q? xs) -takeWhile⁺ Q? [] = [] -takeWhile⁺ {xs = x ∷ xs} Q? (px ∷ pxs) with does (Q? x) -... | true = px ∷ takeWhile⁺ Q? pxs -... | false = [] - -takeWhile⁻ : (P? : Decidable P) → takeWhile P? xs ≡ xs → All P xs -takeWhile⁻ {xs = []} P? eq = [] -takeWhile⁻ {xs = x ∷ xs} P? eq with P? x -... | yes px = px ∷ takeWhile⁻ P? (Listₚ.∷-injectiveʳ eq) -... | no ¬px = case eq of λ () - -all-takeWhile : (P? : Decidable P) → ∀ xs → All P (takeWhile P? xs) -all-takeWhile P? [] = [] -all-takeWhile P? (x ∷ xs) with P? x -... | yes px = px ∷ all-takeWhile P? xs -... | no ¬px = [] - ------------------------------------------------------------------------- --- applyUpTo - -applyUpTo⁺₁ : ∀ f n → (∀ {i} → i < n → P (f i)) → All P (applyUpTo f n) -applyUpTo⁺₁ f zero Pf = [] -applyUpTo⁺₁ f (suc n) Pf = Pf z<s ∷ applyUpTo⁺₁ (f ∘ suc) n (Pf ∘ s<s) - -applyUpTo⁺₂ : ∀ f n → (∀ i → P (f i)) → All P (applyUpTo f n) -applyUpTo⁺₂ f n Pf = applyUpTo⁺₁ f n (λ _ → Pf _) - -applyUpTo⁻ : ∀ f n → All P (applyUpTo f n) → ∀ {i} → i < n → P (f i) -applyUpTo⁻ f (suc n) (px ∷ _) z<s = px -applyUpTo⁻ f (suc n) (_ ∷ pxs) (s<s i<n@(s≤s _)) = - applyUpTo⁻ (f ∘ suc) n pxs i<n - ------------------------------------------------------------------------- --- upTo - -all-upTo : ∀ n → All (_< n) (upTo n) -all-upTo n = applyUpTo⁺₁ id n id - ------------------------------------------------------------------------- --- applyDownFrom - -applyDownFrom⁺₁ : ∀ f n → (∀ {i} → i < n → P (f i)) → All P (applyDownFrom f n) -applyDownFrom⁺₁ f zero Pf = [] -applyDownFrom⁺₁ f (suc n) Pf = Pf ≤-refl ∷ applyDownFrom⁺₁ f n (Pf ∘ m≤n⇒m≤1+n) - -applyDownFrom⁺₂ : ∀ f n → (∀ i → P (f i)) → All P (applyDownFrom f n) -applyDownFrom⁺₂ f n Pf = applyDownFrom⁺₁ f n (λ _ → Pf _) - ------------------------------------------------------------------------- --- tabulate - -tabulate⁺ : ∀ {n} {f : Fin n → A} → - (∀ i → P (f i)) → All P (tabulate f) -tabulate⁺ {n = zero} Pf = [] -tabulate⁺ {n = suc _} Pf = Pf zero ∷ tabulate⁺ (Pf ∘ suc) - -tabulate⁻ : ∀ {n} {f : Fin n → A} → - All P (tabulate f) → (∀ i → P (f i)) -tabulate⁻ (px ∷ _) zero = px -tabulate⁻ (_ ∷ pf) (suc i) = tabulate⁻ pf i - ------------------------------------------------------------------------- --- remove - -─⁺ : ∀ (p : Any P xs) → All Q xs → All Q (xs Any.─ p) -─⁺ (here px) (_ ∷ qs) = qs -─⁺ (there p) (q ∷ qs) = q ∷ ─⁺ p qs - -─⁻ : ∀ (p : Any P xs) → Q (Any.lookup p) → All Q (xs Any.─ p) → All Q xs -─⁻ (here px) q qs = q ∷ qs -─⁻ (there p) q (q′ ∷ qs) = q′ ∷ ─⁻ p q qs - ------------------------------------------------------------------------- --- filter - -module _ (P? : Decidable P) where - - all-filter : ∀ xs → All P (filter P? xs) - all-filter [] = [] - all-filter (x ∷ xs) with P? x - ... | true because [Px] = invert [Px] ∷ all-filter xs - ... | false because _ = all-filter xs - - filter⁺ : All Q xs → All Q (filter P? xs) - filter⁺ {xs = _} [] = [] - filter⁺ {xs = x ∷ _} (Qx ∷ Qxs) with does (P? x) - ... | false = filter⁺ Qxs - ... | true = Qx ∷ filter⁺ Qxs - - filter⁻ : All Q (filter P? xs) → All Q (filter (¬? ∘ P?) xs) → All Q xs - filter⁻ {xs = []} [] [] = [] - filter⁻ {xs = x ∷ xs} all⁺ all⁻ with P? x | ¬? (P? x) - filter⁻ {xs = x ∷ xs} all⁺ all⁻ | yes Px | yes ¬Px = contradiction Px ¬Px - filter⁻ {xs = x ∷ xs} (qx ∷ all⁺) all⁻ | yes Px | no ¬¬Px = qx ∷ filter⁻ all⁺ all⁻ - filter⁻ {xs = x ∷ xs} all⁺ (qx ∷ all⁻) | no _ | yes ¬Px = qx ∷ filter⁻ all⁺ all⁻ - filter⁻ {xs = x ∷ xs} all⁺ all⁻ | no ¬Px | no ¬¬Px = contradiction ¬Px ¬¬Px - ------------------------------------------------------------------------- --- partition - -module _ {P : A → Set p} (P? : Decidable P) where - - partition-All : ∀ xs → (let ys , zs = partition P? xs) → - All P ys × All (∁ P) zs - partition-All xs rewrite partition-defn P? xs = - all-filter P? xs , all-filter (∁? P?) xs - ------------------------------------------------------------------------- --- derun and deduplicate - -module _ {R : A → A → Set q} (R? : B.Decidable R) where - - derun⁺ : All P xs → All P (derun R? xs) - derun⁺ {xs = []} [] = [] - derun⁺ {xs = x ∷ []} (px ∷ []) = px ∷ [] - derun⁺ {xs = x ∷ y ∷ xs} (px ∷ all[P,y∷xs]) with does (R? x y) - ... | false = px ∷ derun⁺ all[P,y∷xs] - ... | true = derun⁺ all[P,y∷xs] - - deduplicate⁺ : All P xs → All P (deduplicate R? xs) - deduplicate⁺ [] = [] - deduplicate⁺ (px ∷ pxs) = px ∷ filter⁺ (¬? ∘ R? _) (deduplicate⁺ pxs) - - derun⁻ : P B.Respects (flip R) → ∀ xs → All P (derun R? xs) → All P xs - derun⁻ {P = P} P-resp-R [] [] = [] - derun⁻ {P = P} P-resp-R (x ∷ xs) all[P,x∷xs] = aux x xs all[P,x∷xs] - where - aux : ∀ x xs → All P (derun R? (x ∷ xs)) → All P (x ∷ xs) - aux x [] (px ∷ []) = px ∷ [] - aux x (y ∷ xs) all[P,x∷y∷xs] with R? x y - aux x (y ∷ xs) all[P,y∷xs] | yes Rxy with aux y xs all[P,y∷xs] - aux x (y ∷ xs) all[P,y∷xs] | yes Rxy | r@(py ∷ _) = P-resp-R Rxy py ∷ r - aux x (y ∷ xs) (px ∷ all[P,y∷xs]) | no _ = px ∷ aux y xs all[P,y∷xs] +------------------------------------------------------------------------ +-- mapMaybe - deduplicate⁻ : P B.Respects R → ∀ xs → All P (deduplicate R? xs) → All P xs - deduplicate⁻ {P = P} resp [] [] = [] - deduplicate⁻ {P = P} resp (x ∷ xs) (px ∷ pxs!) = - px ∷ deduplicate⁻ resp xs (filter⁻ (¬? ∘ R? x) pxs! (All.tabulate aux)) - where - aux : ∀ {z} → z ∈ filter (¬? ∘ ¬? ∘ R? x) (deduplicate R? xs) → P z - aux {z = z} z∈filter = resp (decidable-stable (R? x z) - (Prod.proj₂ (∈-filter⁻ (¬? ∘ ¬? ∘ R? x) {z} {deduplicate R? xs} z∈filter))) px - ------------------------------------------------------------------------- --- zipWith - -zipWith⁺ : ∀ (f : A → B → C) → Pointwise (λ x y → P (f x y)) xs ys → - All P (zipWith f xs ys) -zipWith⁺ f [] = [] -zipWith⁺ f (Pfxy ∷ Pfxsys) = Pfxy ∷ zipWith⁺ f Pfxsys - ------------------------------------------------------------------------- --- Operations for constructing lists ------------------------------------------------------------------------- --- fromMaybe - -fromMaybe⁺ : ∀ {mx} → Maybe.All P mx → All P (fromMaybe mx) -fromMaybe⁺ (just px) = px ∷ [] -fromMaybe⁺ nothing = [] - -fromMaybe⁻ : ∀ mx → All P (fromMaybe mx) → Maybe.All P mx -fromMaybe⁻ (just x) (px ∷ []) = just px -fromMaybe⁻ nothing p = nothing - ------------------------------------------------------------------------- --- replicate - -replicate⁺ : ∀ n → P x → All P (replicate n x) -replicate⁺ zero px = [] -replicate⁺ (suc n) px = px ∷ replicate⁺ n px - -replicate⁻ : ∀ {n} → All P (replicate (suc n) x) → P x -replicate⁻ (px ∷ _) = px - ------------------------------------------------------------------------- --- inits - -inits⁺ : All P xs → All (All P) (inits xs) -inits⁺ [] = [] ∷ [] -inits⁺ (px ∷ pxs) = [] ∷ gmap (px ∷_) (inits⁺ pxs) - -inits⁻ : ∀ xs → All (All P) (inits xs) → All P xs -inits⁻ [] pxs = [] -inits⁻ (x ∷ []) ([] ∷ p[x] ∷ []) = p[x] -inits⁻ (x ∷ xs@(_ ∷ _)) ([] ∷ pxs@(p[x] ∷ _)) = - singleton⁻ p[x] ∷ inits⁻ xs (All.map (drop⁺ 1) (map⁻ pxs)) - ------------------------------------------------------------------------- --- tails - -tails⁺ : All P xs → All (All P) (tails xs) -tails⁺ [] = [] ∷ [] -tails⁺ pxxs@(_ ∷ pxs) = pxxs ∷ tails⁺ pxs - -tails⁻ : ∀ xs → All (All P) (tails xs) → All P xs -tails⁻ [] pxs = [] -tails⁻ (x ∷ xs) (pxxs ∷ _) = pxxs - ------------------------------------------------------------------------- --- all - -module _ (p : A → Bool) where - - all⁺ : ∀ xs → T (all p xs) → All (T ∘ p) xs - all⁺ [] _ = [] - all⁺ (x ∷ xs) px∷xs with Equivalence.to (T-∧ {p x}) ⟨$⟩ px∷xs - ... | (px , pxs) = px ∷ all⁺ xs pxs - - all⁻ : All (T ∘ p) xs → T (all p xs) - all⁻ [] = _ - all⁻ (px ∷ pxs) = Equivalence.from T-∧ ⟨$⟩ (px , all⁻ pxs) - ------------------------------------------------------------------------- --- All is anti-monotone. - -anti-mono : xs ⊆ ys → All P ys → All P xs -anti-mono xs⊆ys pys = All.tabulate (lookup pys ∘ xs⊆ys) - -all-anti-mono : ∀ (p : A → Bool) → xs ⊆ ys → T (all p ys) → T (all p xs) -all-anti-mono p xs⊆ys = all⁻ p ∘ anti-mono xs⊆ys ∘ all⁺ p _ - ------------------------------------------------------------------------- --- Interactions with pointwise equality ------------------------------------------------------------------------- - -module _ (S : Setoid c ℓ) where +mapMaybe⁺ : ∀ {f : A → Maybe B} → + All (Maybe.All P) (map f xs) → All P (mapMaybe f xs) +mapMaybe⁺ {xs = []} {f = f} [] = [] +mapMaybe⁺ {xs = x ∷ xs} {f = f} (px ∷ pxs) with f x +... | nothing = mapMaybe⁺ pxs +... | just v with px +... | just pv = pv ∷ mapMaybe⁺ pxs + +------------------------------------------------------------------------ +-- _++_ - open Setoid S - open ListEq S +++⁺ : All P xs → All P ys → All P (xs ++ ys) +++⁺ [] pys = pys +++⁺ (px ∷ pxs) pys = px ∷ ++⁺ pxs pys + +++⁻ˡ : ∀ xs {ys} → All P (xs ++ ys) → All P xs +++⁻ˡ [] p = [] +++⁻ˡ (x ∷ xs) (px ∷ pxs) = px ∷ (++⁻ˡ _ pxs) + +++⁻ʳ : ∀ xs {ys} → All P (xs ++ ys) → All P ys +++⁻ʳ [] p = p +++⁻ʳ (x ∷ xs) (px ∷ pxs) = ++⁻ʳ xs pxs + +++⁻ : ∀ xs {ys} → All P (xs ++ ys) → All P xs × All P ys +++⁻ [] p = [] , p +++⁻ (x ∷ xs) (px ∷ pxs) = Prod.map (px ∷_) id (++⁻ _ pxs) + +++↔ : (All P xs × All P ys) ↔ All P (xs ++ ys) +++↔ {xs = zs} = mk↔ₛ′ (uncurry ++⁺) (++⁻ zs) (++⁺∘++⁻ zs) ++⁻∘++⁺ + where + ++⁺∘++⁻ : ∀ xs (p : All P (xs ++ ys)) → uncurry′ ++⁺ (++⁻ xs p) ≡ p + ++⁺∘++⁻ [] p = refl + ++⁺∘++⁻ (x ∷ xs) (px ∷ pxs) = cong (_∷_ px) $ ++⁺∘++⁻ xs pxs + + ++⁻∘++⁺ : ∀ (p : All P xs × All P ys) → ++⁻ xs (uncurry ++⁺ p) ≡ p + ++⁻∘++⁺ ([] , pys) = refl + ++⁻∘++⁺ (px ∷ pxs , pys) rewrite ++⁻∘++⁺ (pxs , pys) = refl + +------------------------------------------------------------------------ +-- concat + +concat⁺ : ∀ {xss} → All (All P) xss → All P (concat xss) +concat⁺ [] = [] +concat⁺ (pxs ∷ pxss) = ++⁺ pxs (concat⁺ pxss) + +concat⁻ : ∀ {xss} → All P (concat xss) → All (All P) xss +concat⁻ {xss = []} [] = [] +concat⁻ {xss = xs ∷ xss} pxs = ++⁻ˡ xs pxs ∷ concat⁻ (++⁻ʳ xs pxs) + +------------------------------------------------------------------------ +-- snoc + +∷ʳ⁺ : All P xs → P x → All P (xs ∷ʳ x) +∷ʳ⁺ pxs px = ++⁺ pxs (px ∷ []) + +∷ʳ⁻ : All P (xs ∷ʳ x) → All P xs × P x +∷ʳ⁻ pxs = Prod.map₂ singleton⁻ $ ++⁻ _ pxs + +-- unsnoc + +unsnoc⁺ : All P xs → Maybe.All (All P ⟨×⟩ P) (unsnoc xs) +unsnoc⁺ {xs = xs} pxs with initLast xs +unsnoc⁺ {xs = .[]} pxs | [] = nothing +unsnoc⁺ {xs = .(xs ∷ʳ x)} pxs | xs ∷ʳ′ x = just (∷ʳ⁻ pxs) + +unsnoc⁻ : Maybe.All (All P ⟨×⟩ P) (unsnoc xs) → All P xs +unsnoc⁻ {xs = xs} pxs with initLast xs +unsnoc⁻ {xs = .[]} nothing | [] = [] +unsnoc⁻ {xs = .(xs ∷ʳ x)} (just (pxs , px)) | xs ∷ʳ′ x = ∷ʳ⁺ pxs px + +------------------------------------------------------------------------ +-- cartesianProductWith and cartesianProduct + +module _ (S₁ : Setoid a ℓ₁) (S₂ : Setoid b ℓ₂) where + open SetoidMembership S₁ using () renaming (_∈_ to _∈₁_) + open SetoidMembership S₂ using () renaming (_∈_ to _∈₂_) + + cartesianProductWith⁺ : ∀ f xs ys → + (∀ {x y} → x ∈₁ xs → y ∈₂ ys → P (f x y)) → + All P (cartesianProductWith f xs ys) + cartesianProductWith⁺ f [] ys pres = [] + cartesianProductWith⁺ f (x ∷ xs) ys pres = ++⁺ + (map⁺ (All.tabulateₛ S₂ (pres (here (Setoid.refl S₁))))) + (cartesianProductWith⁺ f xs ys (pres ∘ there)) + + cartesianProduct⁺ : ∀ xs ys → + (∀ {x y} → x ∈₁ xs → y ∈₂ ys → P (x , y)) → + All P (cartesianProduct xs ys) + cartesianProduct⁺ = cartesianProductWith⁺ _,_ + +------------------------------------------------------------------------ +-- take and drop + +drop⁺ : ∀ n → All P xs → All P (drop n xs) +drop⁺ zero pxs = pxs +drop⁺ (suc n) [] = [] +drop⁺ (suc n) (px ∷ pxs) = drop⁺ n pxs + +dropWhile⁺ : (Q? : Decidable Q) → All P xs → All P (dropWhile Q? xs) +dropWhile⁺ Q? [] = [] +dropWhile⁺ {xs = x ∷ xs} Q? (px ∷ pxs) with does (Q? x) +... | true = dropWhile⁺ Q? pxs +... | false = px ∷ pxs + +dropWhile⁻ : (P? : Decidable P) → dropWhile P? xs ≡ [] → All P xs +dropWhile⁻ {xs = []} P? eq = [] +dropWhile⁻ {xs = x ∷ xs} P? eq with P? x +... | yes px = px ∷ (dropWhile⁻ P? eq) +... | no ¬px = case eq of λ () + +all-head-dropWhile : (P? : Decidable P) → + ∀ xs → Maybe.All (∁ P) (head (dropWhile P? xs)) +all-head-dropWhile P? [] = nothing +all-head-dropWhile P? (x ∷ xs) with P? x +... | yes px = all-head-dropWhile P? xs +... | no ¬px = just ¬px + +take⁺ : ∀ n → All P xs → All P (take n xs) +take⁺ zero pxs = [] +take⁺ (suc n) [] = [] +take⁺ (suc n) (px ∷ pxs) = px ∷ take⁺ n pxs + +takeWhile⁺ : (Q? : Decidable Q) → All P xs → All P (takeWhile Q? xs) +takeWhile⁺ Q? [] = [] +takeWhile⁺ {xs = x ∷ xs} Q? (px ∷ pxs) with does (Q? x) +... | true = px ∷ takeWhile⁺ Q? pxs +... | false = [] + +takeWhile⁻ : (P? : Decidable P) → takeWhile P? xs ≡ xs → All P xs +takeWhile⁻ {xs = []} P? eq = [] +takeWhile⁻ {xs = x ∷ xs} P? eq with P? x +... | yes px = px ∷ takeWhile⁻ P? (Listₚ.∷-injectiveʳ eq) +... | no ¬px = case eq of λ () + +all-takeWhile : (P? : Decidable P) → ∀ xs → All P (takeWhile P? xs) +all-takeWhile P? [] = [] +all-takeWhile P? (x ∷ xs) with P? x +... | yes px = px ∷ all-takeWhile P? xs +... | no ¬px = [] + +------------------------------------------------------------------------ +-- applyUpTo + +applyUpTo⁺₁ : ∀ f n → (∀ {i} → i < n → P (f i)) → All P (applyUpTo f n) +applyUpTo⁺₁ f zero Pf = [] +applyUpTo⁺₁ f (suc n) Pf = Pf z<s ∷ applyUpTo⁺₁ (f ∘ suc) n (Pf ∘ s<s) + +applyUpTo⁺₂ : ∀ f n → (∀ i → P (f i)) → All P (applyUpTo f n) +applyUpTo⁺₂ f n Pf = applyUpTo⁺₁ f n (λ _ → Pf _) + +applyUpTo⁻ : ∀ f n → All P (applyUpTo f n) → ∀ {i} → i < n → P (f i) +applyUpTo⁻ f (suc n) (px ∷ _) z<s = px +applyUpTo⁻ f (suc n) (_ ∷ pxs) (s<s i<n@(s≤s _)) = + applyUpTo⁻ (f ∘ suc) n pxs i<n + +------------------------------------------------------------------------ +-- upTo + +all-upTo : ∀ n → All (_< n) (upTo n) +all-upTo n = applyUpTo⁺₁ id n id + +------------------------------------------------------------------------ +-- applyDownFrom + +applyDownFrom⁺₁ : ∀ f n → (∀ {i} → i < n → P (f i)) → All P (applyDownFrom f n) +applyDownFrom⁺₁ f zero Pf = [] +applyDownFrom⁺₁ f (suc n) Pf = Pf ≤-refl ∷ applyDownFrom⁺₁ f n (Pf ∘ m≤n⇒m≤1+n) + +applyDownFrom⁺₂ : ∀ f n → (∀ i → P (f i)) → All P (applyDownFrom f n) +applyDownFrom⁺₂ f n Pf = applyDownFrom⁺₁ f n (λ _ → Pf _) + +------------------------------------------------------------------------ +-- tabulate + +tabulate⁺ : ∀ {n} {f : Fin n → A} → + (∀ i → P (f i)) → All P (tabulate f) +tabulate⁺ {n = zero} Pf = [] +tabulate⁺ {n = suc _} Pf = Pf zero ∷ tabulate⁺ (Pf ∘ suc) + +tabulate⁻ : ∀ {n} {f : Fin n → A} → + All P (tabulate f) → (∀ i → P (f i)) +tabulate⁻ (px ∷ _) zero = px +tabulate⁻ (_ ∷ pf) (suc i) = tabulate⁻ pf i + +------------------------------------------------------------------------ +-- remove + +─⁺ : ∀ (p : Any P xs) → All Q xs → All Q (xs Any.─ p) +─⁺ (here px) (_ ∷ qs) = qs +─⁺ (there p) (q ∷ qs) = q ∷ ─⁺ p qs + +─⁻ : ∀ (p : Any P xs) → Q (Any.lookup p) → All Q (xs Any.─ p) → All Q xs +─⁻ (here px) q qs = q ∷ qs +─⁻ (there p) q (q′ ∷ qs) = q′ ∷ ─⁻ p q qs + +------------------------------------------------------------------------ +-- filter + +module _ (P? : Decidable P) where + + all-filter : ∀ xs → All P (filter P? xs) + all-filter [] = [] + all-filter (x ∷ xs) with P? x + ... | true because [Px] = invert [Px] ∷ all-filter xs + ... | false because _ = all-filter xs + + filter⁺ : All Q xs → All Q (filter P? xs) + filter⁺ {xs = _} [] = [] + filter⁺ {xs = x ∷ _} (Qx ∷ Qxs) with does (P? x) + ... | false = filter⁺ Qxs + ... | true = Qx ∷ filter⁺ Qxs + + filter⁻ : All Q (filter P? xs) → All Q (filter (¬? ∘ P?) xs) → All Q xs + filter⁻ {xs = []} [] [] = [] + filter⁻ {xs = x ∷ xs} all⁺ all⁻ with P? x | ¬? (P? x) + filter⁻ {xs = x ∷ xs} all⁺ all⁻ | yes Px | yes ¬Px = contradiction Px ¬Px + filter⁻ {xs = x ∷ xs} (qx ∷ all⁺) all⁻ | yes Px | no ¬¬Px = qx ∷ filter⁻ all⁺ all⁻ + filter⁻ {xs = x ∷ xs} all⁺ (qx ∷ all⁻) | no _ | yes ¬Px = qx ∷ filter⁻ all⁺ all⁻ + filter⁻ {xs = x ∷ xs} all⁺ all⁻ | no ¬Px | no ¬¬Px = contradiction ¬Px ¬¬Px + +------------------------------------------------------------------------ +-- partition + +module _ {P : A → Set p} (P? : Decidable P) where + + partition-All : ∀ xs → (let ys , zs = partition P? xs) → + All P ys × All (∁ P) zs + partition-All xs rewrite partition-defn P? xs = + all-filter P? xs , all-filter (∁? P?) xs + +------------------------------------------------------------------------ +-- derun and deduplicate + +module _ {R : A → A → Set q} (R? : B.Decidable R) where + + derun⁺ : All P xs → All P (derun R? xs) + derun⁺ {xs = []} [] = [] + derun⁺ {xs = x ∷ []} (px ∷ []) = px ∷ [] + derun⁺ {xs = x ∷ y ∷ xs} (px ∷ all[P,y∷xs]) with does (R? x y) + ... | false = px ∷ derun⁺ all[P,y∷xs] + ... | true = derun⁺ all[P,y∷xs] + + deduplicate⁺ : All P xs → All P (deduplicate R? xs) + deduplicate⁺ [] = [] + deduplicate⁺ (px ∷ pxs) = px ∷ filter⁺ (¬? ∘ R? _) (deduplicate⁺ pxs) + + derun⁻ : P B.Respects (flip R) → ∀ xs → All P (derun R? xs) → All P xs + derun⁻ {P = P} P-resp-R [] [] = [] + derun⁻ {P = P} P-resp-R (x ∷ xs) all[P,x∷xs] = aux x xs all[P,x∷xs] + where + aux : ∀ x xs → All P (derun R? (x ∷ xs)) → All P (x ∷ xs) + aux x [] (px ∷ []) = px ∷ [] + aux x (y ∷ xs) all[P,x∷y∷xs] with R? x y + aux x (y ∷ xs) all[P,y∷xs] | yes Rxy with aux y xs all[P,y∷xs] + aux x (y ∷ xs) all[P,y∷xs] | yes Rxy | r@(py ∷ _) = P-resp-R Rxy py ∷ r + aux x (y ∷ xs) (px ∷ all[P,y∷xs]) | no _ = px ∷ aux y xs all[P,y∷xs] - respects : P Respects _≈_ → (All P) Respects _≋_ - respects p≈ [] [] = [] - respects p≈ (x≈y ∷ xs≈ys) (px ∷ pxs) = p≈ x≈y px ∷ respects p≈ xs≈ys pxs + deduplicate⁻ : P B.Respects R → ∀ xs → All P (deduplicate R? xs) → All P xs + deduplicate⁻ {P = P} resp [] [] = [] + deduplicate⁻ {P = P} resp (x ∷ xs) (px ∷ pxs!) = + px ∷ deduplicate⁻ resp xs (filter⁻ (¬? ∘ R? x) pxs! (All.tabulate aux)) + where + aux : ∀ {z} → z ∈ filter (¬? ∘ ¬? ∘ R? x) (deduplicate R? xs) → P z + aux {z = z} z∈filter = resp (decidable-stable (R? x z) + (Prod.proj₂ (∈-filter⁻ (¬? ∘ ¬? ∘ R? x) {z} {deduplicate R? xs} z∈filter))) px + +------------------------------------------------------------------------ +-- zipWith + +zipWith⁺ : ∀ (f : A → B → C) → Pointwise (λ x y → P (f x y)) xs ys → + All P (zipWith f xs ys) +zipWith⁺ f [] = [] +zipWith⁺ f (Pfxy ∷ Pfxsys) = Pfxy ∷ zipWith⁺ f Pfxsys + +------------------------------------------------------------------------ +-- Operations for constructing lists +------------------------------------------------------------------------ +-- fromMaybe + +fromMaybe⁺ : ∀ {mx} → Maybe.All P mx → All P (fromMaybe mx) +fromMaybe⁺ (just px) = px ∷ [] +fromMaybe⁺ nothing = [] + +fromMaybe⁻ : ∀ mx → All P (fromMaybe mx) → Maybe.All P mx +fromMaybe⁻ (just x) (px ∷ []) = just px +fromMaybe⁻ nothing p = nothing + +------------------------------------------------------------------------ +-- replicate + +replicate⁺ : ∀ n → P x → All P (replicate n x) +replicate⁺ zero px = [] +replicate⁺ (suc n) px = px ∷ replicate⁺ n px + +replicate⁻ : ∀ {n} → All P (replicate (suc n) x) → P x +replicate⁻ (px ∷ _) = px + +------------------------------------------------------------------------ +-- inits + +inits⁺ : All P xs → All (All P) (inits xs) +inits⁺ [] = [] ∷ [] +inits⁺ (px ∷ pxs) = [] ∷ gmap⁺ (px ∷_) (inits⁺ pxs) + +inits⁻ : ∀ xs → All (All P) (inits xs) → All P xs +inits⁻ [] pxs = [] +inits⁻ (x ∷ []) ([] ∷ p[x] ∷ []) = p[x] +inits⁻ (x ∷ xs@(_ ∷ _)) ([] ∷ pxs@(p[x] ∷ _)) = + singleton⁻ p[x] ∷ inits⁻ xs (All.map (drop⁺ 1) (map⁻ pxs)) + +------------------------------------------------------------------------ +-- tails + +tails⁺ : All P xs → All (All P) (tails xs) +tails⁺ [] = [] ∷ [] +tails⁺ pxxs@(_ ∷ pxs) = pxxs ∷ tails⁺ pxs + +tails⁻ : ∀ xs → All (All P) (tails xs) → All P xs +tails⁻ [] pxs = [] +tails⁻ (x ∷ xs) (pxxs ∷ _) = pxxs + +------------------------------------------------------------------------ +-- all + +module _ (p : A → Bool) where + + all⁺ : ∀ xs → T (all p xs) → All (T ∘ p) xs + all⁺ [] _ = [] + all⁺ (x ∷ xs) px∷xs with Equivalence.to (T-∧ {p x}) px∷xs + ... | (px , pxs) = px ∷ all⁺ xs pxs + + all⁻ : All (T ∘ p) xs → T (all p xs) + all⁻ [] = _ + all⁻ (px ∷ pxs) = Equivalence.from T-∧ (px , all⁻ pxs) + +------------------------------------------------------------------------ +-- All is anti-monotone. + +anti-mono : xs ⊆ ys → All P ys → All P xs +anti-mono xs⊆ys pys = All.tabulate (lookup pys ∘ xs⊆ys) + +all-anti-mono : ∀ (p : A → Bool) → xs ⊆ ys → T (all p ys) → T (all p xs) +all-anti-mono p xs⊆ys = all⁻ p ∘ anti-mono xs⊆ys ∘ all⁺ p _ + +------------------------------------------------------------------------ +-- Interactions with pointwise equality +------------------------------------------------------------------------ + +module _ (S : Setoid c ℓ) where ------------------------------------------------------------------------- --- DEPRECATED NAMES ------------------------------------------------------------------------- --- Please use the new names as continuing support for the old names is --- not guaranteed. + open Setoid S + open ListEq S --- Version 1.3 + respects : P B.Respects _≈_ → (All P) B.Respects _≋_ + respects p≈ [] [] = [] + respects p≈ (x≈y ∷ xs≈ys) (px ∷ pxs) = p≈ x≈y px ∷ respects p≈ xs≈ys pxs -Any¬→¬All = Any¬⇒¬All -{-# WARNING_ON_USAGE Any¬→¬All -"Warning: Any¬→¬All was deprecated in v1.3. +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 1.3 + +Any¬→¬All = Any¬⇒¬All +{-# WARNING_ON_USAGE Any¬→¬All +"Warning: Any¬→¬All was deprecated in v1.3. Please use Any¬⇒¬All instead." -#-} +#-} --- Version 2.0 +-- Version 2.0 -updateAt-id-relative = updateAt-id-local -{-# WARNING_ON_USAGE updateAt-id-relative -"Warning: updateAt-id-relative was deprecated in v2.0. +updateAt-id-relative = updateAt-id-local +{-# WARNING_ON_USAGE updateAt-id-relative +"Warning: updateAt-id-relative was deprecated in v2.0. Please use updateAt-id-local instead." -#-} +#-} -updateAt-compose-relative = updateAt-∘-local -{-# WARNING_ON_USAGE updateAt-compose-relative -"Warning: updateAt-compose-relative was deprecated in v2.0. +updateAt-compose-relative = updateAt-∘-local +{-# WARNING_ON_USAGE updateAt-compose-relative +"Warning: updateAt-compose-relative was deprecated in v2.0. Please use updateAt-∘-local instead." -#-} +#-} -updateAt-compose = updateAt-∘ -{-# WARNING_ON_USAGE updateAt-compose -"Warning: updateAt-compose was deprecated in v2.0. +updateAt-compose = updateAt-∘ +{-# WARNING_ON_USAGE updateAt-compose +"Warning: updateAt-compose was deprecated in v2.0. Please use updateAt-∘ instead." -#-} +#-} -updateAt-cong-relative = updateAt-cong-local -{-# WARNING_ON_USAGE updateAt-cong-relative -"Warning: updateAt-cong-relative was deprecated in v2.0. +updateAt-cong-relative = updateAt-cong-local +{-# WARNING_ON_USAGE updateAt-cong-relative +"Warning: updateAt-cong-relative was deprecated in v2.0. Please use updateAt-cong-local instead." -#-} +#-} + +gmap = gmap⁺ +{-# WARNING_ON_USAGE gmap +"Warning: gmap was deprecated in v2.0. +Please use gmap⁺ instead." +#-} \ No newline at end of file diff --git a/Data.List.Relation.Unary.All.html b/Data.List.Relation.Unary.All.html index 056f84cb..b5fc8baa 100644 --- a/Data.List.Relation.Unary.All.html +++ b/Data.List.Relation.Unary.All.html @@ -12,232 +12,235 @@ open import Effect.Applicative open import Effect.Monad open import Data.Empty using (⊥) -open import Data.List.Base as List using (List; []; _∷_) -open import Data.List.Relation.Unary.Any as Any using (Any; here; there) -open import Data.List.Membership.Propositional renaming (_∈_ to _∈ₚ_) +open import Data.List.Base as List using (List; []; _∷_) +open import Data.List.Relation.Unary.Any as Any using (Any; here; there) +open import Data.List.Membership.Propositional renaming (_∈_ to _∈ₚ_) import Data.List.Membership.Setoid as SetoidMembership -open import Data.Product as Prod - using (∃; -,_; _×_; _,_; proj₁; proj₂; uncurry) -open import Data.Sum.Base as Sum using (inj₁; inj₂) -open import Function -open import Level -open import Relation.Nullary hiding (Irrelevant) -import Relation.Nullary.Decidable as Dec -open import Relation.Unary hiding (_∈_) -open import Relation.Binary using (Setoid; _Respects_) -open import Relation.Binary.PropositionalEquality as P +open import Data.Product.Base as Prod + using (∃; -,_; _×_; _,_; proj₁; proj₂; uncurry) +open import Data.Sum.Base as Sum using (inj₁; inj₂) +open import Function.Base using (_∘_; _∘′_; id; const) +open import Level using (Level; _⊔_) +open import Relation.Nullary hiding (Irrelevant) +import Relation.Nullary.Decidable as Dec +open import Relation.Unary hiding (_∈_) +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Binary.Definitions using (_Respects_) +open import Relation.Binary.PropositionalEquality.Core as P +import Relation.Binary.PropositionalEquality.Properties as P -private - variable - a b p q r ℓ : Level - A : Set a - B : Set b - P Q R : Pred A p - x : A - xs : List A +private + variable + a b p q r ℓ : Level + A : Set a + B : Set b + P Q R : Pred A p + x : A + xs : List A ------------------------------------------------------------------------- --- Definitions +------------------------------------------------------------------------ +-- Definitions --- Given a predicate P, then All P xs means that every element in xs --- satisfies P. See `Relation.Unary` for an explanation of predicates. +-- Given a predicate P, then All P xs means that every element in xs +-- satisfies P. See `Relation.Unary` for an explanation of predicates. -infixr 5 _∷_ +infixr 5 _∷_ -data All {A : Set a} (P : Pred A p) : Pred (List A) (a ⊔ p) where - [] : All P [] - _∷_ : ∀ {x xs} (px : P x) (pxs : All P xs) → All P (x ∷ xs) +data All {A : Set a} (P : Pred A p) : Pred (List A) (a ⊔ p) where + [] : All P [] + _∷_ : ∀ {x xs} (px : P x) (pxs : All P xs) → All P (x ∷ xs) --- All P xs is a finite map from indices x ∈ xs to content P x. --- Relation pxs [ i ]= px states that, in map pxs, key i : x ∈ xs points to value px. +-- All P xs is a finite map from indices x ∈ xs to content P x. +-- Relation pxs [ i ]= px states that, in map pxs, key i : x ∈ xs points +-- to value px. -infix 4 _[_]=_ +infix 4 _[_]=_ -data _[_]=_ {A : Set a} {P : Pred A p} : - ∀ {x xs} → All P xs → x ∈ₚ xs → P x → Set (a ⊔ p) where +data _[_]=_ {A : Set a} {P : Pred A p} : + ∀ {x xs} → All P xs → x ∈ₚ xs → P x → Set (a ⊔ p) where - here : ∀ {x xs} {px : P x} {pxs : All P xs} → - px ∷ pxs [ here refl ]= px + here : ∀ {x xs} {px : P x} {pxs : All P xs} → + px ∷ pxs [ here refl ]= px - there : ∀ {x xs y} {px : P x} {pxs : All P xs} {py : P y} {i : x ∈ₚ xs} → - pxs [ i ]= px → - py ∷ pxs [ there i ]= px + there : ∀ {x xs y} {px : P x} {pxs : All P xs} {py : P y} {i : x ∈ₚ xs} → + pxs [ i ]= px → + py ∷ pxs [ there i ]= px --- A list is empty if having an element is impossible. +-- A list is empty if having an element is impossible. -Null : Pred (List A) _ -Null = All (λ _ → ⊥) +Null : Pred (List A) _ +Null = All (λ _ → ⊥) ------------------------------------------------------------------------- --- Operations on All +------------------------------------------------------------------------ +-- Operations on All -uncons : All P (x ∷ xs) → P x × All P xs -uncons (px ∷ pxs) = px , pxs +uncons : All P (x ∷ xs) → P x × All P xs +uncons (px ∷ pxs) = px , pxs -head : All P (x ∷ xs) → P x -head = proj₁ ∘ uncons +head : All P (x ∷ xs) → P x +head = proj₁ ∘ uncons -tail : All P (x ∷ xs) → All P xs -tail = proj₂ ∘ uncons +tail : All P (x ∷ xs) → All P xs +tail = proj₂ ∘ uncons -reduce : (f : ∀ {x} → P x → B) → All P xs → List B -reduce f [] = [] -reduce f (px ∷ pxs) = f px ∷ reduce f pxs +reduce : (f : ∀ {x} → P x → B) → All P xs → List B +reduce f [] = [] +reduce f (px ∷ pxs) = f px ∷ reduce f pxs -construct : (f : B → ∃ P) (xs : List B) → ∃ (All P) -construct f [] = [] , [] -construct f (x ∷ xs) = Prod.zip _∷_ _∷_ (f x) (construct f xs) +construct : (f : B → ∃ P) (xs : List B) → ∃ (All P) +construct f [] = [] , [] +construct f (x ∷ xs) = Prod.zip _∷_ _∷_ (f x) (construct f xs) -fromList : (xs : List (∃ P)) → All P (List.map proj₁ xs) -fromList [] = [] -fromList ((x , p) ∷ xps) = p ∷ fromList xps +fromList : (xs : List (∃ P)) → All P (List.map proj₁ xs) +fromList [] = [] +fromList ((x , p) ∷ xps) = p ∷ fromList xps -toList : All P xs → List (∃ P) -toList pxs = reduce (λ {x} px → x , px) pxs +toList : All P xs → List (∃ P) +toList pxs = reduce (λ {x} px → x , px) pxs -map : P ⊆ Q → All P ⊆ All Q -map g [] = [] -map g (px ∷ pxs) = g px ∷ map g pxs +map : P ⊆ Q → All P ⊆ All Q +map g [] = [] +map g (px ∷ pxs) = g px ∷ map g pxs -zipWith : P ∩ Q ⊆ R → All P ∩ All Q ⊆ All R -zipWith f ([] , []) = [] -zipWith f (px ∷ pxs , qx ∷ qxs) = f (px , qx) ∷ zipWith f (pxs , qxs) +zipWith : P ∩ Q ⊆ R → All P ∩ All Q ⊆ All R +zipWith f ([] , []) = [] +zipWith f (px ∷ pxs , qx ∷ qxs) = f (px , qx) ∷ zipWith f (pxs , qxs) -unzipWith : R ⊆ P ∩ Q → All R ⊆ All P ∩ All Q -unzipWith f [] = [] , [] -unzipWith f (rx ∷ rxs) = Prod.zip _∷_ _∷_ (f rx) (unzipWith f rxs) +unzipWith : R ⊆ P ∩ Q → All R ⊆ All P ∩ All Q +unzipWith f [] = [] , [] +unzipWith f (rx ∷ rxs) = Prod.zip _∷_ _∷_ (f rx) (unzipWith f rxs) -zip : All P ∩ All Q ⊆ All (P ∩ Q) -zip = zipWith id +zip : All P ∩ All Q ⊆ All (P ∩ Q) +zip = zipWith id -unzip : All (P ∩ Q) ⊆ All P ∩ All Q -unzip = unzipWith id +unzip : All (P ∩ Q) ⊆ All P ∩ All Q +unzip = unzipWith id -module _(S : Setoid a ℓ) {P : Pred (Setoid.Carrier S) p} where - open Setoid S renaming (Carrier to C; refl to refl₁) - open SetoidMembership S +module _(S : Setoid a ℓ) {P : Pred (Setoid.Carrier S) p} where + open Setoid S renaming (Carrier to C; refl to refl₁) + open SetoidMembership S - tabulateₛ : (∀ {x} → x ∈ xs → P x) → All P xs - tabulateₛ {[]} hyp = [] - tabulateₛ {x ∷ xs} hyp = hyp (here refl₁) ∷ tabulateₛ (hyp ∘ there) + tabulateₛ : (∀ {x} → x ∈ xs → P x) → All P xs + tabulateₛ {[]} hyp = [] + tabulateₛ {x ∷ xs} hyp = hyp (here refl₁) ∷ tabulateₛ (hyp ∘ there) -tabulate : (∀ {x} → x ∈ₚ xs → P x) → All P xs -tabulate = tabulateₛ (P.setoid _) +tabulate : (∀ {x} → x ∈ₚ xs → P x) → All P xs +tabulate = tabulateₛ (P.setoid _) -self : ∀ {xs : List A} → All (const A) xs -self = tabulate (λ {x} _ → x) +self : ∀ {xs : List A} → All (const A) xs +self = tabulate (λ {x} _ → x) ------------------------------------------------------------------------- --- (weak) updateAt +------------------------------------------------------------------------ +-- (weak) updateAt -infixl 6 _[_]%=_ _[_]≔_ +infixl 6 _[_]%=_ _[_]≔_ -updateAt : x ∈ₚ xs → (P x → P x) → All P xs → All P xs -updateAt () f [] -updateAt (here refl) f (px ∷ pxs) = f px ∷ pxs -updateAt (there i) f (px ∷ pxs) = px ∷ updateAt i f pxs +updateAt : x ∈ₚ xs → (P x → P x) → All P xs → All P xs +updateAt () f [] +updateAt (here refl) f (px ∷ pxs) = f px ∷ pxs +updateAt (there i) f (px ∷ pxs) = px ∷ updateAt i f pxs -_[_]%=_ : All P xs → x ∈ₚ xs → (P x → P x) → All P xs -pxs [ i ]%= f = updateAt i f pxs +_[_]%=_ : All P xs → x ∈ₚ xs → (P x → P x) → All P xs +pxs [ i ]%= f = updateAt i f pxs -_[_]≔_ : All P xs → x ∈ₚ xs → P x → All P xs -pxs [ i ]≔ px = pxs [ i ]%= const px +_[_]≔_ : All P xs → x ∈ₚ xs → P x → All P xs +pxs [ i ]≔ px = pxs [ i ]%= const px ------------------------------------------------------------------------- --- Traversable-like functions +------------------------------------------------------------------------ +-- Traversable-like functions -module _ (p : Level) {A : Set a} {P : Pred A (a ⊔ p)} - {F : Set (a ⊔ p) → Set (a ⊔ p)} - (App : RawApplicative F) - where +module _ (p : Level) {A : Set a} {P : Pred A (a ⊔ p)} + {F : Set (a ⊔ p) → Set (a ⊔ p)} + (App : RawApplicative F) + where - open RawApplicative App + open RawApplicative App - sequenceA : All (F ∘′ P) ⊆ F ∘′ All P - sequenceA [] = pure [] - sequenceA (x ∷ xs) = _∷_ <$> x <*> sequenceA xs + sequenceA : All (F ∘′ P) ⊆ F ∘′ All P + sequenceA [] = pure [] + sequenceA (x ∷ xs) = _∷_ <$> x <*> sequenceA xs - mapA : ∀ {Q : Pred A q} → (Q ⊆ F ∘′ P) → All Q ⊆ (F ∘′ All P) - mapA f = sequenceA ∘′ map f + mapA : ∀ {Q : Pred A q} → (Q ⊆ F ∘′ P) → All Q ⊆ (F ∘′ All P) + mapA f = sequenceA ∘′ map f - forA : ∀ {Q : Pred A q} → All Q xs → (Q ⊆ F ∘′ P) → F (All P xs) - forA qxs f = mapA f qxs + forA : ∀ {Q : Pred A q} → All Q xs → (Q ⊆ F ∘′ P) → F (All P xs) + forA qxs f = mapA f qxs -module _ (p : Level) {A : Set a} {P : Pred A (a ⊔ p)} - {M : Set (a ⊔ p) → Set (a ⊔ p)} - (Mon : RawMonad M) - where +module _ (p : Level) {A : Set a} {P : Pred A (a ⊔ p)} + {M : Set (a ⊔ p) → Set (a ⊔ p)} + (Mon : RawMonad M) + where - private App = RawMonad.rawApplicative Mon + private App = RawMonad.rawApplicative Mon - sequenceM : All (M ∘′ P) ⊆ M ∘′ All P - sequenceM = sequenceA p App + sequenceM : All (M ∘′ P) ⊆ M ∘′ All P + sequenceM = sequenceA p App - mapM : ∀ {Q : Pred A q} → (Q ⊆ M ∘′ P) → All Q ⊆ (M ∘′ All P) - mapM = mapA p App + mapM : ∀ {Q : Pred A q} → (Q ⊆ M ∘′ P) → All Q ⊆ (M ∘′ All P) + mapM = mapA p App - forM : ∀ {Q : Pred A q} → All Q xs → (Q ⊆ M ∘′ P) → M (All P xs) - forM = forA p App + forM : ∀ {Q : Pred A q} → All Q xs → (Q ⊆ M ∘′ P) → M (All P xs) + forM = forA p App ------------------------------------------------------------------------- --- Generalised lookup based on a proof of Any +------------------------------------------------------------------------ +-- Generalised lookup based on a proof of Any -lookupAny : All P xs → (i : Any Q xs) → (P ∩ Q) (Any.lookup i) -lookupAny (px ∷ pxs) (here qx) = px , qx -lookupAny (px ∷ pxs) (there i) = lookupAny pxs i +lookupAny : All P xs → (i : Any Q xs) → (P ∩ Q) (Any.lookup i) +lookupAny (px ∷ pxs) (here qx) = px , qx +lookupAny (px ∷ pxs) (there i) = lookupAny pxs i -lookupWith : ∀[ P ⇒ Q ⇒ R ] → All P xs → (i : Any Q xs) → R (Any.lookup i) -lookupWith f pxs i = Prod.uncurry f (lookupAny pxs i) +lookupWith : ∀[ P ⇒ Q ⇒ R ] → All P xs → (i : Any Q xs) → R (Any.lookup i) +lookupWith f pxs i = Prod.uncurry f (lookupAny pxs i) -lookup : All P xs → (∀ {x} → x ∈ₚ xs → P x) -lookup pxs = lookupWith (λ { px refl → px }) pxs +lookup : All P xs → (∀ {x} → x ∈ₚ xs → P x) +lookup pxs = lookupWith (λ { px refl → px }) pxs -module _(S : Setoid a ℓ) {P : Pred (Setoid.Carrier S) p} where - open Setoid S renaming (sym to sym₁) - open SetoidMembership S +module _(S : Setoid a ℓ) {P : Pred (Setoid.Carrier S) p} where + open Setoid S renaming (sym to sym₁) + open SetoidMembership S - lookupₛ : P Respects _≈_ → All P xs → (∀ {x} → x ∈ xs → P x) - lookupₛ resp pxs = lookupWith (λ py x=y → resp (sym₁ x=y) py) pxs + lookupₛ : P Respects _≈_ → All P xs → (∀ {x} → x ∈ xs → P x) + lookupₛ resp pxs = lookupWith (λ py x=y → resp (sym₁ x=y) py) pxs ------------------------------------------------------------------------- --- Properties of predicates preserved by All +------------------------------------------------------------------------ +-- Properties of predicates preserved by All -all? : Decidable P → Decidable (All P) -all? p [] = yes [] -all? p (x ∷ xs) = Dec.map′ (uncurry _∷_) uncons (p x ×-dec all? p xs) +all? : Decidable P → Decidable (All P) +all? p [] = yes [] +all? p (x ∷ xs) = Dec.map′ (uncurry _∷_) uncons (p x ×-dec all? p xs) -universal : Universal P → Universal (All P) -universal u [] = [] -universal u (x ∷ xs) = u x ∷ universal u xs +universal : Universal P → Universal (All P) +universal u [] = [] +universal u (x ∷ xs) = u x ∷ universal u xs -irrelevant : Irrelevant P → Irrelevant (All P) -irrelevant irr [] [] = P.refl -irrelevant irr (px₁ ∷ pxs₁) (px₂ ∷ pxs₂) = - P.cong₂ _∷_ (irr px₁ px₂) (irrelevant irr pxs₁ pxs₂) +irrelevant : Irrelevant P → Irrelevant (All P) +irrelevant irr [] [] = P.refl +irrelevant irr (px₁ ∷ pxs₁) (px₂ ∷ pxs₂) = + P.cong₂ _∷_ (irr px₁ px₂) (irrelevant irr pxs₁ pxs₂) -satisfiable : Satisfiable (All P) -satisfiable = [] , [] +satisfiable : Satisfiable (All P) +satisfiable = [] , [] ------------------------------------------------------------------------- --- Generalised decidability procedure +------------------------------------------------------------------------ +-- Generalised decidability procedure -decide : Π[ P ∪ Q ] → Π[ All P ∪ Any Q ] -decide p∪q [] = inj₁ [] -decide p∪q (x ∷ xs) with p∪q x -... | inj₂ qx = inj₂ (here qx) -... | inj₁ px = Sum.map (px ∷_) there (decide p∪q xs) +decide : Π[ P ∪ Q ] → Π[ All P ∪ Any Q ] +decide p∪q [] = inj₁ [] +decide p∪q (x ∷ xs) with p∪q x +... | inj₂ qx = inj₂ (here qx) +... | inj₁ px = Sum.map (px ∷_) there (decide p∪q xs) ------------------------------------------------------------------------- --- DEPRECATED ------------------------------------------------------------------------- --- Please use the new names as continuing support for the old names is --- not guaranteed. +------------------------------------------------------------------------ +-- DEPRECATED +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. --- Version 1.4 +-- Version 1.4 -all = all? -{-# WARNING_ON_USAGE all -"Warning: all was deprecated in v1.4. +all = all? +{-# WARNING_ON_USAGE all +"Warning: all was deprecated in v1.4. Please use all? instead." -#-} +#-} \ No newline at end of file diff --git a/Data.List.Relation.Unary.AllPairs.Core.html b/Data.List.Relation.Unary.AllPairs.Core.html index 85701189..bc0a3bf2 100644 --- a/Data.List.Relation.Unary.AllPairs.Core.html +++ b/Data.List.Relation.Unary.AllPairs.Core.html @@ -13,24 +13,24 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary using (Rel) +open import Relation.Binary.Core using (Rel) -module Data.List.Relation.Unary.AllPairs.Core - {a ℓ} {A : Set a} (R : Rel A ℓ) where +module Data.List.Relation.Unary.AllPairs.Core + {a ℓ} {A : Set a} (R : Rel A ℓ) where -open import Level -open import Data.List.Base -open import Data.List.Relation.Unary.All +open import Level +open import Data.List.Base +open import Data.List.Relation.Unary.All ------------------------------------------------------------------------- --- Definition +------------------------------------------------------------------------ +-- Definition --- AllPairs R xs means that every pair of elements (x , y) in xs is a --- member of relation R (as long as x comes before y in the list). +-- AllPairs R xs means that every pair of elements (x , y) in xs is a +-- member of relation R (as long as x comes before y in the list). -infixr 5 _∷_ +infixr 5 _∷_ -data AllPairs : List A → Set (a ⊔ ℓ) where - [] : AllPairs [] - _∷_ : ∀ {x xs} → All (R x) xs → AllPairs xs → AllPairs (x ∷ xs) +data AllPairs : List A → Set (a ⊔ ℓ) where + [] : AllPairs [] + _∷_ : ∀ {x xs} → All (R x) xs → AllPairs xs → AllPairs (x ∷ xs) \ No newline at end of file diff --git a/Data.List.Relation.Unary.AllPairs.html b/Data.List.Relation.Unary.AllPairs.html index 35de0c89..5efe4418 100644 --- a/Data.List.Relation.Unary.AllPairs.html +++ b/Data.List.Relation.Unary.AllPairs.html @@ -7,76 +7,76 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary using (Rel) +open import Relation.Binary.Core using (Rel; _⇒_) -module Data.List.Relation.Unary.AllPairs - {a ℓ} {A : Set a} {R : Rel A ℓ} where +module Data.List.Relation.Unary.AllPairs + {a ℓ} {A : Set a} {R : Rel A ℓ} where -open import Data.List.Base using (List; []; _∷_) -open import Data.List.Relation.Unary.All as All using (All; []; _∷_) -open import Data.Product as Prod using (_,_; _×_; uncurry; <_,_>) -open import Function.Base using (id; _∘_) -open import Level using (_⊔_) -open import Relation.Binary as B using (Rel; _⇒_) -open import Relation.Binary.Construct.Intersection renaming (_∩_ to _∩ᵇ_) -open import Relation.Binary.PropositionalEquality -open import Relation.Unary as U renaming (_∩_ to _∩ᵘ_) hiding (_⇒_) -open import Relation.Nullary.Decidable as Dec using (_×-dec_; yes; no) +open import Data.List.Base using (List; []; _∷_) +open import Data.List.Relation.Unary.All as All using (All; []; _∷_) +open import Data.Product.Base as Prod using (_,_; _×_; uncurry; <_,_>) +open import Function.Base using (id; _∘_) +open import Level using (_⊔_) +open import Relation.Binary.Definitions as B +open import Relation.Binary.Construct.Intersection renaming (_∩_ to _∩ᵇ_) +open import Relation.Binary.PropositionalEquality +open import Relation.Unary as U renaming (_∩_ to _∩ᵘ_) hiding (_⇒_) +open import Relation.Nullary.Decidable as Dec using (_×-dec_; yes; no) ------------------------------------------------------------------------- --- Definition +------------------------------------------------------------------------ +-- Definition -open import Data.List.Relation.Unary.AllPairs.Core public +open import Data.List.Relation.Unary.AllPairs.Core public ------------------------------------------------------------------------- --- Operations +------------------------------------------------------------------------ +-- Operations -head : ∀ {x xs} → AllPairs R (x ∷ xs) → All (R x) xs -head (px ∷ pxs) = px +head : ∀ {x xs} → AllPairs R (x ∷ xs) → All (R x) xs +head (px ∷ pxs) = px -tail : ∀ {x xs} → AllPairs R (x ∷ xs) → AllPairs R xs -tail (px ∷ pxs) = pxs +tail : ∀ {x xs} → AllPairs R (x ∷ xs) → AllPairs R xs +tail (px ∷ pxs) = pxs -uncons : ∀ {x xs} → AllPairs R (x ∷ xs) → All (R x) xs × AllPairs R xs -uncons = < head , tail > +uncons : ∀ {x xs} → AllPairs R (x ∷ xs) → All (R x) xs × AllPairs R xs +uncons = < head , tail > -module _ {q} {S : Rel A q} where +module _ {q} {S : Rel A q} where - map : R ⇒ S → AllPairs R ⊆ AllPairs S - map ~₁⇒~₂ [] = [] - map ~₁⇒~₂ (x~xs ∷ pxs) = All.map ~₁⇒~₂ x~xs ∷ (map ~₁⇒~₂ pxs) + map : R ⇒ S → AllPairs R ⊆ AllPairs S + map ~₁⇒~₂ [] = [] + map ~₁⇒~₂ (x~xs ∷ pxs) = All.map ~₁⇒~₂ x~xs ∷ (map ~₁⇒~₂ pxs) -module _ {s t} {S : Rel A s} {T : Rel A t} where +module _ {s t} {S : Rel A s} {T : Rel A t} where - zipWith : R ∩ᵇ S ⇒ T → AllPairs R ∩ᵘ AllPairs S ⊆ AllPairs T - zipWith f ([] , []) = [] - zipWith f (px ∷ pxs , qx ∷ qxs) = All.zipWith f (px , qx) ∷ zipWith f (pxs , qxs) + zipWith : R ∩ᵇ S ⇒ T → AllPairs R ∩ᵘ AllPairs S ⊆ AllPairs T + zipWith f ([] , []) = [] + zipWith f (px ∷ pxs , qx ∷ qxs) = All.zipWith f (px , qx) ∷ zipWith f (pxs , qxs) - unzipWith : T ⇒ R ∩ᵇ S → AllPairs T ⊆ AllPairs R ∩ᵘ AllPairs S - unzipWith f [] = [] , [] - unzipWith f (rx ∷ rxs) = Prod.zip _∷_ _∷_ (All.unzipWith f rx) (unzipWith f rxs) + unzipWith : T ⇒ R ∩ᵇ S → AllPairs T ⊆ AllPairs R ∩ᵘ AllPairs S + unzipWith f [] = [] , [] + unzipWith f (rx ∷ rxs) = Prod.zip _∷_ _∷_ (All.unzipWith f rx) (unzipWith f rxs) -module _ {s} {S : Rel A s} where +module _ {s} {S : Rel A s} where - zip : AllPairs R ∩ᵘ AllPairs S ⊆ AllPairs (R ∩ᵇ S) - zip = zipWith id + zip : AllPairs R ∩ᵘ AllPairs S ⊆ AllPairs (R ∩ᵇ S) + zip = zipWith id - unzip : AllPairs (R ∩ᵇ S) ⊆ AllPairs R ∩ᵘ AllPairs S - unzip = unzipWith id + unzip : AllPairs (R ∩ᵇ S) ⊆ AllPairs R ∩ᵘ AllPairs S + unzip = unzipWith id ------------------------------------------------------------------------- --- Properties of predicates preserved by AllPairs +------------------------------------------------------------------------ +-- Properties of predicates preserved by AllPairs -allPairs? : B.Decidable R → U.Decidable (AllPairs R) -allPairs? R? [] = yes [] -allPairs? R? (x ∷ xs) = - Dec.map′ (uncurry _∷_) uncons (All.all? (R? x) xs ×-dec allPairs? R? xs) +allPairs? : B.Decidable R → U.Decidable (AllPairs R) +allPairs? R? [] = yes [] +allPairs? R? (x ∷ xs) = + Dec.map′ (uncurry _∷_) uncons (All.all? (R? x) xs ×-dec allPairs? R? xs) -irrelevant : B.Irrelevant R → U.Irrelevant (AllPairs R) -irrelevant irr [] [] = refl -irrelevant irr (px₁ ∷ pxs₁) (px₂ ∷ pxs₂) = - cong₂ _∷_ (All.irrelevant irr px₁ px₂) (irrelevant irr pxs₁ pxs₂) +irrelevant : B.Irrelevant R → U.Irrelevant (AllPairs R) +irrelevant irr [] [] = refl +irrelevant irr (px₁ ∷ pxs₁) (px₂ ∷ pxs₂) = + cong₂ _∷_ (All.irrelevant irr px₁ px₂) (irrelevant irr pxs₁ pxs₂) -satisfiable : U.Satisfiable (AllPairs R) -satisfiable = [] , [] +satisfiable : U.Satisfiable (AllPairs R) +satisfiable = [] , [] \ No newline at end of file diff --git a/Data.List.Relation.Unary.Any.Properties.html b/Data.List.Relation.Unary.Any.Properties.html index e5673858..5adc437a 100644 --- a/Data.List.Relation.Unary.Any.Properties.html +++ b/Data.List.Relation.Unary.Any.Properties.html @@ -9,738 +9,729 @@ module Data.List.Relation.Unary.Any.Properties where -open import Data.Bool.Base using (Bool; false; true; T) -open import Data.Bool.Properties using (T-∨; T-≡) +open import Data.Bool.Base using (Bool; false; true; T) +open import Data.Bool.Properties using (T-∨; T-≡) open import Data.Empty using (⊥) -open import Data.Fin.Base using (Fin; zero; suc) -open import Data.List.Base as List -open import Data.List.Properties using (ʳ++-defn) -open import Data.List.Effectful as Listₑ using (monad) -open import Data.List.Relation.Unary.Any as Any using (Any; here; there) -open import Data.List.Membership.Propositional -open import Data.List.Membership.Propositional.Properties.Core - using (Any↔; find∘map; map∘find; lose∘find) -open import Data.List.Relation.Binary.Pointwise - using (Pointwise; []; _∷_) -open import Data.Nat using (zero; suc; _<_; z<s; s<s; s≤s) -open import Data.Nat.Properties using (_≟_; ≤∧≢⇒<; ≤-refl; m<n⇒m<1+n) -open import Data.Maybe.Base using (Maybe; just; nothing) -open import Data.Maybe.Relation.Unary.Any as MAny using (just) -open import Data.Product as Prod - using (_×_; _,_; ∃; ∃₂; proj₁; proj₂; uncurry′) -open import Data.Product.Properties -open import Data.Product.Function.NonDependent.Propositional - using (_×-cong_) -import Data.Product.Function.Dependent.Propositional as Σ -open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂; [_,_]′) -open import Data.Sum.Function.Propositional using (_⊎-cong_) -open import Effect.Monad -open import Function.Base -open import Function.Equality using (_⟨$⟩_) -open import Function.Equivalence using (_⇔_; equivalence; Equivalence) -open import Function.Inverse as Inv using (_↔_; inverse; Inverse) -open import Function.Related as Related using (Kind; Related; SK-sym) -open import Level using (Level) -open import Relation.Binary as B hiding (_⇔_) -open import Relation.Binary.PropositionalEquality as P - using (_≡_; refl; inspect) -open import Relation.Unary as U - using (Pred; _⟨×⟩_; _⟨→⟩_) renaming (_⊆_ to _⋐_) -open import Relation.Nullary using (¬_; _because_; does; ofʸ; ofⁿ; yes; no) -open import Relation.Nullary.Decidable using (¬?; decidable-stable) -open import Relation.Nullary.Negation using (contradiction) - -private - open module ListMonad {ℓ} = RawMonad (monad {ℓ = ℓ}) - -private - variable - a b c p q r ℓ : Level - A : Set a - B : Set b - C : Set c - P Q R : Pred A p - x y : A - xs ys : List A - ------------------------------------------------------------------------- --- Equality properties - -lift-resp : ∀ {_≈_ : Rel A ℓ} → P Respects _≈_ → - (Any P) Respects (Pointwise _≈_) -lift-resp resp (x≈y ∷ xs≈ys) (here px) = here (resp x≈y px) -lift-resp resp (x≈y ∷ xs≈ys) (there pxs) = there (lift-resp resp xs≈ys pxs) - -here-injective : ∀ {p q : P x} → here {P = P} {xs = xs} p ≡ here q → p ≡ q -here-injective refl = refl - -there-injective : ∀ {p q : Any P xs} → there {x = x} p ≡ there q → p ≡ q -there-injective refl = refl - ------------------------------------------------------------------------- --- Misc - -¬Any[] : ¬ Any P [] -¬Any[] () - ------------------------------------------------------------------------- --- Any is a congruence - -Any-cong : ∀ {k : Kind} → (∀ x → Related k (P x) (Q x)) → - (∀ {z} → Related k (z ∈ xs) (z ∈ ys)) → - Related k (Any P xs) (Any Q ys) -Any-cong {P = P} {Q = Q} {xs = xs} {ys} P↔Q xs≈ys = - Any P xs ↔⟨ SK-sym Any↔ ⟩ - (∃ λ x → x ∈ xs × P x) ∼⟨ Σ.cong Inv.id (xs≈ys ×-cong P↔Q _) ⟩ - (∃ λ x → x ∈ ys × Q x) ↔⟨ Any↔ ⟩ - Any Q ys ∎ - where open Related.EquationalReasoning - ------------------------------------------------------------------------- --- Any.map - -map-id : ∀ (f : P ⋐ P) → (∀ {x} (p : P x) → f p ≡ p) → - (p : Any P xs) → Any.map f p ≡ p -map-id f hyp (here p) = P.cong here (hyp p) -map-id f hyp (there p) = P.cong there $ map-id f hyp p - -map-∘ : ∀ (f : Q ⋐ R) (g : P ⋐ Q) (p : Any P xs) → - Any.map (f ∘ g) p ≡ Any.map f (Any.map g p) -map-∘ f g (here p) = refl -map-∘ f g (there p) = P.cong there $ map-∘ f g p - ------------------------------------------------------------------------- --- Any.lookup - -lookup-result : ∀ (p : Any P xs) → P (Any.lookup p) -lookup-result (here px) = px -lookup-result (there p) = lookup-result p - -lookup-index : ∀ (p : Any P xs) → P (lookup xs (Any.index p)) -lookup-index (here px) = px -lookup-index (there pxs) = lookup-index pxs - ------------------------------------------------------------------------- --- Swapping - --- Nested occurrences of Any can sometimes be swapped. See also ×↔. - -swap : ∀ {P : A → B → Set ℓ} → - Any (λ x → Any (P x) ys) xs → Any (λ y → Any (flip P y) xs) ys -swap (here pys) = Any.map here pys -swap (there pxys) = Any.map there (swap pxys) - -swap-there : ∀ {P : A → B → Set ℓ} → - (any : Any (λ x → Any (P x) ys) xs) → - swap (Any.map (there {x = x}) any) ≡ there (swap any) -swap-there (here pys) = refl -swap-there (there pxys) = P.cong (Any.map there) (swap-there pxys) - -swap-invol : ∀ {P : A → B → Set ℓ} → - (any : Any (λ x → Any (P x) ys) xs) → - swap (swap any) ≡ any -swap-invol (here (here px)) = refl -swap-invol (here (there pys)) = - P.cong (Any.map there) (swap-invol (here pys)) -swap-invol (there pxys) = - P.trans (swap-there (swap pxys)) (P.cong there (swap-invol pxys)) - -swap↔ : ∀ {P : A → B → Set ℓ} → - Any (λ x → Any (P x) ys) xs ↔ Any (λ y → Any (flip P y) xs) ys -swap↔ = inverse swap swap swap-invol swap-invol - ------------------------------------------------------------------------- --- Lemmas relating Any to ⊥ - -⊥↔Any⊥ : ⊥ ↔ Any (const ⊥) xs -⊥↔Any⊥ = inverse (λ()) (λ p → from p) (λ()) (λ p → from p) - where - from : Any (const ⊥) xs → B - from (there p) = from p - -⊥↔Any[] : ⊥ ↔ Any P [] -⊥↔Any[] = inverse (λ()) (λ()) (λ()) (λ()) - ------------------------------------------------------------------------- --- Lemmas relating Any to ⊤ - --- These introduction and elimination rules are not inverses, though. - -any⁺ : ∀ (p : A → Bool) → Any (T ∘ p) xs → T (any p xs) -any⁺ p (here px) = Equivalence.from T-∨ ⟨$⟩ inj₁ px -any⁺ p (there {x = x} pxs) with p x -... | true = _ -... | false = any⁺ p pxs - -any⁻ : ∀ (p : A → Bool) xs → T (any p xs) → Any (T ∘ p) xs -any⁻ p (x ∷ xs) px∷xs with p x | inspect p x -... | true | P.[ eq ] = here (Equivalence.from T-≡ ⟨$⟩ eq) -... | false | _ = there (any⁻ p xs px∷xs) - -any⇔ : ∀ {p : A → Bool} → Any (T ∘ p) xs ⇔ T (any p xs) -any⇔ = equivalence (any⁺ _) (any⁻ _ _) - ------------------------------------------------------------------------- --- Sums commute with Any - -Any-⊎⁺ : Any P xs ⊎ Any Q xs → Any (λ x → P x ⊎ Q x) xs -Any-⊎⁺ = [ Any.map inj₁ , Any.map inj₂ ]′ - -Any-⊎⁻ : Any (λ x → P x ⊎ Q x) xs → Any P xs ⊎ Any Q xs -Any-⊎⁻ (here (inj₁ p)) = inj₁ (here p) -Any-⊎⁻ (here (inj₂ q)) = inj₂ (here q) -Any-⊎⁻ (there p) = Sum.map there there (Any-⊎⁻ p) - -⊎↔ : (Any P xs ⊎ Any Q xs) ↔ Any (λ x → P x ⊎ Q x) xs -⊎↔ {P = P} {Q = Q} = inverse Any-⊎⁺ Any-⊎⁻ from∘to to∘from - where - from∘to : (p : Any P xs ⊎ Any Q xs) → Any-⊎⁻ (Any-⊎⁺ p) ≡ p - from∘to (inj₁ (here p)) = refl - from∘to (inj₁ (there p)) rewrite from∘to (inj₁ p) = refl - from∘to (inj₂ (here q)) = refl - from∘to (inj₂ (there q)) rewrite from∘to (inj₂ q) = refl - - to∘from : (p : Any (λ x → P x ⊎ Q x) xs) → Any-⊎⁺ (Any-⊎⁻ p) ≡ p - to∘from (here (inj₁ p)) = refl - to∘from (here (inj₂ q)) = refl - to∘from (there p) with Any-⊎⁻ p | to∘from p - to∘from (there .(Any.map inj₁ p)) | inj₁ p | refl = refl - to∘from (there .(Any.map inj₂ q)) | inj₂ q | refl = refl - ------------------------------------------------------------------------- --- Products "commute" with Any. - -Any-×⁺ : Any P xs × Any Q ys → Any (λ x → Any (λ y → P x × Q y) ys) xs -Any-×⁺ (p , q) = Any.map (λ p → Any.map (λ q → (p , q)) q) p - -Any-×⁻ : Any (λ x → Any (λ y → P x × Q y) ys) xs → - Any P xs × Any Q ys -Any-×⁻ pq with Prod.map₂ (Prod.map₂ find) (find pq) -... | (x , x∈xs , y , y∈ys , p , q) = lose x∈xs p , lose y∈ys q - -×↔ : ∀ {xs ys} → - (Any P xs × Any Q ys) ↔ Any (λ x → Any (λ y → P x × Q y) ys) xs -×↔ {P = P} {Q = Q} {xs} {ys} = inverse Any-×⁺ Any-×⁻ from∘to to∘from - where - open P.≡-Reasoning - - from∘to : ∀ pq → Any-×⁻ (Any-×⁺ pq) ≡ pq - from∘to (p , q) = - - Any-×⁻ (Any-×⁺ (p , q)) - - ≡⟨⟩ - - (let (x , x∈xs , pq) = find (Any-×⁺ (p , q)) - (y , y∈ys , p , q) = find pq - in lose x∈xs p , lose y∈ys q) - - ≡⟨ P.cong (λ • → let (x , x∈xs , pq) = • - (y , y∈ys , p , q) = find pq - in lose x∈xs p , lose y∈ys q) - (find∘map p (λ p → Any.map (p ,_) q)) ⟩ - - (let (x , x∈xs , p) = find p - (y , y∈ys , p , q) = find (Any.map (p ,_) q) - in lose x∈xs p , lose y∈ys q) +open import Data.Fin.Base using (Fin; zero; suc) +open import Data.List.Base as List hiding (find) +open import Data.List.Properties using (ʳ++-defn) +open import Data.List.Effectful as Listₑ using (monad) +open import Data.List.Relation.Unary.Any as Any using (Any; here; there) +open import Data.List.Membership.Propositional +open import Data.List.Membership.Propositional.Properties.Core + using (Any↔; find∘map; map∘find; lose∘find) +open import Data.List.Relation.Binary.Pointwise + using (Pointwise; []; _∷_) +open import Data.Nat using (zero; suc; _<_; z<s; s<s; s≤s) +open import Data.Nat.Properties using (_≟_; ≤∧≢⇒<; ≤-refl; m<n⇒m<1+n) +open import Data.Maybe.Base using (Maybe; just; nothing) +open import Data.Maybe.Relation.Unary.Any as MAny using (just) +open import Data.Product.Base as Prod + using (_×_; _,_; ∃; ∃₂; proj₁; proj₂; uncurry′) +open import Data.Product.Properties +open import Data.Product.Function.NonDependent.Propositional + using (_×-cong_) +import Data.Product.Function.Dependent.Propositional as Σ +open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂; [_,_]′) +open import Data.Sum.Function.Propositional using (_⊎-cong_) +open import Effect.Monad +open import Function.Base +open import Function.Bundles +import Function.Properties.Inverse as Inverse +open import Function.Related.Propositional as Related using (Kind; Related) +open import Level using (Level) +open import Relation.Binary.Core using (Rel; REL) +open import Relation.Binary.Definitions as B +open import Relation.Binary.PropositionalEquality.Core as P + using (_≡_; refl) +open import Relation.Binary.PropositionalEquality.Properties + using (module ≡-Reasoning) +open import Relation.Unary as U + using (Pred; _⟨×⟩_; _⟨→⟩_) renaming (_⊆_ to _⋐_) +open import Relation.Nullary using (¬_; _because_; does; ofʸ; ofⁿ; yes; no) +open import Relation.Nullary.Decidable using (¬?; decidable-stable) +open import Relation.Nullary.Negation using (contradiction) + +private + open module ListMonad {ℓ} = RawMonad (monad {ℓ = ℓ}) + +private + variable + a b c p q r ℓ : Level + A B C : Set a + P Q R : Pred A p + x y : A + xs ys : List A + +------------------------------------------------------------------------ +-- Equality properties + +lift-resp : ∀ {_≈_ : Rel A ℓ} → P Respects _≈_ → + (Any P) Respects (Pointwise _≈_) +lift-resp resp (x≈y ∷ xs≈ys) (here px) = here (resp x≈y px) +lift-resp resp (x≈y ∷ xs≈ys) (there pxs) = there (lift-resp resp xs≈ys pxs) + +here-injective : ∀ {p q : P x} → here {P = P} {xs = xs} p ≡ here q → p ≡ q +here-injective refl = refl + +there-injective : ∀ {p q : Any P xs} → there {x = x} p ≡ there q → p ≡ q +there-injective refl = refl + +------------------------------------------------------------------------ +-- Misc + +¬Any[] : ¬ Any P [] +¬Any[] () + +------------------------------------------------------------------------ +-- Any is a congruence + +Any-cong : ∀ {k : Kind} → (∀ x → Related k (P x) (Q x)) → + (∀ {z} → Related k (z ∈ xs) (z ∈ ys)) → + Related k (Any P xs) (Any Q ys) +Any-cong {P = P} {Q = Q} {xs = xs} {ys} P↔Q xs≈ys = + Any P xs ↔⟨ Related.SK-sym Any↔ ⟩ + (∃ λ x → x ∈ xs × P x) ∼⟨ Σ.cong Inverse.↔-refl (xs≈ys ×-cong P↔Q _) ⟩ + (∃ λ x → x ∈ ys × Q x) ↔⟨ Any↔ ⟩ + Any Q ys ∎ + where open Related.EquationalReasoning + +------------------------------------------------------------------------ +-- Any.map + +map-id : ∀ (f : P ⋐ P) → (∀ {x} (p : P x) → f p ≡ p) → + (p : Any P xs) → Any.map f p ≡ p +map-id f hyp (here p) = P.cong here (hyp p) +map-id f hyp (there p) = P.cong there $ map-id f hyp p + +map-∘ : ∀ (f : Q ⋐ R) (g : P ⋐ Q) (p : Any P xs) → + Any.map (f ∘ g) p ≡ Any.map f (Any.map g p) +map-∘ f g (here p) = refl +map-∘ f g (there p) = P.cong there $ map-∘ f g p + +------------------------------------------------------------------------ +-- Any.lookup + +lookup-result : ∀ (p : Any P xs) → P (Any.lookup p) +lookup-result (here px) = px +lookup-result (there p) = lookup-result p + +lookup-index : ∀ (p : Any P xs) → P (lookup xs (Any.index p)) +lookup-index (here px) = px +lookup-index (there pxs) = lookup-index pxs + +------------------------------------------------------------------------ +-- Swapping + +-- Nested occurrences of Any can sometimes be swapped. See also ×↔. + +swap : ∀ {P : A → B → Set ℓ} → + Any (λ x → Any (P x) ys) xs → Any (λ y → Any (flip P y) xs) ys +swap (here pys) = Any.map here pys +swap (there pxys) = Any.map there (swap pxys) + +swap-there : ∀ {P : A → B → Set ℓ} → + (any : Any (λ x → Any (P x) ys) xs) → + swap (Any.map (there {x = x}) any) ≡ there (swap any) +swap-there (here pys) = refl +swap-there (there pxys) = P.cong (Any.map there) (swap-there pxys) + +swap-invol : ∀ {P : A → B → Set ℓ} → + (any : Any (λ x → Any (P x) ys) xs) → + swap (swap any) ≡ any +swap-invol (here (here px)) = refl +swap-invol (here (there pys)) = + P.cong (Any.map there) (swap-invol (here pys)) +swap-invol (there pxys) = + P.trans (swap-there (swap pxys)) (P.cong there (swap-invol pxys)) + +swap↔ : ∀ {P : A → B → Set ℓ} → + Any (λ x → Any (P x) ys) xs ↔ Any (λ y → Any (flip P y) xs) ys +swap↔ = mk↔ₛ′ swap swap swap-invol swap-invol + +------------------------------------------------------------------------ +-- Lemmas relating Any to ⊥ + +⊥↔Any⊥ : ⊥ ↔ Any (const ⊥) xs +⊥↔Any⊥ = mk↔ₛ′ (λ()) (λ p → from p) (λ p → from p) (λ()) + where + from : Any (const ⊥) xs → B + from (there p) = from p + +⊥↔Any[] : ⊥ ↔ Any P [] +⊥↔Any[] = mk↔ₛ′ (λ()) (λ()) (λ()) (λ()) + +------------------------------------------------------------------------ +-- Lemmas relating Any to ⊤ + +-- These introduction and elimination rules are not inverses, though. + +any⁺ : ∀ (p : A → Bool) → Any (T ∘ p) xs → T (any p xs) +any⁺ p (here px) = Equivalence.from T-∨ (inj₁ px) +any⁺ p (there {x = x} pxs) with p x +... | true = _ +... | false = any⁺ p pxs + +any⁻ : ∀ (p : A → Bool) xs → T (any p xs) → Any (T ∘ p) xs +any⁻ p (x ∷ xs) px∷xs with p x in eq +... | true = here (Equivalence.from T-≡ eq) +... | false = there (any⁻ p xs px∷xs) + +any⇔ : ∀ {p : A → Bool} → Any (T ∘ p) xs ⇔ T (any p xs) +any⇔ = mk⇔ (any⁺ _) (any⁻ _ _) + +------------------------------------------------------------------------ +-- Sums commute with Any + +Any-⊎⁺ : Any P xs ⊎ Any Q xs → Any (λ x → P x ⊎ Q x) xs +Any-⊎⁺ = [ Any.map inj₁ , Any.map inj₂ ]′ + +Any-⊎⁻ : Any (λ x → P x ⊎ Q x) xs → Any P xs ⊎ Any Q xs +Any-⊎⁻ (here (inj₁ p)) = inj₁ (here p) +Any-⊎⁻ (here (inj₂ q)) = inj₂ (here q) +Any-⊎⁻ (there p) = Sum.map there there (Any-⊎⁻ p) + +⊎↔ : (Any P xs ⊎ Any Q xs) ↔ Any (λ x → P x ⊎ Q x) xs +⊎↔ {P = P} {Q = Q} = mk↔ₛ′ Any-⊎⁺ Any-⊎⁻ to∘from from∘to + where + from∘to : (p : Any P xs ⊎ Any Q xs) → Any-⊎⁻ (Any-⊎⁺ p) ≡ p + from∘to (inj₁ (here p)) = refl + from∘to (inj₁ (there p)) rewrite from∘to (inj₁ p) = refl + from∘to (inj₂ (here q)) = refl + from∘to (inj₂ (there q)) rewrite from∘to (inj₂ q) = refl + + to∘from : (p : Any (λ x → P x ⊎ Q x) xs) → Any-⊎⁺ (Any-⊎⁻ p) ≡ p + to∘from (here (inj₁ p)) = refl + to∘from (here (inj₂ q)) = refl + to∘from (there p) with Any-⊎⁻ p | to∘from p + ... | inj₁ p | refl = refl + ... | inj₂ q | refl = refl + +------------------------------------------------------------------------ +-- Products "commute" with Any. + +Any-×⁺ : Any P xs × Any Q ys → Any (λ x → Any (λ y → P x × Q y) ys) xs +Any-×⁺ (p , q) = Any.map (λ p → Any.map (λ q → (p , q)) q) p + +Any-×⁻ : Any (λ x → Any (λ y → P x × Q y) ys) xs → + Any P xs × Any Q ys +Any-×⁻ pq with Prod.map₂ (Prod.map₂ find) (find pq) +... | (x , x∈xs , y , y∈ys , p , q) = lose x∈xs p , lose y∈ys q + +×↔ : ∀ {xs ys} → + (Any P xs × Any Q ys) ↔ Any (λ x → Any (λ y → P x × Q y) ys) xs +×↔ {P = P} {Q = Q} {xs} {ys} = mk↔ₛ′ Any-×⁺ Any-×⁻ to∘from from∘to + where + open ≡-Reasoning + + from∘to : ∀ pq → Any-×⁻ (Any-×⁺ pq) ≡ pq + from∘to (p , q) = + + Any-×⁻ (Any-×⁺ (p , q)) + + ≡⟨⟩ + + (let (x , x∈xs , pq) = find (Any-×⁺ (p , q)) + (y , y∈ys , p , q) = find pq + in lose x∈xs p , lose y∈ys q) + + ≡⟨ P.cong (λ • → let (x , x∈xs , pq) = • + (y , y∈ys , p , q) = find pq + in lose x∈xs p , lose y∈ys q) + (find∘map p (λ p → Any.map (p ,_) q)) ⟩ + + (let (x , x∈xs , p) = find p + (y , y∈ys , p , q) = find (Any.map (p ,_) q) + in lose x∈xs p , lose y∈ys q) + + ≡⟨ P.cong (λ • → let (x , x∈xs , p) = find p + (y , y∈ys , p , q) = • + in lose x∈xs p , lose y∈ys q) + (find∘map q (proj₂ (proj₂ (find p)) ,_)) ⟩ - ≡⟨ P.cong (λ • → let (x , x∈xs , p) = find p - (y , y∈ys , p , q) = • - in lose x∈xs p , lose y∈ys q) - (find∘map q (proj₂ (proj₂ (find p)) ,_)) ⟩ + (let (x , x∈xs , p) = find p + (y , y∈ys , q) = find q + in lose x∈xs p , lose y∈ys q) + + ≡⟨ P.cong₂ _,_ (lose∘find p) (lose∘find q) ⟩ - (let (x , x∈xs , p) = find p - (y , y∈ys , q) = find q - in lose x∈xs p , lose y∈ys q) + (p , q) ∎ - ≡⟨ P.cong₂ _,_ (lose∘find p) (lose∘find q) ⟩ - - (p , q) ∎ - - - to∘from : ∀ pq → Any-×⁺ {xs = xs} (Any-×⁻ pq) ≡ pq - to∘from pq - with find pq - | (λ (f : (proj₁ (find pq) ≡_) ⋐ _) → map∘find pq {f}) - ... | (x , x∈xs , pq′) | lem₁ - with find pq′ - | (λ (f : (proj₁ (find pq′) ≡_) ⋐ _) → map∘find pq′ {f}) - ... | (y , y∈ys , p , q) | lem₂ - rewrite P.sym $ map-∘ {R = λ x → Any (λ y → P x × Q y) ys} - (λ p → Any.map (λ q → p , q) (lose y∈ys q)) - (λ y → P.subst P y p) - x∈xs - = lem₁ _ helper - where - helper : Any.map (λ q → p , q) (lose y∈ys q) ≡ pq′ - helper rewrite P.sym $ map-∘ (λ q → p , q) - (λ y → P.subst Q y q) - y∈ys - = lem₂ _ refl - ------------------------------------------------------------------------- --- Half-applied product commutes with Any. - -module _ {_~_ : REL A B r} where - - Any-Σ⁺ʳ : (∃ λ x → Any (_~ x) xs) → Any (∃ ∘ _~_) xs - Any-Σ⁺ʳ (b , here px) = here (b , px) - Any-Σ⁺ʳ (b , there pxs) = there (Any-Σ⁺ʳ (b , pxs)) - - Any-Σ⁻ʳ : Any (∃ ∘ _~_) xs → ∃ λ x → Any (_~ x) xs - Any-Σ⁻ʳ (here (b , x)) = b , here x - Any-Σ⁻ʳ (there xs) = Prod.map₂ there $ Any-Σ⁻ʳ xs - ------------------------------------------------------------------------- --- Invertible introduction (⁺) and elimination (⁻) rules for various --- list functions ------------------------------------------------------------------------- - ------------------------------------------------------------------------- --- singleton - -singleton⁺ : P x → Any P [ x ] -singleton⁺ Px = here Px - -singleton⁻ : Any P [ x ] → P x -singleton⁻ (here Px) = Px - ------------------------------------------------------------------------- --- map - -module _ {f : A → B} where - - map⁺ : Any (P ∘ f) xs → Any P (List.map f xs) - map⁺ (here p) = here p - map⁺ (there p) = there $ map⁺ p - - map⁻ : Any P (List.map f xs) → Any (P ∘ f) xs - map⁻ {xs = x ∷ xs} (here p) = here p - map⁻ {xs = x ∷ xs} (there p) = there $ map⁻ p - - map⁺∘map⁻ : (p : Any P (List.map f xs)) → map⁺ (map⁻ p) ≡ p - map⁺∘map⁻ {xs = x ∷ xs} (here p) = refl - map⁺∘map⁻ {xs = x ∷ xs} (there p) = P.cong there (map⁺∘map⁻ p) - - map⁻∘map⁺ : ∀ (P : Pred B p) → - (p : Any (P ∘ f) xs) → map⁻ {P = P} (map⁺ p) ≡ p - map⁻∘map⁺ P (here p) = refl - map⁻∘map⁺ P (there p) = P.cong there (map⁻∘map⁺ P p) - - map↔ : Any (P ∘ f) xs ↔ Any P (List.map f xs) - map↔ = inverse map⁺ map⁻ (map⁻∘map⁺ _) map⁺∘map⁻ - - gmap : P ⋐ Q ∘ f → Any P ⋐ Any Q ∘ map f - gmap g = map⁺ ∘ Any.map g - ------------------------------------------------------------------------- --- mapMaybe - -module _ (f : A → Maybe B) where - - mapMaybe⁺ : ∀ xs → Any (MAny.Any P) (map f xs) → Any P (mapMaybe f xs) - mapMaybe⁺ (x ∷ xs) ps with f x | ps - ... | nothing | there pxs = mapMaybe⁺ xs pxs - ... | just _ | here (just py) = here py - ... | just _ | there pxs = there (mapMaybe⁺ xs pxs) - ------------------------------------------------------------------------- --- _++_ - -module _ {P : A → Set p} where - - ++⁺ˡ : Any P xs → Any P (xs ++ ys) - ++⁺ˡ (here p) = here p - ++⁺ˡ (there p) = there (++⁺ˡ p) - - ++⁺ʳ : ∀ xs {ys} → Any P ys → Any P (xs ++ ys) - ++⁺ʳ [] p = p - ++⁺ʳ (x ∷ xs) p = there (++⁺ʳ xs p) - - ++⁻ : ∀ xs {ys} → Any P (xs ++ ys) → Any P xs ⊎ Any P ys - ++⁻ [] p = inj₂ p - ++⁻ (x ∷ xs) (here p) = inj₁ (here p) - ++⁻ (x ∷ xs) (there p) = Sum.map there id (++⁻ xs p) - - ++⁺∘++⁻ : ∀ xs {ys} (p : Any P (xs ++ ys)) → [ ++⁺ˡ , ++⁺ʳ xs ]′ (++⁻ xs p) ≡ p - ++⁺∘++⁻ [] p = refl - ++⁺∘++⁻ (x ∷ xs) (here p) = refl - ++⁺∘++⁻ (x ∷ xs) (there p) with ++⁻ xs p | ++⁺∘++⁻ xs p - ... | inj₁ p′ | ih = P.cong there ih - ... | inj₂ p′ | ih = P.cong there ih - - ++⁻∘++⁺ : ∀ xs {ys} (p : Any P xs ⊎ Any P ys) → - ++⁻ xs ([ ++⁺ˡ , ++⁺ʳ xs ]′ p) ≡ p - ++⁻∘++⁺ [] (inj₂ p) = refl - ++⁻∘++⁺ (x ∷ xs) (inj₁ (here p)) = refl - ++⁻∘++⁺ (x ∷ xs) {ys} (inj₁ (there p)) rewrite ++⁻∘++⁺ xs {ys} (inj₁ p) = refl - ++⁻∘++⁺ (x ∷ xs) (inj₂ p) rewrite ++⁻∘++⁺ xs (inj₂ p) = refl - - ++↔ : ∀ {xs ys} → (Any P xs ⊎ Any P ys) ↔ Any P (xs ++ ys) - ++↔ {xs = xs} = inverse [ ++⁺ˡ , ++⁺ʳ xs ]′ (++⁻ xs) (++⁻∘++⁺ xs) (++⁺∘++⁻ xs) - - ++-comm : ∀ xs ys → Any P (xs ++ ys) → Any P (ys ++ xs) - ++-comm xs ys = [ ++⁺ʳ ys , ++⁺ˡ ]′ ∘ ++⁻ xs - - ++-comm∘++-comm : ∀ xs {ys} (p : Any P (xs ++ ys)) → - ++-comm ys xs (++-comm xs ys p) ≡ p - ++-comm∘++-comm [] {ys} p - rewrite ++⁻∘++⁺ ys {ys = []} (inj₁ p) = refl - ++-comm∘++-comm (x ∷ xs) {ys} (here p) - rewrite ++⁻∘++⁺ ys {ys = x ∷ xs} (inj₂ (here p)) = refl - ++-comm∘++-comm (x ∷ xs) (there p) with ++⁻ xs p | ++-comm∘++-comm xs p - ++-comm∘++-comm (x ∷ xs) {ys} (there .([ ++⁺ʳ xs , ++⁺ˡ ]′ (++⁻ ys (++⁺ʳ ys p)))) - | inj₁ p | refl - rewrite ++⁻∘++⁺ ys (inj₂ p) - | ++⁻∘++⁺ ys (inj₂ $ there {x = x} p) = refl - ++-comm∘++-comm (x ∷ xs) {ys} (there .([ ++⁺ʳ xs , ++⁺ˡ ]′ (++⁻ ys (++⁺ˡ p)))) - | inj₂ p | refl - rewrite ++⁻∘++⁺ ys {ys = xs} (inj₁ p) - | ++⁻∘++⁺ ys {ys = x ∷ xs} (inj₁ p) = refl - - ++↔++ : ∀ xs ys → Any P (xs ++ ys) ↔ Any P (ys ++ xs) - ++↔++ xs ys = inverse (++-comm xs ys) (++-comm ys xs) - (++-comm∘++-comm xs) (++-comm∘++-comm ys) - - ++-insert : ∀ xs {ys} → P x → Any P (xs ++ [ x ] ++ ys) - ++-insert xs Px = ++⁺ʳ xs (++⁺ˡ (singleton⁺ Px)) - ------------------------------------------------------------------------- --- concat - -module _ {P : A → Set p} where - - concat⁺ : ∀ {xss} → Any (Any P) xss → Any P (concat xss) - concat⁺ (here p) = ++⁺ˡ p - concat⁺ (there {x = xs} p) = ++⁺ʳ xs (concat⁺ p) - - concat⁻ : ∀ xss → Any P (concat xss) → Any (Any P) xss - concat⁻ ([] ∷ xss) p = there $ concat⁻ xss p - concat⁻ ((x ∷ xs) ∷ xss) (here p) = here (here p) - concat⁻ ((x ∷ xs) ∷ xss) (there p) with concat⁻ (xs ∷ xss) p - ... | here p′ = here (there p′) - ... | there p′ = there p′ - - concat⁻∘++⁺ˡ : ∀ {xs} xss (p : Any P xs) → - concat⁻ (xs ∷ xss) (++⁺ˡ p) ≡ here p - concat⁻∘++⁺ˡ xss (here p) = refl - concat⁻∘++⁺ˡ xss (there p) rewrite concat⁻∘++⁺ˡ xss p = refl - - concat⁻∘++⁺ʳ : ∀ xs xss (p : Any P (concat xss)) → - concat⁻ (xs ∷ xss) (++⁺ʳ xs p) ≡ there (concat⁻ xss p) - concat⁻∘++⁺ʳ [] xss p = refl - concat⁻∘++⁺ʳ (x ∷ xs) xss p rewrite concat⁻∘++⁺ʳ xs xss p = refl - - concat⁺∘concat⁻ : ∀ xss (p : Any P (concat xss)) → - concat⁺ (concat⁻ xss p) ≡ p - concat⁺∘concat⁻ ([] ∷ xss) p = concat⁺∘concat⁻ xss p - concat⁺∘concat⁻ ((x ∷ xs) ∷ xss) (here p) = refl - concat⁺∘concat⁻ ((x ∷ xs) ∷ xss) (there p) - with p | concat⁻ (xs ∷ xss) p | concat⁺∘concat⁻ (xs ∷ xss) p - ... | .(++⁺ˡ p′) | here p′ | refl = refl - ... | .(++⁺ʳ xs (concat⁺ p′)) | there p′ | refl = refl - - concat⁻∘concat⁺ : ∀ {xss} (p : Any (Any P) xss) → concat⁻ xss (concat⁺ p) ≡ p - concat⁻∘concat⁺ (here p) = concat⁻∘++⁺ˡ _ p - concat⁻∘concat⁺ (there {x = xs} {xs = xss} p) - rewrite concat⁻∘++⁺ʳ xs xss (concat⁺ p) = - P.cong there $ concat⁻∘concat⁺ p - - concat↔ : ∀ {xss} → Any (Any P) xss ↔ Any P (concat xss) - concat↔ {xss} = inverse concat⁺ (concat⁻ xss) concat⁻∘concat⁺ (concat⁺∘concat⁻ xss) - ------------------------------------------------------------------------- --- cartesianProductWith - -module _ (f : A → B → C) where - - cartesianProductWith⁺ : (∀ {x y} → P x → Q y → R (f x y)) → - Any P xs → Any Q ys → - Any R (cartesianProductWith f xs ys) - cartesianProductWith⁺ pres (here px) qys = ++⁺ˡ (map⁺ (Any.map (pres px) qys)) - cartesianProductWith⁺ pres (there qxs) qys = ++⁺ʳ _ (cartesianProductWith⁺ pres qxs qys) - - cartesianProductWith⁻ : (∀ {x y} → R (f x y) → P x × Q y) → ∀ xs ys → - Any R (cartesianProductWith f xs ys) → - Any P xs × Any Q ys - cartesianProductWith⁻ resp (x ∷ xs) ys Rxsys with ++⁻ (map (f x) ys) Rxsys - cartesianProductWith⁻ resp (x ∷ xs) ys Rxsys | inj₁ Rfxys with map⁻ Rfxys - ... | Rxys = here (proj₁ (resp (proj₂ (Any.satisfied Rxys)))) , Any.map (proj₂ ∘ resp) Rxys - cartesianProductWith⁻ resp (x ∷ xs) ys Rxsys | inj₂ Rc with cartesianProductWith⁻ resp xs ys Rc - ... | pxs , qys = there pxs , qys - ------------------------------------------------------------------------- --- cartesianProduct - -cartesianProduct⁺ : Any P xs → Any Q ys → - Any (P ⟨×⟩ Q) (cartesianProduct xs ys) -cartesianProduct⁺ = cartesianProductWith⁺ _,_ _,_ - -cartesianProduct⁻ : ∀ xs ys → Any (P ⟨×⟩ Q) (cartesianProduct xs ys) → - Any P xs × Any Q ys -cartesianProduct⁻ = cartesianProductWith⁻ _,_ id - ------------------------------------------------------------------------- --- applyUpTo - -applyUpTo⁺ : ∀ f {i n} → P (f i) → i < n → Any P (applyUpTo f n) -applyUpTo⁺ _ p z<s = here p -applyUpTo⁺ f p (s<s i<n@(s≤s _)) = - there (applyUpTo⁺ (f ∘ suc) p i<n) - -applyUpTo⁻ : ∀ f {n} → Any P (applyUpTo f n) → - ∃ λ i → i < n × P (f i) -applyUpTo⁻ f {suc n} (here p) = zero , z<s , p -applyUpTo⁻ f {suc n} (there p) with applyUpTo⁻ (f ∘ suc) p -... | i , i<n , q = suc i , s<s i<n , q - ------------------------------------------------------------------------- --- applyDownFrom - -module _ {P : A → Set p} where - - applyDownFrom⁺ : ∀ f {i n} → P (f i) → i < n → Any P (applyDownFrom f n) - applyDownFrom⁺ f {i} {suc n} p (s≤s i≤n) with i ≟ n - ... | yes P.refl = here p - ... | no i≢n = there (applyDownFrom⁺ f p (≤∧≢⇒< i≤n i≢n)) - - applyDownFrom⁻ : ∀ f {n} → Any P (applyDownFrom f n) → - ∃ λ i → i < n × P (f i) - applyDownFrom⁻ f {suc n} (here p) = n , ≤-refl , p - applyDownFrom⁻ f {suc n} (there p) with applyDownFrom⁻ f p - ... | i , i<n , pf = i , m<n⇒m<1+n i<n , pf - ------------------------------------------------------------------------- --- tabulate - -tabulate⁺ : ∀ {n} {f : Fin n → A} i → P (f i) → Any P (tabulate f) -tabulate⁺ zero p = here p -tabulate⁺ (suc i) p = there (tabulate⁺ i p) - -tabulate⁻ : ∀ {n} {f : Fin n → A} → Any P (tabulate f) → ∃ λ i → P (f i) -tabulate⁻ {n = suc _} (here p) = zero , p -tabulate⁻ {n = suc _} (there p) = Prod.map suc id (tabulate⁻ p) - ------------------------------------------------------------------------- --- filter - -module _ (Q? : U.Decidable Q) where - - filter⁺ : (p : Any P xs) → Any P (filter Q? xs) ⊎ ¬ Q (Any.lookup p) - filter⁺ {xs = x ∷ _} (here px) with Q? x - ... | true because _ = inj₁ (here px) - ... | false because ofⁿ ¬Qx = inj₂ ¬Qx - filter⁺ {xs = x ∷ _} (there p) with does (Q? x) - ... | true = Sum.map₁ there (filter⁺ p) - ... | false = filter⁺ p - - filter⁻ : Any P (filter Q? xs) → Any P xs - filter⁻ {xs = x ∷ xs} p with does (Q? x) | p - ... | true | here px = here px - ... | true | there pxs = there (filter⁻ pxs) - ... | false | pxs = there (filter⁻ pxs) - ------------------------------------------------------------------------- --- derun and deduplicate - -module _ {R : A → A → Set r} (R? : B.Decidable R) where - - private - derun⁺-aux : ∀ x xs → P Respects R → P x → Any P (derun R? (x ∷ xs)) - derun⁺-aux x [] resp Px = here Px - derun⁺-aux x (y ∷ xs) resp Px with R? x y - ... | true because ofʸ Rxy = derun⁺-aux y xs resp (resp Rxy Px) - ... | false because _ = here Px - - derun⁺ : P Respects R → Any P xs → Any P (derun R? xs) - derun⁺ {xs = x ∷ xs} resp (here px) = derun⁺-aux x xs resp px - derun⁺ {xs = x ∷ y ∷ xs} resp (there pxs) with does (R? x y) - ... | true = derun⁺ resp pxs - ... | false = there (derun⁺ resp pxs) - - deduplicate⁺ : ∀ {xs} → P Respects (flip R) → Any P xs → Any P (deduplicate R? xs) - deduplicate⁺ {xs = x ∷ xs} resp (here px) = here px - deduplicate⁺ {xs = x ∷ xs} resp (there pxs) - with filter⁺ (¬? ∘ R? x) (deduplicate⁺ resp pxs) - ... | inj₁ p = there p - ... | inj₂ ¬¬q with decidable-stable (R? x (Any.lookup (deduplicate⁺ resp pxs))) ¬¬q - ... | q = here (resp q (lookup-result (deduplicate⁺ resp pxs))) - - private - derun⁻-aux : Any P (derun R? (x ∷ xs)) → Any P (x ∷ xs) - derun⁻-aux {x = x} {[]} (here px) = here px - derun⁻-aux {x = x} {y ∷ _} p[x∷y∷xs] with does (R? x y) | p[x∷y∷xs] - ... | true | p[y∷xs] = there (derun⁻-aux p[y∷xs]) - ... | false | here px = here px - ... | false | there p[y∷xs]! = there (derun⁻-aux p[y∷xs]!) - - derun⁻ : Any P (derun R? xs) → Any P xs - derun⁻ {xs = x ∷ xs} p[x∷xs]! = derun⁻-aux p[x∷xs]! - - deduplicate⁻ : Any P (deduplicate R? xs) → Any P xs - deduplicate⁻ {xs = x ∷ _} (here px) = here px - deduplicate⁻ {xs = x ∷ _} (there pxs!) = there (deduplicate⁻ (filter⁻ (¬? ∘ R? x) pxs!)) - ------------------------------------------------------------------------- --- mapWith∈. - -module _ {P : B → Set p} where - - mapWith∈⁺ : ∀ {xs : List A} (f : ∀ {x} → x ∈ xs → B) → - (∃₂ λ x (x∈xs : x ∈ xs) → P (f x∈xs)) → - Any P (mapWith∈ xs f) - mapWith∈⁺ f (_ , here refl , p) = here p - mapWith∈⁺ f (_ , there x∈xs , p) = - there $ mapWith∈⁺ (f ∘ there) (_ , x∈xs , p) - - mapWith∈⁻ : ∀ (xs : List A) (f : ∀ {x} → x ∈ xs → B) → - Any P (mapWith∈ xs f) → - ∃₂ λ x (x∈xs : x ∈ xs) → P (f x∈xs) - mapWith∈⁻ (y ∷ xs) f (here p) = (y , here refl , p) - mapWith∈⁻ (y ∷ xs) f (there p) = - Prod.map₂ (Prod.map there id) $ mapWith∈⁻ xs (f ∘ there) p - - mapWith∈↔ : ∀ {xs : List A} {f : ∀ {x} → x ∈ xs → B} → - (∃₂ λ x (x∈xs : x ∈ xs) → P (f x∈xs)) ↔ Any P (mapWith∈ xs f) - mapWith∈↔ = inverse (mapWith∈⁺ _) (mapWith∈⁻ _ _) (from∘to _) (to∘from _ _) - where - from∘to : ∀ {xs : List A} (f : ∀ {x} → x ∈ xs → B) - (p : ∃₂ λ x (x∈xs : x ∈ xs) → P (f x∈xs)) → - mapWith∈⁻ xs f (mapWith∈⁺ f p) ≡ p - from∘to f (_ , here refl , p) = refl - from∘to f (_ , there x∈xs , p) - rewrite from∘to (f ∘ there) (_ , x∈xs , p) = refl - - to∘from : ∀ (xs : List A) (f : ∀ {x} → x ∈ xs → B) - (p : Any P (mapWith∈ xs f)) → - mapWith∈⁺ f (mapWith∈⁻ xs f p) ≡ p - to∘from (y ∷ xs) f (here p) = refl - to∘from (y ∷ xs) f (there p) = - P.cong there $ to∘from xs (f ∘ there) p - ------------------------------------------------------------------------- --- reverse - -reverseAcc⁺ : ∀ acc xs → Any P acc ⊎ Any P xs → Any P (reverseAcc acc xs) -reverseAcc⁺ acc [] (inj₁ ps) = ps -reverseAcc⁺ acc (x ∷ xs) (inj₁ ps) = reverseAcc⁺ (x ∷ acc) xs (inj₁ (there ps)) -reverseAcc⁺ acc (x ∷ xs) (inj₂ (here px)) = reverseAcc⁺ (x ∷ acc) xs (inj₁ (here px)) -reverseAcc⁺ acc (x ∷ xs) (inj₂ (there y)) = reverseAcc⁺ (x ∷ acc) xs (inj₂ y) - -reverseAcc⁻ : ∀ acc xs → Any P (reverseAcc acc xs) → Any P acc ⊎ Any P xs -reverseAcc⁻ acc [] ps = inj₁ ps -reverseAcc⁻ acc (x ∷ xs) ps rewrite ʳ++-defn xs {x ∷ acc} with ++⁻ (reverseAcc [] xs) ps -... | inj₂ (here p') = inj₂ (here p') -... | inj₂ (there ps') = inj₁ ps' -... | inj₁ ps' with reverseAcc⁻ [] xs ps' -... | inj₂ ps'' = inj₂ (there ps'') - -reverse⁺ : Any P xs → Any P (reverse xs) -reverse⁺ ps = reverseAcc⁺ [] _ (inj₂ ps) - -reverse⁻ : Any P (reverse xs) → Any P xs -reverse⁻ ps with reverseAcc⁻ [] _ ps -... | inj₂ ps' = ps' - ------------------------------------------------------------------------- --- pure - -module _ {P : A → Set p} where - - pure⁺ : P x → Any P (pure x) - pure⁺ = here - - pure⁻ : Any P (pure x) → P x - pure⁻ (here p) = p - - pure⁺∘pure⁻ : (p : Any P (pure x)) → pure⁺ (pure⁻ p) ≡ p - pure⁺∘pure⁻ (here p) = refl - - pure⁻∘pure⁺ : (p : P x) → pure⁻ (pure⁺ p) ≡ p - pure⁻∘pure⁺ p = refl - - pure↔ : P x ↔ Any P (pure x) - pure↔ = inverse pure⁺ pure⁻ pure⁻∘pure⁺ pure⁺∘pure⁻ - ------------------------------------------------------------------------- --- _∷_ - -module _ (P : Pred A p) where - - ∷↔ : (P x ⊎ Any P xs) ↔ Any P (x ∷ xs) - ∷↔ {x = x} {xs} = - (P x ⊎ Any P xs) ↔⟨ pure↔ {P = P} ⊎-cong (Any P xs ∎) ⟩ - (Any P [ x ] ⊎ Any P xs) ↔⟨ ++↔ {P = P} {xs = [ x ]} ⟩ - Any P (x ∷ xs) ∎ - where open Related.EquationalReasoning - ------------------------------------------------------------------------- --- _>>=_ - -module _ {A B : Set ℓ} {P : B → Set p} {f : A → List B} where - - >>=↔ : Any (Any P ∘ f) xs ↔ Any P (xs >>= f) - >>=↔ {xs = xs} = - Any (Any P ∘ f) xs ↔⟨ map↔ ⟩ - Any (Any P) (List.map f xs) ↔⟨ concat↔ ⟩ - Any P (xs >>= f) ∎ - where open Related.EquationalReasoning - ------------------------------------------------------------------------- --- _⊛_ - -⊛↔ : ∀ {P : B → Set ℓ} {fs : List (A → B)} {xs : List A} → - Any (λ f → Any (P ∘ f) xs) fs ↔ Any P (fs ⊛ xs) -⊛↔ {P = P} {fs} {xs} = - Any (λ f → Any (P ∘ f) xs) fs ↔⟨ Any-cong (λ _ → Any-cong (λ _ → pure↔) (_ ∎)) (_ ∎) ⟩ - Any (λ f → Any (Any P ∘ pure ∘ f) xs) fs ↔⟨ Any-cong (λ _ → >>=↔ ) (_ ∎) ⟩ - Any (λ f → Any P (xs >>= pure ∘ f)) fs ↔⟨ >>=↔ ⟩ - Any P (fs >>= λ f → xs >>= λ x → pure (f x)) ≡˘⟨ P.cong (Any P) (Listₑ.Applicative.unfold-⊛ fs xs) ⟩ - Any P (fs ⊛ xs) ∎ - where open Related.EquationalReasoning - --- An alternative introduction rule for _⊛_ - -⊛⁺′ : ∀ {P : A → Set ℓ} {Q : B → Set ℓ} {fs : List (A → B)} {xs} → - Any (P ⟨→⟩ Q) fs → Any P xs → Any Q (fs ⊛ xs) -⊛⁺′ pq p = - Inverse.to ⊛↔ ⟨$⟩ - Any.map (λ pq → Any.map (λ {x} → pq {x}) p) pq - ------------------------------------------------------------------------- --- _⊗_ - -⊗↔ : {P : A × B → Set ℓ} {xs : List A} {ys : List B} → - Any (λ x → Any (λ y → P (x , y)) ys) xs ↔ Any P (xs ⊗ ys) -⊗↔ {P = P} {xs} {ys} = - Any (λ x → Any (λ y → P (x , y)) ys) xs ↔⟨ pure↔ ⟩ - Any (λ _,_ → Any (λ x → Any (λ y → P (x , y)) ys) xs) (pure _,_) ↔⟨ ⊛↔ ⟩ - Any (λ x, → Any (P ∘ x,) ys) (pure _,_ ⊛ xs) ↔⟨ ⊛↔ ⟩ - Any P (pure _,_ ⊛ xs ⊛ ys) ≡˘⟨ P.cong (Any P ∘′ (_⊛ ys)) (Listₑ.Applicative.unfold-<$> _,_ xs) ⟩ - Any P (xs ⊗ ys) ∎ - where open Related.EquationalReasoning - -⊗↔′ : {P : A → Set ℓ} {Q : B → Set ℓ} {xs : List A} {ys : List B} → - (Any P xs × Any Q ys) ↔ Any (P ⟨×⟩ Q) (xs ⊗ ys) -⊗↔′ {P = P} {Q} {xs} {ys} = - (Any P xs × Any Q ys) ↔⟨ ×↔ ⟩ - Any (λ x → Any (λ y → P x × Q y) ys) xs ↔⟨ ⊗↔ ⟩ - Any (P ⟨×⟩ Q) (xs ⊗ ys) ∎ - where open Related.EquationalReasoning - -map-with-∈⁺ = mapWith∈⁺ -{-# WARNING_ON_USAGE map-with-∈⁺ -"Warning: map-with-∈⁺ was deprecated in v2.0. + to∘from : ∀ pq → Any-×⁺ {xs = xs} (Any-×⁻ pq) ≡ pq + to∘from pq with find pq + | (λ (f : (proj₁ (find pq) ≡_) ⋐ _) → map∘find pq {f}) + ... | (x , x∈xs , pq′) | lem₁ + with find pq′ + | (λ (f : (proj₁ (find pq′) ≡_) ⋐ _) → map∘find pq′ {f}) + ... | (y , y∈ys , p , q) | lem₂ + rewrite P.sym $ map-∘ {R = λ x → Any (λ y → P x × Q y) ys} + (λ p → Any.map (λ q → p , q) (lose y∈ys q)) + (λ y → P.subst P y p) + x∈xs + = lem₁ _ helper + where + helper : Any.map (λ q → p , q) (lose y∈ys q) ≡ pq′ + helper rewrite P.sym $ map-∘ (λ q → p , q) + (λ y → P.subst Q y q) + y∈ys + = lem₂ _ refl + +------------------------------------------------------------------------ +-- Half-applied product commutes with Any. + +module _ {_~_ : REL A B r} where + + Any-Σ⁺ʳ : (∃ λ x → Any (_~ x) xs) → Any (∃ ∘ _~_) xs + Any-Σ⁺ʳ (b , here px) = here (b , px) + Any-Σ⁺ʳ (b , there pxs) = there (Any-Σ⁺ʳ (b , pxs)) + + Any-Σ⁻ʳ : Any (∃ ∘ _~_) xs → ∃ λ x → Any (_~ x) xs + Any-Σ⁻ʳ (here (b , x)) = b , here x + Any-Σ⁻ʳ (there xs) = Prod.map₂ there $ Any-Σ⁻ʳ xs + +------------------------------------------------------------------------ +-- Invertible introduction (⁺) and elimination (⁻) rules for various +-- list functions +------------------------------------------------------------------------ + +------------------------------------------------------------------------ +-- singleton + +singleton⁺ : P x → Any P [ x ] +singleton⁺ Px = here Px + +singleton⁻ : Any P [ x ] → P x +singleton⁻ (here Px) = Px + +------------------------------------------------------------------------ +-- map + +module _ {f : A → B} where + + map⁺ : Any (P ∘ f) xs → Any P (List.map f xs) + map⁺ (here p) = here p + map⁺ (there p) = there $ map⁺ p + + map⁻ : Any P (List.map f xs) → Any (P ∘ f) xs + map⁻ {xs = x ∷ xs} (here p) = here p + map⁻ {xs = x ∷ xs} (there p) = there $ map⁻ p + + map⁺∘map⁻ : (p : Any P (List.map f xs)) → map⁺ (map⁻ p) ≡ p + map⁺∘map⁻ {xs = x ∷ xs} (here p) = refl + map⁺∘map⁻ {xs = x ∷ xs} (there p) = P.cong there (map⁺∘map⁻ p) + + map⁻∘map⁺ : ∀ (P : Pred B p) → + (p : Any (P ∘ f) xs) → map⁻ {P = P} (map⁺ p) ≡ p + map⁻∘map⁺ P (here p) = refl + map⁻∘map⁺ P (there p) = P.cong there (map⁻∘map⁺ P p) + + map↔ : Any (P ∘ f) xs ↔ Any P (List.map f xs) + map↔ = mk↔ₛ′ map⁺ map⁻ map⁺∘map⁻ (map⁻∘map⁺ _) + + gmap : P ⋐ Q ∘ f → Any P ⋐ Any Q ∘ map f + gmap g = map⁺ ∘ Any.map g + +------------------------------------------------------------------------ +-- mapMaybe + +module _ (f : A → Maybe B) where + + mapMaybe⁺ : ∀ xs → Any (MAny.Any P) (map f xs) → Any P (mapMaybe f xs) + mapMaybe⁺ (x ∷ xs) ps with f x | ps + ... | nothing | there pxs = mapMaybe⁺ xs pxs + ... | just _ | here (just py) = here py + ... | just _ | there pxs = there (mapMaybe⁺ xs pxs) + +------------------------------------------------------------------------ +-- _++_ + +module _ {P : A → Set p} where + + ++⁺ˡ : Any P xs → Any P (xs ++ ys) + ++⁺ˡ (here p) = here p + ++⁺ˡ (there p) = there (++⁺ˡ p) + + ++⁺ʳ : ∀ xs {ys} → Any P ys → Any P (xs ++ ys) + ++⁺ʳ [] p = p + ++⁺ʳ (x ∷ xs) p = there (++⁺ʳ xs p) + + ++⁻ : ∀ xs {ys} → Any P (xs ++ ys) → Any P xs ⊎ Any P ys + ++⁻ [] p = inj₂ p + ++⁻ (x ∷ xs) (here p) = inj₁ (here p) + ++⁻ (x ∷ xs) (there p) = Sum.map there id (++⁻ xs p) + + ++⁺∘++⁻ : ∀ xs {ys} (p : Any P (xs ++ ys)) → [ ++⁺ˡ , ++⁺ʳ xs ]′ (++⁻ xs p) ≡ p + ++⁺∘++⁻ [] p = refl + ++⁺∘++⁻ (x ∷ xs) (here p) = refl + ++⁺∘++⁻ (x ∷ xs) (there p) with ++⁻ xs p | ++⁺∘++⁻ xs p + ... | inj₁ p′ | ih = P.cong there ih + ... | inj₂ p′ | ih = P.cong there ih + + ++⁻∘++⁺ : ∀ xs {ys} (p : Any P xs ⊎ Any P ys) → + ++⁻ xs ([ ++⁺ˡ , ++⁺ʳ xs ]′ p) ≡ p + ++⁻∘++⁺ [] (inj₂ p) = refl + ++⁻∘++⁺ (x ∷ xs) (inj₁ (here p)) = refl + ++⁻∘++⁺ (x ∷ xs) {ys} (inj₁ (there p)) rewrite ++⁻∘++⁺ xs {ys} (inj₁ p) = refl + ++⁻∘++⁺ (x ∷ xs) (inj₂ p) rewrite ++⁻∘++⁺ xs (inj₂ p) = refl + + ++↔ : ∀ {xs ys} → (Any P xs ⊎ Any P ys) ↔ Any P (xs ++ ys) + ++↔ {xs = xs} = mk↔ₛ′ [ ++⁺ˡ , ++⁺ʳ xs ]′ (++⁻ xs) (++⁺∘++⁻ xs) (++⁻∘++⁺ xs) + + ++-comm : ∀ xs ys → Any P (xs ++ ys) → Any P (ys ++ xs) + ++-comm xs ys = [ ++⁺ʳ ys , ++⁺ˡ ]′ ∘ ++⁻ xs + + ++-comm∘++-comm : ∀ xs {ys} (p : Any P (xs ++ ys)) → + ++-comm ys xs (++-comm xs ys p) ≡ p + ++-comm∘++-comm [] {ys} p + rewrite ++⁻∘++⁺ ys {ys = []} (inj₁ p) = refl + ++-comm∘++-comm (x ∷ xs) {ys} (here p) + rewrite ++⁻∘++⁺ ys {ys = x ∷ xs} (inj₂ (here p)) = refl + ++-comm∘++-comm (x ∷ xs) (there p) with ++⁻ xs p | ++-comm∘++-comm xs p + ++-comm∘++-comm (x ∷ xs) {ys} (there .([ ++⁺ʳ xs , ++⁺ˡ ]′ (++⁻ ys (++⁺ʳ ys p)))) + | inj₁ p | refl + rewrite ++⁻∘++⁺ ys (inj₂ p) + | ++⁻∘++⁺ ys (inj₂ $ there {x = x} p) = refl + ++-comm∘++-comm (x ∷ xs) {ys} (there .([ ++⁺ʳ xs , ++⁺ˡ ]′ (++⁻ ys (++⁺ˡ p)))) + | inj₂ p | refl + rewrite ++⁻∘++⁺ ys {ys = xs} (inj₁ p) + | ++⁻∘++⁺ ys {ys = x ∷ xs} (inj₁ p) = refl + + ++↔++ : ∀ xs ys → Any P (xs ++ ys) ↔ Any P (ys ++ xs) + ++↔++ xs ys = mk↔ₛ′ (++-comm xs ys) (++-comm ys xs) + (++-comm∘++-comm ys) (++-comm∘++-comm xs) + + ++-insert : ∀ xs {ys} → P x → Any P (xs ++ [ x ] ++ ys) + ++-insert xs Px = ++⁺ʳ xs (++⁺ˡ (singleton⁺ Px)) + +------------------------------------------------------------------------ +-- concat + +module _ {P : A → Set p} where + + concat⁺ : ∀ {xss} → Any (Any P) xss → Any P (concat xss) + concat⁺ (here p) = ++⁺ˡ p + concat⁺ (there {x = xs} p) = ++⁺ʳ xs (concat⁺ p) + + concat⁻ : ∀ xss → Any P (concat xss) → Any (Any P) xss + concat⁻ ([] ∷ xss) p = there $ concat⁻ xss p + concat⁻ ((x ∷ xs) ∷ xss) (here p) = here (here p) + concat⁻ ((x ∷ xs) ∷ xss) (there p) with concat⁻ (xs ∷ xss) p + ... | here p′ = here (there p′) + ... | there p′ = there p′ + + concat⁻∘++⁺ˡ : ∀ {xs} xss (p : Any P xs) → + concat⁻ (xs ∷ xss) (++⁺ˡ p) ≡ here p + concat⁻∘++⁺ˡ xss (here p) = refl + concat⁻∘++⁺ˡ xss (there p) rewrite concat⁻∘++⁺ˡ xss p = refl + + concat⁻∘++⁺ʳ : ∀ xs xss (p : Any P (concat xss)) → + concat⁻ (xs ∷ xss) (++⁺ʳ xs p) ≡ there (concat⁻ xss p) + concat⁻∘++⁺ʳ [] xss p = refl + concat⁻∘++⁺ʳ (x ∷ xs) xss p rewrite concat⁻∘++⁺ʳ xs xss p = refl + + concat⁺∘concat⁻ : ∀ xss (p : Any P (concat xss)) → + concat⁺ (concat⁻ xss p) ≡ p + concat⁺∘concat⁻ ([] ∷ xss) p = concat⁺∘concat⁻ xss p + concat⁺∘concat⁻ ((x ∷ xs) ∷ xss) (here p) = refl + concat⁺∘concat⁻ ((x ∷ xs) ∷ xss) (there p) + with p | concat⁻ (xs ∷ xss) p | concat⁺∘concat⁻ (xs ∷ xss) p + ... | .(++⁺ˡ p′) | here p′ | refl = refl + ... | .(++⁺ʳ xs (concat⁺ p′)) | there p′ | refl = refl + + concat⁻∘concat⁺ : ∀ {xss} (p : Any (Any P) xss) → concat⁻ xss (concat⁺ p) ≡ p + concat⁻∘concat⁺ (here p) = concat⁻∘++⁺ˡ _ p + concat⁻∘concat⁺ (there {x = xs} {xs = xss} p) + rewrite concat⁻∘++⁺ʳ xs xss (concat⁺ p) = + P.cong there $ concat⁻∘concat⁺ p + + concat↔ : ∀ {xss} → Any (Any P) xss ↔ Any P (concat xss) + concat↔ {xss} = mk↔ₛ′ concat⁺ (concat⁻ xss) (concat⁺∘concat⁻ xss) concat⁻∘concat⁺ + +------------------------------------------------------------------------ +-- cartesianProductWith + +module _ (f : A → B → C) where + + cartesianProductWith⁺ : (∀ {x y} → P x → Q y → R (f x y)) → + Any P xs → Any Q ys → + Any R (cartesianProductWith f xs ys) + cartesianProductWith⁺ pres (here px) qys = ++⁺ˡ (map⁺ (Any.map (pres px) qys)) + cartesianProductWith⁺ pres (there qxs) qys = ++⁺ʳ _ (cartesianProductWith⁺ pres qxs qys) + + cartesianProductWith⁻ : (∀ {x y} → R (f x y) → P x × Q y) → ∀ xs ys → + Any R (cartesianProductWith f xs ys) → + Any P xs × Any Q ys + cartesianProductWith⁻ resp (x ∷ xs) ys Rxsys with ++⁻ (map (f x) ys) Rxsys + cartesianProductWith⁻ resp (x ∷ xs) ys Rxsys | inj₁ Rfxys with map⁻ Rfxys + ... | Rxys = here (proj₁ (resp (proj₂ (Any.satisfied Rxys)))) , Any.map (proj₂ ∘ resp) Rxys + cartesianProductWith⁻ resp (x ∷ xs) ys Rxsys | inj₂ Rc with cartesianProductWith⁻ resp xs ys Rc + ... | pxs , qys = there pxs , qys + +------------------------------------------------------------------------ +-- cartesianProduct + +cartesianProduct⁺ : Any P xs → Any Q ys → + Any (P ⟨×⟩ Q) (cartesianProduct xs ys) +cartesianProduct⁺ = cartesianProductWith⁺ _,_ _,_ + +cartesianProduct⁻ : ∀ xs ys → Any (P ⟨×⟩ Q) (cartesianProduct xs ys) → + Any P xs × Any Q ys +cartesianProduct⁻ = cartesianProductWith⁻ _,_ id + +------------------------------------------------------------------------ +-- applyUpTo + +applyUpTo⁺ : ∀ f {i n} → P (f i) → i < n → Any P (applyUpTo f n) +applyUpTo⁺ _ p z<s = here p +applyUpTo⁺ f p (s<s i<n@(s≤s _)) = + there (applyUpTo⁺ (f ∘ suc) p i<n) + +applyUpTo⁻ : ∀ f {n} → Any P (applyUpTo f n) → + ∃ λ i → i < n × P (f i) +applyUpTo⁻ f {suc n} (here p) = zero , z<s , p +applyUpTo⁻ f {suc n} (there p) with applyUpTo⁻ (f ∘ suc) p +... | i , i<n , q = suc i , s<s i<n , q + +------------------------------------------------------------------------ +-- applyDownFrom + +applyDownFrom⁺ : ∀ f {i n} → P (f i) → i < n → Any P (applyDownFrom f n) +applyDownFrom⁺ f {i} {suc n} p (s≤s i≤n) with i ≟ n +... | yes P.refl = here p +... | no i≢n = there (applyDownFrom⁺ f p (≤∧≢⇒< i≤n i≢n)) + +applyDownFrom⁻ : ∀ f {n} → Any P (applyDownFrom f n) → + ∃ λ i → i < n × P (f i) +applyDownFrom⁻ f {suc n} (here p) = n , ≤-refl , p +applyDownFrom⁻ f {suc n} (there p) with applyDownFrom⁻ f p +... | i , i<n , pf = i , m<n⇒m<1+n i<n , pf + +------------------------------------------------------------------------ +-- tabulate + +tabulate⁺ : ∀ {n} {f : Fin n → A} i → P (f i) → Any P (tabulate f) +tabulate⁺ zero p = here p +tabulate⁺ (suc i) p = there (tabulate⁺ i p) + +tabulate⁻ : ∀ {n} {f : Fin n → A} → Any P (tabulate f) → ∃ λ i → P (f i) +tabulate⁻ {n = suc _} (here p) = zero , p +tabulate⁻ {n = suc _} (there p) = Prod.map suc id (tabulate⁻ p) + +------------------------------------------------------------------------ +-- filter + +module _ (Q? : U.Decidable Q) where + + filter⁺ : (p : Any P xs) → Any P (filter Q? xs) ⊎ ¬ Q (Any.lookup p) + filter⁺ {xs = x ∷ _} (here px) with Q? x + ... | true because _ = inj₁ (here px) + ... | false because ofⁿ ¬Qx = inj₂ ¬Qx + filter⁺ {xs = x ∷ _} (there p) with does (Q? x) + ... | true = Sum.map₁ there (filter⁺ p) + ... | false = filter⁺ p + + filter⁻ : Any P (filter Q? xs) → Any P xs + filter⁻ {xs = x ∷ xs} p with does (Q? x) | p + ... | true | here px = here px + ... | true | there pxs = there (filter⁻ pxs) + ... | false | pxs = there (filter⁻ pxs) + +------------------------------------------------------------------------ +-- derun and deduplicate + +module _ {R : A → A → Set r} (R? : B.Decidable R) where + + private + derun⁺-aux : ∀ x xs → P Respects R → P x → Any P (derun R? (x ∷ xs)) + derun⁺-aux x [] resp Px = here Px + derun⁺-aux x (y ∷ xs) resp Px with R? x y + ... | true because ofʸ Rxy = derun⁺-aux y xs resp (resp Rxy Px) + ... | false because _ = here Px + + derun⁺ : P Respects R → Any P xs → Any P (derun R? xs) + derun⁺ {xs = x ∷ xs} resp (here px) = derun⁺-aux x xs resp px + derun⁺ {xs = x ∷ y ∷ xs} resp (there pxs) with does (R? x y) + ... | true = derun⁺ resp pxs + ... | false = there (derun⁺ resp pxs) + + deduplicate⁺ : ∀ {xs} → P Respects (flip R) → Any P xs → Any P (deduplicate R? xs) + deduplicate⁺ {xs = x ∷ xs} resp (here px) = here px + deduplicate⁺ {xs = x ∷ xs} resp (there pxs) + with filter⁺ (¬? ∘ R? x) (deduplicate⁺ resp pxs) + ... | inj₁ p = there p + ... | inj₂ ¬¬q with decidable-stable (R? x (Any.lookup (deduplicate⁺ resp pxs))) ¬¬q + ... | q = here (resp q (lookup-result (deduplicate⁺ resp pxs))) + + private + derun⁻-aux : Any P (derun R? (x ∷ xs)) → Any P (x ∷ xs) + derun⁻-aux {x = x} {[]} (here px) = here px + derun⁻-aux {x = x} {y ∷ _} p[x∷y∷xs] with does (R? x y) | p[x∷y∷xs] + ... | true | p[y∷xs] = there (derun⁻-aux p[y∷xs]) + ... | false | here px = here px + ... | false | there p[y∷xs]! = there (derun⁻-aux p[y∷xs]!) + + derun⁻ : Any P (derun R? xs) → Any P xs + derun⁻ {xs = x ∷ xs} p[x∷xs]! = derun⁻-aux p[x∷xs]! + + deduplicate⁻ : Any P (deduplicate R? xs) → Any P xs + deduplicate⁻ {xs = x ∷ _} (here px) = here px + deduplicate⁻ {xs = x ∷ _} (there pxs!) = there (deduplicate⁻ (filter⁻ (¬? ∘ R? x) pxs!)) + +------------------------------------------------------------------------ +-- mapWith∈. + +module _ {P : B → Set p} where + + mapWith∈⁺ : ∀ {xs : List A} (f : ∀ {x} → x ∈ xs → B) → + (∃₂ λ x (x∈xs : x ∈ xs) → P (f x∈xs)) → + Any P (mapWith∈ xs f) + mapWith∈⁺ f (_ , here refl , p) = here p + mapWith∈⁺ f (_ , there x∈xs , p) = + there $ mapWith∈⁺ (f ∘ there) (_ , x∈xs , p) + + mapWith∈⁻ : ∀ (xs : List A) (f : ∀ {x} → x ∈ xs → B) → + Any P (mapWith∈ xs f) → + ∃₂ λ x (x∈xs : x ∈ xs) → P (f x∈xs) + mapWith∈⁻ (y ∷ xs) f (here p) = (y , here refl , p) + mapWith∈⁻ (y ∷ xs) f (there p) = + Prod.map₂ (Prod.map there id) $ mapWith∈⁻ xs (f ∘ there) p + + mapWith∈↔ : ∀ {xs : List A} {f : ∀ {x} → x ∈ xs → B} → + (∃₂ λ x (x∈xs : x ∈ xs) → P (f x∈xs)) ↔ Any P (mapWith∈ xs f) + mapWith∈↔ = mk↔ₛ′ (mapWith∈⁺ _) (mapWith∈⁻ _ _) (to∘from _ _) (from∘to _) + where + from∘to : ∀ {xs : List A} (f : ∀ {x} → x ∈ xs → B) + (p : ∃₂ λ x (x∈xs : x ∈ xs) → P (f x∈xs)) → + mapWith∈⁻ xs f (mapWith∈⁺ f p) ≡ p + from∘to f (_ , here refl , p) = refl + from∘to f (_ , there x∈xs , p) + rewrite from∘to (f ∘ there) (_ , x∈xs , p) = refl + + to∘from : ∀ (xs : List A) (f : ∀ {x} → x ∈ xs → B) + (p : Any P (mapWith∈ xs f)) → + mapWith∈⁺ f (mapWith∈⁻ xs f p) ≡ p + to∘from (y ∷ xs) f (here p) = refl + to∘from (y ∷ xs) f (there p) = + P.cong there $ to∘from xs (f ∘ there) p + +------------------------------------------------------------------------ +-- reverse + +reverseAcc⁺ : ∀ acc xs → Any P acc ⊎ Any P xs → Any P (reverseAcc acc xs) +reverseAcc⁺ acc [] (inj₁ ps) = ps +reverseAcc⁺ acc (x ∷ xs) (inj₁ ps) = reverseAcc⁺ (x ∷ acc) xs (inj₁ (there ps)) +reverseAcc⁺ acc (x ∷ xs) (inj₂ (here px)) = reverseAcc⁺ (x ∷ acc) xs (inj₁ (here px)) +reverseAcc⁺ acc (x ∷ xs) (inj₂ (there y)) = reverseAcc⁺ (x ∷ acc) xs (inj₂ y) + +reverseAcc⁻ : ∀ acc xs → Any P (reverseAcc acc xs) → Any P acc ⊎ Any P xs +reverseAcc⁻ acc [] ps = inj₁ ps +reverseAcc⁻ acc (x ∷ xs) ps rewrite ʳ++-defn xs {x ∷ acc} with ++⁻ (reverseAcc [] xs) ps +... | inj₂ (here p') = inj₂ (here p') +... | inj₂ (there ps') = inj₁ ps' +... | inj₁ ps' with reverseAcc⁻ [] xs ps' +... | inj₂ ps'' = inj₂ (there ps'') + +reverse⁺ : Any P xs → Any P (reverse xs) +reverse⁺ ps = reverseAcc⁺ [] _ (inj₂ ps) + +reverse⁻ : Any P (reverse xs) → Any P xs +reverse⁻ ps with reverseAcc⁻ [] _ ps +... | inj₂ ps' = ps' + +------------------------------------------------------------------------ +-- pure + +pure⁺ : P x → Any P (pure x) +pure⁺ = here + +pure⁻ : Any P (pure x) → P x +pure⁻ (here p) = p + +pure⁺∘pure⁻ : (p : Any P (pure x)) → pure⁺ (pure⁻ p) ≡ p +pure⁺∘pure⁻ (here p) = refl + +pure⁻∘pure⁺ : (p : P x) → pure⁻ {P = P} (pure⁺ p) ≡ p +pure⁻∘pure⁺ p = refl + +pure↔ : P x ↔ Any P (pure x) +pure↔ {P = P} = mk↔ₛ′ pure⁺ pure⁻ pure⁺∘pure⁻ (pure⁻∘pure⁺ {P = P}) + +------------------------------------------------------------------------ +-- _∷_ + +∷↔ : (P : Pred A p) → (P x ⊎ Any P xs) ↔ Any P (x ∷ xs) +∷↔ {x = x} {xs} P = + (P x ⊎ Any P xs) ↔⟨ pure↔ ⊎-cong (Any P xs ∎) ⟩ + (Any P [ x ] ⊎ Any P xs) ↔⟨ ++↔ ⟩ + Any P (x ∷ xs) ∎ + where open Related.EquationalReasoning + +------------------------------------------------------------------------ +-- _>>=_ + +module _ {A B : Set ℓ} {P : B → Set p} {f : A → List B} where + + >>=↔ : Any (Any P ∘ f) xs ↔ Any P (xs >>= f) + >>=↔ {xs = xs} = + Any (Any P ∘ f) xs ↔⟨ map↔ ⟩ + Any (Any P) (List.map f xs) ↔⟨ concat↔ ⟩ + Any P (xs >>= f) ∎ + where open Related.EquationalReasoning + +------------------------------------------------------------------------ +-- _⊛_ + +⊛↔ : ∀ {P : B → Set ℓ} {fs : List (A → B)} {xs : List A} → + Any (λ f → Any (P ∘ f) xs) fs ↔ Any P (fs ⊛ xs) +⊛↔ {P = P} {fs} {xs} = + Any (λ f → Any (P ∘ f) xs) fs ↔⟨ Any-cong (λ _ → Any-cong (λ _ → pure↔) (_ ∎)) (_ ∎) ⟩ + Any (λ f → Any (Any P ∘ pure ∘ f) xs) fs ↔⟨ Any-cong (λ _ → >>=↔ ) (_ ∎) ⟩ + Any (λ f → Any P (xs >>= pure ∘ f)) fs ↔⟨ >>=↔ ⟩ + Any P (fs >>= λ f → xs >>= λ x → pure (f x)) ≡⟨ P.cong (Any P) (Listₑ.Applicative.unfold-⊛ fs xs) ⟨ + Any P (fs ⊛ xs) ∎ + where open Related.EquationalReasoning + + +-- An alternative introduction rule for _⊛_ + +⊛⁺′ : ∀ {P : Pred A ℓ} {Q : Pred B ℓ} {fs : List (A → B)} {xs} → + Any (P ⟨→⟩ Q) fs → Any P xs → Any Q (fs ⊛ xs) +⊛⁺′ pq p = Inverse.to ⊛↔ (Any.map (λ pq → Any.map (λ {x} → pq {x}) p) pq) + +------------------------------------------------------------------------ +-- _⊗_ + +⊗↔ : {P : A × B → Set ℓ} {xs : List A} {ys : List B} → + Any (λ x → Any (λ y → P (x , y)) ys) xs ↔ Any P (xs ⊗ ys) +⊗↔ {P = P} {xs} {ys} = + Any (λ x → Any (λ y → P (x , y)) ys) xs ↔⟨ pure↔ ⟩ + Any (λ _,_ → Any (λ x → Any (λ y → P (x , y)) ys) xs) (pure _,_) ↔⟨ ⊛↔ ⟩ + Any (λ x, → Any (P ∘ x,) ys) (pure _,_ ⊛ xs) ↔⟨ ⊛↔ ⟩ + Any P (pure _,_ ⊛ xs ⊛ ys) ≡⟨ P.cong (Any P ∘′ (_⊛ ys)) (Listₑ.Applicative.unfold-<$> _,_ xs) ⟨ + Any P (xs ⊗ ys) ∎ + where open Related.EquationalReasoning + +⊗↔′ : {P : A → Set ℓ} {Q : B → Set ℓ} {xs : List A} {ys : List B} → + (Any P xs × Any Q ys) ↔ Any (P ⟨×⟩ Q) (xs ⊗ ys) +⊗↔′ {P = P} {Q} {xs} {ys} = + (Any P xs × Any Q ys) ↔⟨ ×↔ ⟩ + Any (λ x → Any (λ y → P x × Q y) ys) xs ↔⟨ ⊗↔ ⟩ + Any (P ⟨×⟩ Q) (xs ⊗ ys) ∎ + where open Related.EquationalReasoning + +map-with-∈⁺ = mapWith∈⁺ +{-# WARNING_ON_USAGE map-with-∈⁺ +"Warning: map-with-∈⁺ was deprecated in v2.0. Please use mapWith∈⁺ instead." -#-} -map-with-∈⁻ = mapWith∈⁻ -{-# WARNING_ON_USAGE map-with-∈⁻ -"Warning: map-with-∈⁻ was deprecated in v2.0. +#-} +map-with-∈⁻ = mapWith∈⁻ +{-# WARNING_ON_USAGE map-with-∈⁻ +"Warning: map-with-∈⁻ was deprecated in v2.0. Please use mapWith∈⁻ instead." -#-} -map-with-∈↔ = mapWith∈↔ -{-# WARNING_ON_USAGE map-with-∈↔ -"Warning: map-with-∈↔ was deprecated in v2.0. +#-} +map-with-∈↔ = mapWith∈↔ +{-# WARNING_ON_USAGE map-with-∈↔ +"Warning: map-with-∈↔ was deprecated in v2.0. Please use mapWith∈↔ instead." -#-} +#-} \ No newline at end of file diff --git a/Data.List.Relation.Unary.Any.html b/Data.List.Relation.Unary.Any.html index 9c5ac4a0..00a27196 100644 --- a/Data.List.Relation.Unary.Any.html +++ b/Data.List.Relation.Unary.Any.html @@ -10,102 +10,104 @@ module Data.List.Relation.Unary.Any where open import Data.Empty -open import Data.Fin.Base using (Fin; zero; suc) -open import Data.List.Base as List using (List; []; [_]; _∷_) -open import Data.Product as Prod using (∃; _,_) -open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂) -open import Level using (Level; _⊔_) -open import Relation.Nullary using (¬_; yes; no; _⊎-dec_) -import Relation.Nullary.Decidable as Dec -open import Relation.Nullary.Negation using (contradiction) -open import Relation.Unary hiding (_∈_) +open import Data.Fin.Base using (Fin; zero; suc) +open import Data.List.Base as List using (List; []; [_]; _∷_; removeAt) +open import Data.Product.Base as Prod using (∃; _,_) +open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂) +open import Level using (Level; _⊔_) +open import Relation.Nullary using (¬_; yes; no; _⊎-dec_) +import Relation.Nullary.Decidable as Dec +open import Relation.Nullary.Negation using (contradiction) +open import Relation.Unary hiding (_∈_) -private - variable - a p q : Level - A : Set a - P Q : Pred A p - x : A - xs : List A +private + variable + a p q : Level + A : Set a + P Q : Pred A p + x : A + xs : List A ------------------------------------------------------------------------- --- Definition +------------------------------------------------------------------------ +-- Definition --- Given a predicate P, then Any P xs means that at least one element --- in xs satisfies P. See `Relation.Unary` for an explanation of --- predicates. +-- Given a predicate P, then Any P xs means that at least one element +-- in xs satisfies P. See `Relation.Unary` for an explanation of +-- predicates. -data Any {A : Set a} (P : Pred A p) : Pred (List A) (a ⊔ p) where - here : ∀ {x xs} (px : P x) → Any P (x ∷ xs) - there : ∀ {x xs} (pxs : Any P xs) → Any P (x ∷ xs) +data Any {A : Set a} (P : Pred A p) : Pred (List A) (a ⊔ p) where + here : ∀ {x xs} (px : P x) → Any P (x ∷ xs) + there : ∀ {x xs} (pxs : Any P xs) → Any P (x ∷ xs) ------------------------------------------------------------------------- --- Operations on Any +------------------------------------------------------------------------ +-- Operations on Any -head : ¬ Any P xs → Any P (x ∷ xs) → P x -head ¬pxs (here px) = px -head ¬pxs (there pxs) = contradiction pxs ¬pxs +head : ¬ Any P xs → Any P (x ∷ xs) → P x +head ¬pxs (here px) = px +head ¬pxs (there pxs) = contradiction pxs ¬pxs -tail : ¬ P x → Any P (x ∷ xs) → Any P xs -tail ¬px (here px) = ⊥-elim (¬px px) -tail ¬px (there pxs) = pxs +tail : ¬ P x → Any P (x ∷ xs) → Any P xs +tail ¬px (here px) = ⊥-elim (¬px px) +tail ¬px (there pxs) = pxs -map : P ⊆ Q → Any P ⊆ Any Q -map g (here px) = here (g px) -map g (there pxs) = there (map g pxs) +map : P ⊆ Q → Any P ⊆ Any Q +map g (here px) = here (g px) +map g (there pxs) = there (map g pxs) --- `index x∈xs` is the list position (zero-based) which `x∈xs` points to. +-- `index x∈xs` is the list position (zero-based) which `x∈xs` points to. -index : Any P xs → Fin (List.length xs) -index (here px) = zero -index (there pxs) = suc (index pxs) +index : Any P xs → Fin (List.length xs) +index (here px) = zero +index (there pxs) = suc (index pxs) -lookup : {P : Pred A p} → Any P xs → A -lookup {xs = xs} p = List.lookup xs (index p) +lookup : {P : Pred A p} → Any P xs → A +lookup {xs = xs} p = List.lookup xs (index p) -_∷=_ : {P : Pred A p} → Any P xs → A → List A -_∷=_ {xs = xs} x∈xs v = xs List.[ index x∈xs ]∷= v +infixr 5 _∷=_ -infixl 4 _─_ -_─_ : {P : Pred A p} → ∀ xs → Any P xs → List A -xs ─ x∈xs = xs List.─ index x∈xs +_∷=_ : {P : Pred A p} → Any P xs → A → List A +_∷=_ {xs = xs} x∈xs v = xs List.[ index x∈xs ]∷= v --- If any element satisfies P, then P is satisfied. +infixl 4 _─_ +_─_ : {P : Pred A p} → ∀ xs → Any P xs → List A +xs ─ x∈xs = removeAt xs (index x∈xs) -satisfied : Any P xs → ∃ P -satisfied (here px) = _ , px -satisfied (there pxs) = satisfied pxs +-- If any element satisfies P, then P is satisfied. -toSum : Any P (x ∷ xs) → P x ⊎ Any P xs -toSum (here px) = inj₁ px -toSum (there pxs) = inj₂ pxs +satisfied : Any P xs → ∃ P +satisfied (here px) = _ , px +satisfied (there pxs) = satisfied pxs -fromSum : P x ⊎ Any P xs → Any P (x ∷ xs) -fromSum (inj₁ px) = here px -fromSum (inj₂ pxs) = there pxs +toSum : Any P (x ∷ xs) → P x ⊎ Any P xs +toSum (here px) = inj₁ px +toSum (there pxs) = inj₂ pxs ------------------------------------------------------------------------- --- Properties of predicates preserved by Any +fromSum : P x ⊎ Any P xs → Any P (x ∷ xs) +fromSum (inj₁ px) = here px +fromSum (inj₂ pxs) = there pxs -any? : Decidable P → Decidable (Any P) -any? P? [] = no λ() -any? P? (x ∷ xs) = Dec.map′ fromSum toSum (P? x ⊎-dec any? P? xs) +------------------------------------------------------------------------ +-- Properties of predicates preserved by Any -satisfiable : Satisfiable P → Satisfiable (Any P) -satisfiable (x , Px) = [ x ] , here Px +any? : Decidable P → Decidable (Any P) +any? P? [] = no λ() +any? P? (x ∷ xs) = Dec.map′ fromSum toSum (P? x ⊎-dec any? P? xs) +satisfiable : Satisfiable P → Satisfiable (Any P) +satisfiable (x , Px) = [ x ] , here Px ------------------------------------------------------------------------- --- DEPRECATED ------------------------------------------------------------------------- --- Please use the new names as continuing support for the old names is --- not guaranteed. --- Version 1.4 +------------------------------------------------------------------------ +-- DEPRECATED +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. -any = any? -{-# WARNING_ON_USAGE any -"Warning: any was deprecated in v1.4. +-- Version 1.4 + +any = any? +{-# WARNING_ON_USAGE any +"Warning: any was deprecated in v1.4. Please use any? instead." -#-} +#-} \ No newline at end of file diff --git a/Data.List.Relation.Unary.Unique.Setoid.html b/Data.List.Relation.Unary.Unique.Setoid.html index 7bcd2f61..5c4c30c9 100644 --- a/Data.List.Relation.Unary.Unique.Setoid.html +++ b/Data.List.Relation.Unary.Unique.Setoid.html @@ -7,23 +7,24 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary using (Rel; Setoid) -open import Relation.Nullary.Negation using (¬_) +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Nullary.Negation using (¬_) -module Data.List.Relation.Unary.Unique.Setoid {a ℓ} (S : Setoid a ℓ) where +module Data.List.Relation.Unary.Unique.Setoid {a ℓ} (S : Setoid a ℓ) where -open Setoid S renaming (Carrier to A) +open Setoid S renaming (Carrier to A) ------------------------------------------------------------------------- --- Definition +------------------------------------------------------------------------ +-- Definition -private - Distinct : Rel A ℓ - Distinct x y = ¬ (x ≈ y) +private + Distinct : Rel A ℓ + Distinct x y = ¬ (x ≈ y) -open import Data.List.Relation.Unary.AllPairs.Core Distinct public - renaming (AllPairs to Unique) +open import Data.List.Relation.Unary.AllPairs.Core Distinct public + renaming (AllPairs to Unique) -open import Data.List.Relation.Unary.AllPairs {R = Distinct} public - using (head; tail) +open import Data.List.Relation.Unary.AllPairs {R = Distinct} public + using (head; tail) \ No newline at end of file diff --git a/Data.Maybe.Base.html b/Data.Maybe.Base.html index 493643c4..61a54078 100644 --- a/Data.Maybe.Base.html +++ b/Data.Maybe.Base.html @@ -15,127 +15,127 @@ open import Data.Bool.Base using (Bool; true; false; not) open import Data.Unit.Base using (⊤) open import Data.These.Base using (These; this; that; these) -open import Data.Product as Prod using (_×_; _,_) -open import Function.Base -open import Relation.Nullary.Reflects -open import Relation.Nullary.Decidable.Core +open import Data.Product.Base as Prod using (_×_; _,_) +open import Function.Base +open import Relation.Nullary.Reflects +open import Relation.Nullary.Decidable.Core -private - variable - a b c : Level - A : Set a - B : Set b - C : Set c +private + variable + a b c : Level + A : Set a + B : Set b + C : Set c ------------------------------------------------------------------------- --- Definition +------------------------------------------------------------------------ +-- Definition -open import Agda.Builtin.Maybe public - using (Maybe; just; nothing) +open import Agda.Builtin.Maybe public + using (Maybe; just; nothing) ------------------------------------------------------------------------- --- Some operations +------------------------------------------------------------------------ +-- Some operations -boolToMaybe : Bool → Maybe ⊤ -boolToMaybe true = just _ -boolToMaybe false = nothing +boolToMaybe : Bool → Maybe ⊤ +boolToMaybe true = just _ +boolToMaybe false = nothing -is-just : Maybe A → Bool -is-just (just _) = true -is-just nothing = false +is-just : Maybe A → Bool +is-just (just _) = true +is-just nothing = false -is-nothing : Maybe A → Bool -is-nothing = not ∘ is-just +is-nothing : Maybe A → Bool +is-nothing = not ∘ is-just -decToMaybe : Dec A → Maybe A -decToMaybe ( true because [a]) = just (invert [a]) -decToMaybe (false because _ ) = nothing +decToMaybe : Dec A → Maybe A +decToMaybe ( true because [a]) = just (invert [a]) +decToMaybe (false because _ ) = nothing --- A dependent eliminator. +-- A dependent eliminator. -maybe : ∀ {A : Set a} {B : Maybe A → Set b} → - ((x : A) → B (just x)) → B nothing → (x : Maybe A) → B x -maybe j n (just x) = j x -maybe j n nothing = n +maybe : ∀ {A : Set a} {B : Maybe A → Set b} → + ((x : A) → B (just x)) → B nothing → (x : Maybe A) → B x +maybe j n (just x) = j x +maybe j n nothing = n --- A non-dependent eliminator. +-- A non-dependent eliminator. -maybe′ : (A → B) → B → Maybe A → B -maybe′ = maybe +maybe′ : (A → B) → B → Maybe A → B +maybe′ = maybe --- A defaulting mechanism +-- A defaulting mechanism -fromMaybe : A → Maybe A → A -fromMaybe = maybe′ id +fromMaybe : A → Maybe A → A +fromMaybe = maybe′ id --- A safe variant of "fromJust". If the value is nothing, then the --- return type is the unit type. +-- A safe variant of "fromJust". If the value is nothing, then the +-- return type is the unit type. -module _ {a} {A : Set a} where +module _ {a} {A : Set a} where - From-just : Maybe A → Set a - From-just (just _) = A - From-just nothing = Lift a ⊤ + From-just : Maybe A → Set a + From-just (just _) = A + From-just nothing = Lift a ⊤ - from-just : (x : Maybe A) → From-just x - from-just (just x) = x - from-just nothing = _ + from-just : (x : Maybe A) → From-just x + from-just (just x) = x + from-just nothing = _ --- Functoriality: map +-- Functoriality: map -map : (A → B) → Maybe A → Maybe B -map f = maybe (just ∘ f) nothing +map : (A → B) → Maybe A → Maybe B +map f = maybe (just ∘ f) nothing --- Applicative: ap +-- Applicative: ap -ap : Maybe (A → B) → Maybe A → Maybe B -ap nothing = const nothing -ap (just f) = map f +ap : Maybe (A → B) → Maybe A → Maybe B +ap nothing = const nothing +ap (just f) = map f --- Monad: bind +-- Monad: bind -infixl 1 _>>=_ -_>>=_ : Maybe A → (A → Maybe B) → Maybe B -nothing >>= f = nothing -just a >>= f = f a +infixl 1 _>>=_ +_>>=_ : Maybe A → (A → Maybe B) → Maybe B +nothing >>= f = nothing +just a >>= f = f a --- Alternative: <∣> +-- Alternative: <∣> -infixr 6 _<∣>_ -_<∣>_ : Maybe A → Maybe A → Maybe A -just x <∣> my = just x -nothing <∣> my = my +infixr 6 _<∣>_ +_<∣>_ : Maybe A → Maybe A → Maybe A +just x <∣> my = just x +nothing <∣> my = my --- Just when the boolean is true +-- Just when the boolean is true -when : Bool → A → Maybe A -when b c = map (const c) (boolToMaybe b) +when : Bool → A → Maybe A +when b c = map (const c) (boolToMaybe b) ------------------------------------------------------------------------- --- Aligning and zipping +------------------------------------------------------------------------ +-- Aligning and zipping -alignWith : (These A B → C) → Maybe A → Maybe B → Maybe C -alignWith f (just a) (just b) = just (f (these a b)) -alignWith f (just a) nothing = just (f (this a)) -alignWith f nothing (just b) = just (f (that b)) -alignWith f nothing nothing = nothing +alignWith : (These A B → C) → Maybe A → Maybe B → Maybe C +alignWith f (just a) (just b) = just (f (these a b)) +alignWith f (just a) nothing = just (f (this a)) +alignWith f nothing (just b) = just (f (that b)) +alignWith f nothing nothing = nothing -zipWith : (A → B → C) → Maybe A → Maybe B → Maybe C -zipWith f (just a) (just b) = just (f a b) -zipWith _ _ _ = nothing +zipWith : (A → B → C) → Maybe A → Maybe B → Maybe C +zipWith f (just a) (just b) = just (f a b) +zipWith _ _ _ = nothing -align : Maybe A → Maybe B → Maybe (These A B) -align = alignWith id +align : Maybe A → Maybe B → Maybe (These A B) +align = alignWith id -zip : Maybe A → Maybe B → Maybe (A × B) -zip = zipWith _,_ +zip : Maybe A → Maybe B → Maybe (A × B) +zip = zipWith _,_ ------------------------------------------------------------------------- --- Injections. +------------------------------------------------------------------------ +-- Injections. -thisM : A → Maybe B → These A B -thisM a = maybe′ (these a) (this a) +thisM : A → Maybe B → These A B +thisM a = maybe′ (these a) (this a) -thatM : Maybe A → B → These A B -thatM = maybe′ these that +thatM : Maybe A → B → These A B +thatM = maybe′ these that \ No newline at end of file diff --git a/Data.Maybe.Effectful.html b/Data.Maybe.Effectful.html index d99e7cc8..d4ff4538 100644 --- a/Data.Maybe.Effectful.html +++ b/Data.Maybe.Effectful.html @@ -31,77 +31,80 @@ functor : RawFunctor {f} Maybe functor = record - { _<$>_ = map + { _<$>_ = map } -applicative : RawApplicative {f} Maybe +applicative : RawApplicative {f} Maybe applicative = record - { rawFunctor = functor - ; pure = just - ; _<*>_ = maybe map (const nothing) + { rawFunctor = functor + ; pure = just + ; _<*>_ = maybe map (const nothing) } empty : RawEmpty {f} Maybe empty = record { empty = nothing } choice : RawChoice {f} Maybe -choice = record { _<|>_ = _<∣>_ } +choice = record { _<|>_ = _<∣>_ } -applicativeZero : RawApplicativeZero {f} Maybe +applicativeZero : RawApplicativeZero {f} Maybe applicativeZero = record - { rawApplicative = applicative - ; rawEmpty = empty + { rawApplicative = applicative + ; rawEmpty = empty } -alternative : RawAlternative {f} Maybe +alternative : RawAlternative {f} Maybe alternative = record - { rawApplicativeZero = applicativeZero - ; rawChoice = choice + { rawApplicativeZero = applicativeZero + ; rawChoice = choice } ------------------------------------------------------------------------ -- Maybe monad -monad : RawMonad {f} Maybe +monad : RawMonad {f} Maybe monad = record - { rawApplicative = applicative - ; _>>=_ = _>>=_ + { rawApplicative = applicative + ; _>>=_ = _>>=_ } -monadZero : RawMonadZero {f} Maybe -monadZero = record - { rawMonad = monad - ; rawEmpty = empty - } +join : Maybe (Maybe A) → Maybe A +join = Join.join monad -monadPlus : RawMonadPlus {f} Maybe -monadPlus {f} = record - { rawMonadZero = monadZero - ; rawChoice = choice - } +monadZero : RawMonadZero {f} Maybe +monadZero = record + { rawMonad = monad + ; rawEmpty = empty + } -module TraversableA {F} (App : RawApplicative {f} {g} F) where +monadPlus : RawMonadPlus {f} Maybe +monadPlus {f} = record + { rawMonadZero = monadZero + ; rawChoice = choice + } - open RawApplicative App +module TraversableA {F} (App : RawApplicative {f} {g} F) where - sequenceA : Maybe (F A) → F (Maybe A) - sequenceA nothing = pure nothing - sequenceA (just x) = just <$> x + open RawApplicative App - mapA : (A → F B) → Maybe A → F (Maybe B) - mapA f = sequenceA ∘ map f + sequenceA : Maybe (F A) → F (Maybe A) + sequenceA nothing = pure nothing + sequenceA (just x) = just <$> x - forA : Maybe A → (A → F B) → F (Maybe B) - forA = flip mapA + mapA : (A → F B) → Maybe A → F (Maybe B) + mapA f = sequenceA ∘ map f -module TraversableM {M} (Mon : RawMonad {m} {n} M) where + forA : Maybe A → (A → F B) → F (Maybe B) + forA = flip mapA - open RawMonad Mon +module TraversableM {M} (Mon : RawMonad {m} {n} M) where - open TraversableA rawApplicative public - renaming - ( sequenceA to sequenceM - ; mapA to mapM - ; forA to forM - ) + open RawMonad Mon + + open TraversableA rawApplicative public + renaming + ( sequenceA to sequenceM + ; mapA to mapM + ; forA to forM + ) \ No newline at end of file diff --git a/Data.Maybe.Relation.Unary.All.html b/Data.Maybe.Relation.Unary.All.html index c26157f2..57cc3191 100644 --- a/Data.Maybe.Relation.Unary.All.html +++ b/Data.Maybe.Relation.Unary.All.html @@ -12,111 +12,111 @@ open import Effect.Applicative open import Effect.Monad open import Data.Maybe.Base using (Maybe; just; nothing) -open import Data.Maybe.Relation.Unary.Any using (Any; just) -open import Data.Product as Prod using (_,_) -open import Function.Base using (id; _∘′_) -open import Function.Bundles using (_⇔_; mk⇔) -open import Level -open import Relation.Binary.PropositionalEquality as P using (_≡_; cong) -open import Relation.Unary -open import Relation.Nullary hiding (Irrelevant) -import Relation.Nullary.Decidable as Dec +open import Data.Maybe.Relation.Unary.Any using (Any; just) +open import Data.Product.Base as Prod using (_,_) +open import Function.Base using (id; _∘′_) +open import Function.Bundles using (_⇔_; mk⇔) +open import Level +open import Relation.Binary.PropositionalEquality.Core as P using (_≡_; cong) +open import Relation.Unary +open import Relation.Nullary hiding (Irrelevant) +import Relation.Nullary.Decidable as Dec ------------------------------------------------------------------------- --- Definition +------------------------------------------------------------------------ +-- Definition -data All {a p} {A : Set a} (P : Pred A p) : Pred (Maybe A) (a ⊔ p) where - just : ∀ {x} → P x → All P (just x) - nothing : All P nothing +data All {a p} {A : Set a} (P : Pred A p) : Pred (Maybe A) (a ⊔ p) where + just : ∀ {x} → P x → All P (just x) + nothing : All P nothing ------------------------------------------------------------------------- --- Basic operations +------------------------------------------------------------------------ +-- Basic operations -module _ {a p} {A : Set a} {P : Pred A p} where +module _ {a p} {A : Set a} {P : Pred A p} where - drop-just : ∀ {x} → All P (just x) → P x - drop-just (just px) = px + drop-just : ∀ {x} → All P (just x) → P x + drop-just (just px) = px - just-equivalence : ∀ {x} → P x ⇔ All P (just x) - just-equivalence = mk⇔ just drop-just + just-equivalence : ∀ {x} → P x ⇔ All P (just x) + just-equivalence = mk⇔ just drop-just - map : ∀ {q} {Q : Pred A q} → P ⊆ Q → All P ⊆ All Q - map f (just px) = just (f px) - map f nothing = nothing + map : ∀ {q} {Q : Pred A q} → P ⊆ Q → All P ⊆ All Q + map f (just px) = just (f px) + map f nothing = nothing - fromAny : Any P ⊆ All P - fromAny (just px) = just px + fromAny : Any P ⊆ All P + fromAny (just px) = just px ------------------------------------------------------------------------- --- (un/)zip(/With) +------------------------------------------------------------------------ +-- (un/)zip(/With) -module _ {a p q r} {A : Set a} {P : Pred A p} {Q : Pred A q} {R : Pred A r} where +module _ {a p q r} {A : Set a} {P : Pred A p} {Q : Pred A q} {R : Pred A r} where - zipWith : P ∩ Q ⊆ R → All P ∩ All Q ⊆ All R - zipWith f (just px , just qx) = just (f (px , qx)) - zipWith f (nothing , nothing) = nothing + zipWith : P ∩ Q ⊆ R → All P ∩ All Q ⊆ All R + zipWith f (just px , just qx) = just (f (px , qx)) + zipWith f (nothing , nothing) = nothing - unzipWith : P ⊆ Q ∩ R → All P ⊆ All Q ∩ All R - unzipWith f (just px) = Prod.map just just (f px) - unzipWith f nothing = nothing , nothing + unzipWith : P ⊆ Q ∩ R → All P ⊆ All Q ∩ All R + unzipWith f (just px) = Prod.map just just (f px) + unzipWith f nothing = nothing , nothing -module _ {a p q} {A : Set a} {P : Pred A p} {Q : Pred A q} where +module _ {a p q} {A : Set a} {P : Pred A p} {Q : Pred A q} where - zip : All P ∩ All Q ⊆ All (P ∩ Q) - zip = zipWith id + zip : All P ∩ All Q ⊆ All (P ∩ Q) + zip = zipWith id - unzip : All (P ∩ Q) ⊆ All P ∩ All Q - unzip = unzipWith id + unzip : All (P ∩ Q) ⊆ All P ∩ All Q + unzip = unzipWith id ------------------------------------------------------------------------- --- Traversable-like functions +------------------------------------------------------------------------ +-- Traversable-like functions -module _ {a f} p {A : Set a} {P : Pred A (a ⊔ p)} {F} - (App : RawApplicative {a ⊔ p} {f} F) where +module _ {a f} p {A : Set a} {P : Pred A (a ⊔ p)} {F} + (App : RawApplicative {a ⊔ p} {f} F) where - open RawApplicative App + open RawApplicative App - sequenceA : All (F ∘′ P) ⊆ F ∘′ All P - sequenceA nothing = pure nothing - sequenceA (just px) = just <$> px + sequenceA : All (F ∘′ P) ⊆ F ∘′ All P + sequenceA nothing = pure nothing + sequenceA (just px) = just <$> px - mapA : ∀ {q} {Q : Pred A q} → (Q ⊆ F ∘′ P) → All Q ⊆ (F ∘′ All P) - mapA f = sequenceA ∘′ map f + mapA : ∀ {q} {Q : Pred A q} → (Q ⊆ F ∘′ P) → All Q ⊆ (F ∘′ All P) + mapA f = sequenceA ∘′ map f - forA : ∀ {q} {Q : Pred A q} {xs} → All Q xs → (Q ⊆ F ∘′ P) → F (All P xs) - forA qxs f = mapA f qxs + forA : ∀ {q} {Q : Pred A q} {xs} → All Q xs → (Q ⊆ F ∘′ P) → F (All P xs) + forA qxs f = mapA f qxs -module _ {a f} p {A : Set a} {P : Pred A (a ⊔ p)} {M} - (Mon : RawMonad {a ⊔ p} {f} M) where +module _ {a f} p {A : Set a} {P : Pred A (a ⊔ p)} {M} + (Mon : RawMonad {a ⊔ p} {f} M) where - private App = RawMonad.rawApplicative Mon + private App = RawMonad.rawApplicative Mon - sequenceM : All (M ∘′ P) ⊆ M ∘′ All P - sequenceM = sequenceA p App + sequenceM : All (M ∘′ P) ⊆ M ∘′ All P + sequenceM = sequenceA p App - mapM : ∀ {q} {Q : Pred A q} → (Q ⊆ M ∘′ P) → All Q ⊆ (M ∘′ All P) - mapM = mapA p App + mapM : ∀ {q} {Q : Pred A q} → (Q ⊆ M ∘′ P) → All Q ⊆ (M ∘′ All P) + mapM = mapA p App - forM : ∀ {q} {Q : Pred A q} {xs} → All Q xs → (Q ⊆ M ∘′ P) → M (All P xs) - forM = forA p App + forM : ∀ {q} {Q : Pred A q} {xs} → All Q xs → (Q ⊆ M ∘′ P) → M (All P xs) + forM = forA p App ------------------------------------------------------------------------- --- Seeing All as a predicate transformer +------------------------------------------------------------------------ +-- Seeing All as a predicate transformer -module _ {a p} {A : Set a} {P : Pred A p} where +module _ {a p} {A : Set a} {P : Pred A p} where - dec : Decidable P → Decidable (All P) - dec P-dec nothing = yes nothing - dec P-dec (just x) = Dec.map just-equivalence (P-dec x) + dec : Decidable P → Decidable (All P) + dec P-dec nothing = yes nothing + dec P-dec (just x) = Dec.map just-equivalence (P-dec x) - universal : Universal P → Universal (All P) - universal P-universal (just x) = just (P-universal x) - universal P-universal nothing = nothing + universal : Universal P → Universal (All P) + universal P-universal (just x) = just (P-universal x) + universal P-universal nothing = nothing - irrelevant : Irrelevant P → Irrelevant (All P) - irrelevant P-irrelevant (just p) (just q) = cong just (P-irrelevant p q) - irrelevant P-irrelevant nothing nothing = P.refl + irrelevant : Irrelevant P → Irrelevant (All P) + irrelevant P-irrelevant (just p) (just q) = cong just (P-irrelevant p q) + irrelevant P-irrelevant nothing nothing = P.refl - satisfiable : Satisfiable (All P) - satisfiable = nothing , nothing + satisfiable : Satisfiable (All P) + satisfiable = nothing , nothing \ No newline at end of file diff --git a/Data.Maybe.Relation.Unary.Any.html b/Data.Maybe.Relation.Unary.Any.html index 1cf6ce23..088cd628 100644 --- a/Data.Maybe.Relation.Unary.Any.html +++ b/Data.Maybe.Relation.Unary.Any.html @@ -10,69 +10,69 @@ module Data.Maybe.Relation.Unary.Any where open import Data.Maybe.Base using (Maybe; just; nothing) -open import Data.Product as Prod using (∃; _,_; -,_) -open import Function.Base using (id) -open import Function.Bundles using (_⇔_; mk⇔) -open import Level -open import Relation.Binary.PropositionalEquality as P using (_≡_; cong) -open import Relation.Unary -open import Relation.Nullary hiding (Irrelevant) -import Relation.Nullary.Decidable as Dec +open import Data.Product.Base as Prod using (∃; _,_; -,_) +open import Function.Base using (id) +open import Function.Bundles using (_⇔_; mk⇔) +open import Level +open import Relation.Binary.PropositionalEquality.Core as P using (_≡_; cong) +open import Relation.Unary +open import Relation.Nullary hiding (Irrelevant) +import Relation.Nullary.Decidable as Dec ------------------------------------------------------------------------- --- Definition +------------------------------------------------------------------------ +-- Definition -data Any {a p} {A : Set a} (P : Pred A p) : Pred (Maybe A) (a ⊔ p) where - just : ∀ {x} → P x → Any P (just x) +data Any {a p} {A : Set a} (P : Pred A p) : Pred (Maybe A) (a ⊔ p) where + just : ∀ {x} → P x → Any P (just x) ------------------------------------------------------------------------- --- Basic operations +------------------------------------------------------------------------ +-- Basic operations -module _ {a p} {A : Set a} {P : Pred A p} where +module _ {a p} {A : Set a} {P : Pred A p} where - drop-just : ∀ {x} → Any P (just x) → P x - drop-just (just px) = px + drop-just : ∀ {x} → Any P (just x) → P x + drop-just (just px) = px - just-equivalence : ∀ {x} → P x ⇔ Any P (just x) - just-equivalence = mk⇔ just drop-just + just-equivalence : ∀ {x} → P x ⇔ Any P (just x) + just-equivalence = mk⇔ just drop-just - map : ∀ {q} {Q : Pred A q} → P ⊆ Q → Any P ⊆ Any Q - map f (just px) = just (f px) + map : ∀ {q} {Q : Pred A q} → P ⊆ Q → Any P ⊆ Any Q + map f (just px) = just (f px) - satisfied : ∀ {x} → Any P x → ∃ P - satisfied (just p) = -, p + satisfied : ∀ {x} → Any P x → ∃ P + satisfied (just p) = -, p ------------------------------------------------------------------------- --- (un/)zip(/With) +------------------------------------------------------------------------ +-- (un/)zip(/With) -module _ {a p q r} {A : Set a} {P : Pred A p} {Q : Pred A q} {R : Pred A r} where +module _ {a p q r} {A : Set a} {P : Pred A p} {Q : Pred A q} {R : Pred A r} where - zipWith : P ∩ Q ⊆ R → Any P ∩ Any Q ⊆ Any R - zipWith f (just px , just qx) = just (f (px , qx)) + zipWith : P ∩ Q ⊆ R → Any P ∩ Any Q ⊆ Any R + zipWith f (just px , just qx) = just (f (px , qx)) - unzipWith : P ⊆ Q ∩ R → Any P ⊆ Any Q ∩ Any R - unzipWith f (just px) = Prod.map just just (f px) + unzipWith : P ⊆ Q ∩ R → Any P ⊆ Any Q ∩ Any R + unzipWith f (just px) = Prod.map just just (f px) -module _ {a p q} {A : Set a} {P : Pred A p} {Q : Pred A q} where +module _ {a p q} {A : Set a} {P : Pred A p} {Q : Pred A q} where - zip : Any P ∩ Any Q ⊆ Any (P ∩ Q) - zip = zipWith id + zip : Any P ∩ Any Q ⊆ Any (P ∩ Q) + zip = zipWith id - unzip : Any (P ∩ Q) ⊆ Any P ∩ Any Q - unzip = unzipWith id + unzip : Any (P ∩ Q) ⊆ Any P ∩ Any Q + unzip = unzipWith id ------------------------------------------------------------------------- --- Seeing Any as a predicate transformer +------------------------------------------------------------------------ +-- Seeing Any as a predicate transformer -module _ {a p} {A : Set a} {P : Pred A p} where +module _ {a p} {A : Set a} {P : Pred A p} where - dec : Decidable P → Decidable (Any P) - dec P-dec nothing = no λ () - dec P-dec (just x) = Dec.map just-equivalence (P-dec x) + dec : Decidable P → Decidable (Any P) + dec P-dec nothing = no λ () + dec P-dec (just x) = Dec.map just-equivalence (P-dec x) - irrelevant : Irrelevant P → Irrelevant (Any P) - irrelevant P-irrelevant (just p) (just q) = cong just (P-irrelevant p q) + irrelevant : Irrelevant P → Irrelevant (Any P) + irrelevant P-irrelevant (just p) (just q) = cong just (P-irrelevant p q) - satisfiable : Satisfiable P → Satisfiable (Any P) - satisfiable P-satisfiable = Prod.map just just P-satisfiable + satisfiable : Satisfiable P → Satisfiable (Any P) + satisfiable P-satisfiable = Prod.map just just P-satisfiable \ No newline at end of file diff --git a/Data.Maybe.html b/Data.Maybe.html index 48b30a92..011b4b58 100644 --- a/Data.Maybe.html +++ b/Data.Maybe.html @@ -11,7 +11,7 @@ open import Data.Empty using (⊥) open import Data.Unit using (⊤) -open import Data.Bool.Base using (T) +open import Data.Bool.Base using (T) open import Data.Maybe.Relation.Unary.All open import Data.Maybe.Relation.Unary.Any open import Level using (Level) @@ -30,14 +30,14 @@ -- Using Any and All to define Is-just and Is-nothing Is-just : Maybe A → Set _ -Is-just = Any (λ _ → ⊤) +Is-just = Any (λ _ → ⊤) Is-nothing : Maybe A → Set _ -Is-nothing = All (λ _ → ⊥) +Is-nothing = All (λ _ → ⊥) to-witness : ∀ {m : Maybe A} → Is-just m → A -to-witness (just {x = p} _) = p +to-witness (just {x = p} _) = p -to-witness-T : ∀ (m : Maybe A) → T (is-just m) → A +to-witness-T : ∀ (m : Maybe A) → T (is-just m) → A to-witness-T (just p) _ = p \ No newline at end of file diff --git a/Data.Nat.Base.html b/Data.Nat.Base.html index 7db58bd8..e324bb4d 100644 --- a/Data.Nat.Base.html +++ b/Data.Nat.Base.html @@ -13,354 +13,423 @@ module Data.Nat.Base where open import Algebra.Bundles.Raw using (RawMagma; RawMonoid; RawNearSemiring; RawSemiring) -open import Data.Bool.Base using (Bool; true; false; T; not) -open import Data.Parity.Base using (Parity; 0ℙ; 1ℙ) -open import Level using (0ℓ) -open import Relation.Binary.Core using (Rel) -open import Relation.Binary.PropositionalEquality.Core - using (_≡_; _≢_; refl) -open import Relation.Nullary.Negation.Core using (¬_; contradiction) +open import Algebra.Definitions.RawMagma using (_∣ˡ_; _,_) +open import Data.Bool.Base using (Bool; true; false; T; not) +open import Data.Parity.Base using (Parity; 0ℙ; 1ℙ) +open import Level using (0ℓ) +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.PropositionalEquality.Core + using (_≡_; _≢_; refl) +open import Relation.Nullary.Negation.Core using (¬_; contradiction) +open import Relation.Unary using (Pred) ------------------------------------------------------------------------- --- Types +------------------------------------------------------------------------ +-- Types -open import Agda.Builtin.Nat public - using (zero; suc) renaming (Nat to ℕ) +open import Agda.Builtin.Nat public + using (zero; suc) renaming (Nat to ℕ) ------------------------------------------------------------------------- --- Boolean equality relation +--smart constructor +pattern 2+ n = suc (suc n) -open import Agda.Builtin.Nat public - using () renaming (_==_ to _≡ᵇ_) +------------------------------------------------------------------------ +-- Boolean equality relation ------------------------------------------------------------------------- --- Boolean ordering relation +open import Agda.Builtin.Nat public + using () renaming (_==_ to _≡ᵇ_) -open import Agda.Builtin.Nat public - using () renaming (_<_ to _<ᵇ_) +------------------------------------------------------------------------ +-- Boolean ordering relation -infix 4 _≤ᵇ_ -_≤ᵇ_ : (m n : ℕ) → Bool -zero ≤ᵇ n = true -suc m ≤ᵇ n = m <ᵇ n +open import Agda.Builtin.Nat public + using () renaming (_<_ to _<ᵇ_) ------------------------------------------------------------------------- --- Standard ordering relations +infix 4 _≤ᵇ_ +_≤ᵇ_ : (m n : ℕ) → Bool +zero ≤ᵇ n = true +suc m ≤ᵇ n = m <ᵇ n -infix 4 _≤_ _<_ _≥_ _>_ _≰_ _≮_ _≱_ _≯_ +------------------------------------------------------------------------ +-- Standard ordering relations -data _≤_ : Rel ℕ 0ℓ where - z≤n : ∀ {n} → zero ≤ n - s≤s : ∀ {m n} (m≤n : m ≤ n) → suc m ≤ suc n +infix 4 _≤_ _<_ _≥_ _>_ _≰_ _≮_ _≱_ _≯_ -_<_ : Rel ℕ 0ℓ -m < n = suc m ≤ n +data _≤_ : Rel ℕ 0ℓ where + z≤n : ∀ {n} → zero ≤ n + s≤s : ∀ {m n} (m≤n : m ≤ n) → suc m ≤ suc n --- Smart constructors of _<_ +_<_ : Rel ℕ 0ℓ +m < n = suc m ≤ n -pattern z<s {n} = s≤s (z≤n {n}) -pattern s<s {m} {n} m<n = s≤s {m} {n} m<n +-- Smart constructors of _<_ ------------------------------------------------------------------------- --- other ordering relations +pattern z<s {n} = s≤s (z≤n {n}) +pattern s<s {m} {n} m<n = s≤s {m} {n} m<n +pattern sz<ss {n} = s<s (z<s {n}) -_≥_ : Rel ℕ 0ℓ -m ≥ n = n ≤ m +-- Smart destructors of _≤_, _<_ -_>_ : Rel ℕ 0ℓ -m > n = n < m +s≤s⁻¹ : ∀ {m n} → suc m ≤ suc n → m ≤ n +s≤s⁻¹ (s≤s m≤n) = m≤n -_≰_ : Rel ℕ 0ℓ -a ≰ b = ¬ a ≤ b +s<s⁻¹ : ∀ {m n} → suc m < suc n → m < n +s<s⁻¹ (s<s m<n) = m<n -_≮_ : Rel ℕ 0ℓ -a ≮ b = ¬ a < b -_≱_ : Rel ℕ 0ℓ -a ≱ b = ¬ a ≥ b +------------------------------------------------------------------------ +-- Other derived ordering relations -_≯_ : Rel ℕ 0ℓ -a ≯ b = ¬ a > b +_≥_ : Rel ℕ 0ℓ +m ≥ n = n ≤ m ------------------------------------------------------------------------- --- Simple predicates +_>_ : Rel ℕ 0ℓ +m > n = n < m --- Defining `NonZero` in terms of `T` and therefore ultimately `⊤` and --- `⊥` allows Agda to automatically infer nonZero-ness for any natural --- of the form `suc n`. Consequently in many circumstances this --- eliminates the need to explicitly pass a proof when the NonZero --- argument is either an implicit or an instance argument. --- --- See `Data.Nat.DivMod` for an example. +_≰_ : Rel ℕ 0ℓ +a ≰ b = ¬ a ≤ b -record NonZero (n : ℕ) : Set where - field - nonZero : T (not (n ≡ᵇ 0)) +_≮_ : Rel ℕ 0ℓ +a ≮ b = ¬ a < b --- Instances +_≱_ : Rel ℕ 0ℓ +a ≱ b = ¬ a ≥ b -instance - nonZero : ∀ {n} → NonZero (suc n) - nonZero = _ +_≯_ : Rel ℕ 0ℓ +a ≯ b = ¬ a > b --- Constructors +------------------------------------------------------------------------ +-- Simple predicates -≢-nonZero : ∀ {n} → n ≢ 0 → NonZero n -≢-nonZero {zero} 0≢0 = contradiction refl 0≢0 -≢-nonZero {suc n} n≢0 = _ +-- Defining these predicates in terms of `T` and therefore ultimately +-- `⊤` and `⊥` allows Agda to automatically infer them for any natural +-- of the correct form. Consequently in many circumstances this +-- eliminates the need to explicitly pass a proof when the predicate +-- argument is either an implicit or an instance argument. See `_/_` +-- and `_%_` further down this file for examples. +-- +-- Furthermore, defining these predicates as single-field records +-- (rather defining them directly as the type of their field) is +-- necessary as the current version of Agda is far better at +-- reconstructing meta-variable values for the record parameters. ->-nonZero : ∀ {n} → n > 0 → NonZero n ->-nonZero z<s = _ +-- A predicate saying that a number is not equal to 0. --- Destructors +record NonZero (n : ℕ) : Set where + field + nonZero : T (not (n ≡ᵇ 0)) -≢-nonZero⁻¹ : ∀ n → .{{NonZero n}} → n ≢ 0 -≢-nonZero⁻¹ (suc n) () +-- Instances ->-nonZero⁻¹ : ∀ n → .{{NonZero n}} → n > 0 ->-nonZero⁻¹ (suc n) = z<s +instance + nonZero : ∀ {n} → NonZero (suc n) + nonZero = _ ------------------------------------------------------------------------- --- Arithmetic +-- Constructors -open import Agda.Builtin.Nat public - using (_+_; _*_) renaming (_-_ to _∸_) +≢-nonZero : ∀ {n} → n ≢ 0 → NonZero n +≢-nonZero {zero} 0≢0 = contradiction refl 0≢0 +≢-nonZero {suc n} n≢0 = _ -open import Agda.Builtin.Nat - using (div-helper; mod-helper) +>-nonZero : ∀ {n} → n > 0 → NonZero n +>-nonZero z<s = _ -pred : ℕ → ℕ -pred n = n ∸ 1 +-- Destructors -infix 8 _! -infixl 7 _⊓_ _/_ _%_ -infixl 6 _+⋎_ _⊔_ +≢-nonZero⁻¹ : ∀ n → .{{NonZero n}} → n ≢ 0 +≢-nonZero⁻¹ (suc n) () --- Argument-swapping addition. Used by Data.Vec._⋎_. +>-nonZero⁻¹ : ∀ n → .{{NonZero n}} → n > 0 +>-nonZero⁻¹ (suc n) = z<s -_+⋎_ : ℕ → ℕ → ℕ -zero +⋎ n = n -suc m +⋎ n = suc (n +⋎ m) +-- The property of being a non-zero, non-unit --- Max. +record NonTrivial (n : ℕ) : Set where + field + nonTrivial : T (1 <ᵇ n) -_⊔_ : ℕ → ℕ → ℕ -zero ⊔ n = n -suc m ⊔ zero = suc m -suc m ⊔ suc n = suc (m ⊔ n) +-- Instances --- Max defined in terms of primitive operations. --- This is much faster than `_⊔_` but harder to reason about. For proofs --- involving this function, convert it to `_⊔_` with `Data.Nat.Properties.⊔≡⊔‵`. -_⊔′_ : ℕ → ℕ → ℕ -m ⊔′ n with m <ᵇ n -... | false = m -... | true = n +instance + nonTrivial : ∀ {n} → NonTrivial (2+ n) + nonTrivial = _ --- Min. +-- Constructors -_⊓_ : ℕ → ℕ → ℕ -zero ⊓ n = zero -suc m ⊓ zero = zero -suc m ⊓ suc n = suc (m ⊓ n) +n>1⇒nonTrivial : ∀ {n} → n > 1 → NonTrivial n +n>1⇒nonTrivial sz<ss = _ --- Min defined in terms of primitive operations. --- This is much faster than `_⊓_` but harder to reason about. For proofs --- involving this function, convert it to `_⊓_` wtih `Data.Nat.properties.⊓≡⊓′`. -_⊓′_ : ℕ → ℕ → ℕ -m ⊓′ n with m <ᵇ n -... | false = n -... | true = m +-- Destructors --- Parity +nonTrivial⇒nonZero : ∀ n → .{{NonTrivial n}} → NonZero n +nonTrivial⇒nonZero (2+ _) = _ -parity : ℕ → Parity -parity 0 = 0ℙ -parity 1 = 1ℙ -parity (suc (suc n)) = parity n +nonTrivial⇒n>1 : ∀ n → .{{NonTrivial n}} → n > 1 +nonTrivial⇒n>1 (2+ _) = sz<ss --- Division by 2, rounded downwards. +nonTrivial⇒≢1 : ∀ {n} → .{{NonTrivial n}} → n ≢ 1 +nonTrivial⇒≢1 {{()}} refl -⌊_/2⌋ : ℕ → ℕ -⌊ 0 /2⌋ = 0 -⌊ 1 /2⌋ = 0 -⌊ suc (suc n) /2⌋ = suc ⌊ n /2⌋ +------------------------------------------------------------------------ +-- Raw bundles --- Division by 2, rounded upwards. +open import Agda.Builtin.Nat public + using (_+_; _*_) renaming (_-_ to _∸_) -⌈_/2⌉ : ℕ → ℕ -⌈ n /2⌉ = ⌊ suc n /2⌋ ++-rawMagma : RawMagma 0ℓ 0ℓ ++-rawMagma = record + { _≈_ = _≡_ + ; _∙_ = _+_ + } --- Naïve exponentiation ++-0-rawMonoid : RawMonoid 0ℓ 0ℓ ++-0-rawMonoid = record + { _≈_ = _≡_ + ; _∙_ = _+_ + ; ε = 0 + } -_^_ : ℕ → ℕ → ℕ -x ^ zero = 1 -x ^ suc n = x * x ^ n +*-rawMagma : RawMagma 0ℓ 0ℓ +*-rawMagma = record + { _≈_ = _≡_ + ; _∙_ = _*_ + } --- Distance +*-1-rawMonoid : RawMonoid 0ℓ 0ℓ +*-1-rawMonoid = record + { _≈_ = _≡_ + ; _∙_ = _*_ + ; ε = 1 + } -∣_-_∣ : ℕ → ℕ → ℕ -∣ zero - y ∣ = y -∣ x - zero ∣ = x -∣ suc x - suc y ∣ = ∣ x - y ∣ ++-*-rawNearSemiring : RawNearSemiring 0ℓ 0ℓ ++-*-rawNearSemiring = record + { Carrier = _ + ; _≈_ = _≡_ + ; _+_ = _+_ + ; _*_ = _*_ + ; 0# = 0 + } --- Distance in terms of primitive operations. --- This is much faster than `∣_-_∣` but harder to reason about. For proofs --- involving this function, convert it to `∣_-_∣` with --- `Data.Nat.Properties.∣-∣≡∣-∣′`. -∣_-_∣′ : ℕ → ℕ → ℕ -∣ x - y ∣′ with x <ᵇ y -... | false = x ∸ y -... | true = y ∸ x ++-*-rawSemiring : RawSemiring 0ℓ 0ℓ ++-*-rawSemiring = record + { Carrier = _ + ; _≈_ = _≡_ + ; _+_ = _+_ + ; _*_ = _*_ + ; 0# = 0 + ; 1# = 1 + } --- Division --- Note properties of these are in `Nat.DivMod` not `Nat.Properties` +------------------------------------------------------------------------ +-- Arithmetic -_/_ : (dividend divisor : ℕ) .{{_ : NonZero divisor}} → ℕ -m / (suc n) = div-helper 0 n m n +open import Agda.Builtin.Nat + using (div-helper; mod-helper) --- Remainder/modulus --- Note properties of these are in `Nat.DivMod` not `Nat.Properties` +pred : ℕ → ℕ +pred n = n ∸ 1 -_%_ : (dividend divisor : ℕ) .{{_ : NonZero divisor}} → ℕ -m % (suc n) = mod-helper 0 n m n +infix 8 _! +infixl 7 _⊓_ _⊓′_ _/_ _%_ +infixl 6 _+⋎_ _⊔_ _⊔′_ --- Factorial +-- Argument-swapping addition. Used by Data.Vec._⋎_. -_! : ℕ → ℕ -zero ! = 1 -suc n ! = suc n * n ! +_+⋎_ : ℕ → ℕ → ℕ +zero +⋎ n = n +suc m +⋎ n = suc (n +⋎ m) ------------------------------------------------------------------------- --- Alternative definition of _≤_ +-- Max. --- The following definition of _≤_ is more suitable for well-founded --- induction (see Data.Nat.Induction) +_⊔_ : ℕ → ℕ → ℕ +zero ⊔ n = n +suc m ⊔ zero = suc m +suc m ⊔ suc n = suc (m ⊔ n) -infix 4 _≤′_ _<′_ _≥′_ _>′_ +-- Max defined in terms of primitive operations. +-- This is much faster than `_⊔_` but harder to reason about. For proofs +-- involving this function, convert it to `_⊔_` with `Data.Nat.Properties.⊔≡⊔‵`. +_⊔′_ : ℕ → ℕ → ℕ +m ⊔′ n with m <ᵇ n +... | false = m +... | true = n -data _≤′_ (m : ℕ) : ℕ → Set where - ≤′-refl : m ≤′ m - ≤′-step : ∀ {n} (m≤′n : m ≤′ n) → m ≤′ suc n +-- Min. -_<′_ : Rel ℕ 0ℓ -m <′ n = suc m ≤′ n +_⊓_ : ℕ → ℕ → ℕ +zero ⊓ n = zero +suc m ⊓ zero = zero +suc m ⊓ suc n = suc (m ⊓ n) --- Smart constructors of _<′_ +-- Min defined in terms of primitive operations. +-- This is much faster than `_⊓_` but harder to reason about. For proofs +-- involving this function, convert it to `_⊓_` wtih `Data.Nat.properties.⊓≡⊓′`. +_⊓′_ : ℕ → ℕ → ℕ +m ⊓′ n with m <ᵇ n +... | false = n +... | true = m -pattern <′-base = ≤′-refl -pattern <′-step {n} m<′n = ≤′-step {n} m<′n +-- Parity -_≥′_ : Rel ℕ 0ℓ -m ≥′ n = n ≤′ m +parity : ℕ → Parity +parity 0 = 0ℙ +parity 1 = 1ℙ +parity (suc (suc n)) = parity n -_>′_ : Rel ℕ 0ℓ -m >′ n = n <′ m +-- Division by 2, rounded downwards. ------------------------------------------------------------------------- --- Another alternative definition of _≤_ +⌊_/2⌋ : ℕ → ℕ +⌊ 0 /2⌋ = 0 +⌊ 1 /2⌋ = 0 +⌊ suc (suc n) /2⌋ = suc ⌊ n /2⌋ -record _≤″_ (m n : ℕ) : Set where - constructor less-than-or-equal - field - {k} : ℕ - proof : m + k ≡ n +-- Division by 2, rounded upwards. -infix 4 _≤″_ _<″_ _≥″_ _>″_ +⌈_/2⌉ : ℕ → ℕ +⌈ n /2⌉ = ⌊ suc n /2⌋ -_<″_ : Rel ℕ 0ℓ -m <″ n = suc m ≤″ n +-- Naïve exponentiation -_≥″_ : Rel ℕ 0ℓ -m ≥″ n = n ≤″ m +infixr 8 _^_ -_>″_ : Rel ℕ 0ℓ -m >″ n = n <″ m +_^_ : ℕ → ℕ → ℕ +x ^ zero = 1 +x ^ suc n = x * x ^ n ------------------------------------------------------------------------- --- Another alternative definition of _≤_ +-- Distance --- Useful for induction when you have an upper bound. +∣_-_∣ : ℕ → ℕ → ℕ +∣ zero - y ∣ = y +∣ x - zero ∣ = x +∣ suc x - suc y ∣ = ∣ x - y ∣ -data _≤‴_ : ℕ → ℕ → Set where - ≤‴-refl : ∀{m} → m ≤‴ m - ≤‴-step : ∀{m n} → suc m ≤‴ n → m ≤‴ n +-- Distance in terms of primitive operations. +-- This is much faster than `∣_-_∣` but harder to reason about. +-- For proofs involving this function, convert it to `∣_-_∣` with +-- `Data.Nat.Properties.∣-∣≡∣-∣′`. +∣_-_∣′ : ℕ → ℕ → ℕ +∣ x - y ∣′ with x <ᵇ y +... | false = x ∸ y +... | true = y ∸ x -infix 4 _≤‴_ _<‴_ _≥‴_ _>‴_ +-- Division +-- Note properties of these are in `Nat.DivMod` not `Nat.Properties` -_<‴_ : Rel ℕ 0ℓ -m <‴ n = suc m ≤‴ n +_/_ : (dividend divisor : ℕ) .{{_ : NonZero divisor}} → ℕ +m / (suc n) = div-helper 0 n m n -_≥‴_ : Rel ℕ 0ℓ -m ≥‴ n = n ≤‴ m - -_>‴_ : Rel ℕ 0ℓ -m >‴ n = n <‴ m +-- Remainder/modulus +-- Note properties of these are in `Nat.DivMod` not `Nat.Properties` ------------------------------------------------------------------------- --- A comparison view. Taken from "View from the left" --- (McBride/McKinna); details may differ. - -data Ordering : Rel ℕ 0ℓ where - less : ∀ m k → Ordering m (suc (m + k)) - equal : ∀ m → Ordering m m - greater : ∀ m k → Ordering (suc (m + k)) m - -compare : ∀ m n → Ordering m n -compare zero zero = equal zero -compare (suc m) zero = greater zero m -compare zero (suc n) = less zero n -compare (suc m) (suc n) with compare m n -... | less m k = less (suc m) k -... | equal m = equal (suc m) -... | greater n k = greater (suc n) k +_%_ : (dividend divisor : ℕ) .{{_ : NonZero divisor}} → ℕ +m % (suc n) = mod-helper 0 n m n ------------------------------------------------------------------------- --- Raw bundles +-- Factorial -+-rawMagma : RawMagma 0ℓ 0ℓ -+-rawMagma = record - { _≈_ = _≡_ - ; _∙_ = _+_ - } +_! : ℕ → ℕ +zero ! = 1 +suc n ! = suc n * n ! -+-0-rawMonoid : RawMonoid 0ℓ 0ℓ -+-0-rawMonoid = record - { _≈_ = _≡_ - ; _∙_ = _+_ - ; ε = 0 - } - -*-rawMagma : RawMagma 0ℓ 0ℓ -*-rawMagma = record - { _≈_ = _≡_ - ; _∙_ = _*_ - } - -*-1-rawMonoid : RawMonoid 0ℓ 0ℓ -*-1-rawMonoid = record - { _≈_ = _≡_ - ; _∙_ = _*_ - ; ε = 1 - } - -+-*-rawNearSemiring : RawNearSemiring 0ℓ 0ℓ -+-*-rawNearSemiring = record - { Carrier = _ - ; _≈_ = _≡_ - ; _+_ = _+_ - ; _*_ = _*_ - ; 0# = 0 - } - -+-*-rawSemiring : RawSemiring 0ℓ 0ℓ -+-*-rawSemiring = record - { Carrier = _ - ; _≈_ = _≡_ - ; _+_ = _+_ - ; _*_ = _*_ - ; 0# = 0 - ; 1# = 1 - } +------------------------------------------------------------------------ +-- Extensionally equivalent alternative definitions of _≤_/_<_ etc. + +-- _≤′_: this definition is more suitable for well-founded induction +-- (see Data.Nat.Induction) + +infix 4 _≤′_ _<′_ _≥′_ _>′_ + +data _≤′_ (m : ℕ) : ℕ → Set where + ≤′-refl : m ≤′ m + ≤′-step : ∀ {n} (m≤′n : m ≤′ n) → m ≤′ suc n + +_<′_ : Rel ℕ 0ℓ +m <′ n = suc m ≤′ n + +-- Smart constructors of _<′_ + +pattern <′-base = ≤′-refl +pattern <′-step {n} m<′n = ≤′-step {n} m<′n + +_≥′_ : Rel ℕ 0ℓ +m ≥′ n = n ≤′ m + +_>′_ : Rel ℕ 0ℓ +m >′ n = n <′ m + +-- _≤″_: this definition of _≤_ is used for proof-irrelevant ‵DivMod` +-- and is a specialised instance of a general algebraic construction + +infix 4 _≤″_ _<″_ _≥″_ _>″_ + +_≤″_ : (m n : ℕ) → Set +_≤″_ = _∣ˡ_ +-rawMagma + +pattern less-than-or-equal {k} proof = k , proof + +_<″_ : Rel ℕ 0ℓ +m <″ n = suc m ≤″ n + +_≥″_ : Rel ℕ 0ℓ +m ≥″ n = n ≤″ m + +_>″_ : Rel ℕ 0ℓ +m >″ n = n <″ m + +-- Smart constructors of _≤″_ and _<″_ + +pattern ≤″-offset k = less-than-or-equal {k = k} refl +pattern <″-offset k = ≤″-offset k + +-- Smart destructors of _<″_ + +s≤″s⁻¹ : ∀ {m n} → suc m ≤″ suc n → m ≤″ n +s≤″s⁻¹ (≤″-offset k) = ≤″-offset k + +s<″s⁻¹ : ∀ {m n} → suc m <″ suc n → m <″ n +s<″s⁻¹ (<″-offset k) = <″-offset k + +-- _≤‴_: this definition is useful for induction with an upper bound. + +data _≤‴_ : ℕ → ℕ → Set where + ≤‴-refl : ∀{m} → m ≤‴ m + ≤‴-step : ∀{m n} → suc m ≤‴ n → m ≤‴ n + +infix 4 _≤‴_ _<‴_ _≥‴_ _>‴_ + +_<‴_ : Rel ℕ 0ℓ +m <‴ n = suc m ≤‴ n + +_≥‴_ : Rel ℕ 0ℓ +m ≥‴ n = n ≤‴ m + +_>‴_ : Rel ℕ 0ℓ +m >‴ n = n <‴ m + +------------------------------------------------------------------------ +-- A comparison view. Taken from "View from the left" +-- (McBride/McKinna); details may differ. + +data Ordering : Rel ℕ 0ℓ where + less : ∀ m k → Ordering m (suc (m + k)) + equal : ∀ m → Ordering m m + greater : ∀ m k → Ordering (suc (m + k)) m + +compare : ∀ m n → Ordering m n +compare zero zero = equal zero +compare (suc m) zero = greater zero m +compare zero (suc n) = less zero n +compare (suc m) (suc n) with compare m n +... | less m k = less (suc m) k +... | equal m = equal (suc m) +... | greater n k = greater (suc n) k + + +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 2.0 \ No newline at end of file diff --git a/Data.Nat.Coprimality.html b/Data.Nat.Coprimality.html index 0a3fcd01..8937d00e 100644 --- a/Data.Nat.Coprimality.html +++ b/Data.Nat.Coprimality.html @@ -9,144 +9,140 @@ module Data.Nat.Coprimality where -open import Data.Empty -open import Data.Fin.Base using (toℕ; fromℕ<) -open import Data.Fin.Properties using (toℕ-fromℕ<) -open import Data.Nat.Base -open import Data.Nat.Divisibility -open import Data.Nat.GCD -open import Data.Nat.GCD.Lemmas -open import Data.Nat.Primality -open import Data.Nat.Properties -open import Data.Nat.DivMod -open import Data.Product as Prod -open import Function -open import Level using (0ℓ) -open import Relation.Binary.PropositionalEquality as P - using (_≡_; _≢_; refl; trans; cong; subst; module ≡-Reasoning) -open import Relation.Nullary as Nullary hiding (recompute) -open import Relation.Nullary.Negation using (contradiction) -open import Relation.Binary +open import Data.Nat.Base +open import Data.Nat.Divisibility +open import Data.Nat.GCD +open import Data.Nat.GCD.Lemmas +open import Data.Nat.Primality +open import Data.Nat.Properties +open import Data.Nat.DivMod +open import Data.Product.Base as Prod +open import Data.Sum.Base as Sum using (inj₁; inj₂) +open import Function.Base using (_∘_) +open import Level using (0ℓ) +open import Relation.Binary.PropositionalEquality.Core as P + using (_≡_; _≢_; refl; trans; cong; subst) +open import Relation.Nullary as Nullary using (¬_; contradiction; yes ; no) +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Definitions using (Symmetric; Decidable) -open ≤-Reasoning +private + variable d m n o p : ℕ ------------------------------------------------------------------------- --- Definition --- --- Coprime m n is inhabited iff m and n are coprime (relatively --- prime), i.e. if their only common divisor is 1. +open ≤-Reasoning -Coprime : Rel ℕ 0ℓ -Coprime m n = ∀ {i} → i ∣ m × i ∣ n → i ≡ 1 +------------------------------------------------------------------------ +-- Definition +-- +-- Coprime m n is inhabited iff m and n are coprime (relatively +-- prime), i.e. if their only common divisor is 1. ------------------------------------------------------------------------- --- Relationship between GCD and coprimality +Coprime : Rel ℕ 0ℓ +Coprime m n = ∀ {d} → d ∣ m × d ∣ n → d ≡ 1 -coprime⇒GCD≡1 : ∀ {m n} → Coprime m n → GCD m n 1 -coprime⇒GCD≡1 {m} {n} c = GCD.is (1∣ m , 1∣ n) (∣-reflexive ∘ c) +------------------------------------------------------------------------ +-- Relationship between GCD and coprimality -GCD≡1⇒coprime : ∀ {m n} → GCD m n 1 → Coprime m n -GCD≡1⇒coprime g cd with GCD.greatest g cd -... | divides q eq = m*n≡1⇒n≡1 q _ (P.sym eq) +coprime⇒GCD≡1 : Coprime m n → GCD m n 1 +coprime⇒GCD≡1 {m} {n} coprime = GCD.is (1∣ m , 1∣ n) (∣-reflexive ∘ coprime) -coprime⇒gcd≡1 : ∀ {m n} → Coprime m n → gcd m n ≡ 1 -coprime⇒gcd≡1 coprime = GCD.unique (gcd-GCD _ _) (coprime⇒GCD≡1 coprime) +GCD≡1⇒coprime : GCD m n 1 → Coprime m n +GCD≡1⇒coprime g cd with divides q eq ← GCD.greatest g cd + = m*n≡1⇒n≡1 q _ (P.sym eq) -gcd≡1⇒coprime : ∀ {m n} → gcd m n ≡ 1 → Coprime m n -gcd≡1⇒coprime gcd≡1 = GCD≡1⇒coprime (subst (GCD _ _) gcd≡1 (gcd-GCD _ _)) +coprime⇒gcd≡1 : Coprime m n → gcd m n ≡ 1 +coprime⇒gcd≡1 coprime = GCD.unique (gcd-GCD _ _) (coprime⇒GCD≡1 coprime) -coprime-/gcd : ∀ m n .{{_ : NonZero (gcd m n)}} → - Coprime (m / gcd m n) (n / gcd m n) -coprime-/gcd m n = GCD≡1⇒coprime (GCD-/gcd m n) +gcd≡1⇒coprime : gcd m n ≡ 1 → Coprime m n +gcd≡1⇒coprime gcd≡1 = GCD≡1⇒coprime (subst (GCD _ _) gcd≡1 (gcd-GCD _ _)) ------------------------------------------------------------------------- --- Relational properties of Coprime +coprime-/gcd : ∀ m n .{{_ : NonZero (gcd m n)}} → + Coprime (m / gcd m n) (n / gcd m n) +coprime-/gcd m n = GCD≡1⇒coprime (GCD-/gcd m n) -sym : Symmetric Coprime -sym c = c ∘ swap +------------------------------------------------------------------------ +-- Relational properties of Coprime -private - 0≢1 : 0 ≢ 1 - 0≢1 () +sym : Symmetric Coprime +sym c = c ∘ swap - 2+≢1 : ∀ {n} → suc (suc n) ≢ 1 - 2+≢1 () +private + 0≢1 : 0 ≢ 1 + 0≢1 () -coprime? : Decidable Coprime -coprime? i j with mkGCD i j -... | (0 , g) = no (0≢1 ∘ GCD.unique g ∘ coprime⇒GCD≡1) -... | (1 , g) = yes (GCD≡1⇒coprime g) -... | (suc (suc d) , g) = no (2+≢1 ∘ GCD.unique g ∘ coprime⇒GCD≡1) + 2+≢1 : ∀ {n} → 2+ n ≢ 1 + 2+≢1 () ------------------------------------------------------------------------- --- Other basic properties +coprime? : Decidable Coprime +coprime? m n with mkGCD m n +... | (0 , g) = no (0≢1 ∘ GCD.unique g ∘ coprime⇒GCD≡1) +... | (1 , g) = yes (GCD≡1⇒coprime g) +... | (2+ _ , g) = no (2+≢1 ∘ GCD.unique g ∘ coprime⇒GCD≡1) --- Everything is coprime to 1. +------------------------------------------------------------------------ +-- Other basic properties -1-coprimeTo : ∀ m → Coprime 1 m -1-coprimeTo m = ∣1⇒≡1 ∘ proj₁ +-- Everything is coprime to 1. --- Nothing except for 1 is coprime to 0. +1-coprimeTo : ∀ m → Coprime 1 m +1-coprimeTo m = ∣1⇒≡1 ∘ proj₁ -0-coprimeTo-m⇒m≡1 : ∀ {m} → Coprime 0 m → m ≡ 1 -0-coprimeTo-m⇒m≡1 {m} c = c (m ∣0 , ∣-refl) +-- Nothing except for 1 is coprime to 0. -¬0-coprimeTo-2+ : ∀ {n} → ¬ Coprime 0 (2 + n) -¬0-coprimeTo-2+ coprime = contradiction (0-coprimeTo-m⇒m≡1 coprime) λ() +0-coprimeTo-m⇒m≡1 : Coprime 0 m → m ≡ 1 +0-coprimeTo-m⇒m≡1 {m} coprime = coprime (m ∣0 , ∣-refl) --- If m and n are coprime, then n + m and n are also coprime. +¬0-coprimeTo-2+ : .{{NonTrivial n}} → ¬ Coprime 0 n +¬0-coprimeTo-2+ {n} coprime = contradiction (0-coprimeTo-m⇒m≡1 coprime) (nonTrivial⇒≢1 {n}) -coprime-+ : ∀ {m n} → Coprime m n → Coprime (n + m) n -coprime-+ c (d₁ , d₂) = c (∣m+n∣m⇒∣n d₁ d₂ , d₂) +-- If m and n are coprime, then n + m and n are also coprime. --- Recomputable +coprime-+ : Coprime m n → Coprime (n + m) n +coprime-+ coprime (d₁ , d₂) = coprime (∣m+n∣m⇒∣n d₁ d₂ , d₂) -recompute : ∀ {n d} → .(Coprime n d) → Coprime n d -recompute {n} {d} c = Nullary.recompute (coprime? n d) c +-- Recomputable ------------------------------------------------------------------------- --- Relationship with Bezout's lemma +recompute : .(Coprime n d) → Coprime n d +recompute {n} {d} coprime = Nullary.recompute (coprime? n d) coprime --- If the "gcd" in Bézout's identity is non-zero, then the "other" --- divisors are coprime. +------------------------------------------------------------------------ +-- Relationship with Bezout's lemma -Bézout-coprime : ∀ {i j d} .{{_ : NonZero d}} → - Bézout.Identity d (i * d) (j * d) → Coprime i j -Bézout-coprime {d = suc _} (Bézout.+- x y eq) (divides q₁ refl , divides q₂ refl) = - lem₁₀ y q₂ x q₁ eq -Bézout-coprime {d = suc _} (Bézout.-+ x y eq) (divides q₁ refl , divides q₂ refl) = - lem₁₀ x q₁ y q₂ eq +-- If the "gcd" in Bézout's identity is non-zero, then the "other" +-- divisors are coprime. --- Coprime numbers satisfy Bézout's identity. +Bézout-coprime : .{{NonZero d}} → + Bézout.Identity d (m * d) (n * d) → Coprime m n +Bézout-coprime {d = suc _} (Bézout.+- x y eq) (divides-refl q₁ , divides-refl q₂) = + lem₁₀ y q₂ x q₁ eq +Bézout-coprime {d = suc _} (Bézout.-+ x y eq) (divides-refl q₁ , divides-refl q₂) = + lem₁₀ x q₁ y q₂ eq -coprime-Bézout : ∀ {i j} → Coprime i j → Bézout.Identity 1 i j -coprime-Bézout = Bézout.identity ∘ coprime⇒GCD≡1 +-- Coprime numbers satisfy Bézout's identity. --- If i divides jk and is coprime to j, then it divides k. +coprime-Bézout : Coprime m n → Bézout.Identity 1 m n +coprime-Bézout = Bézout.identity ∘ coprime⇒GCD≡1 -coprime-divisor : ∀ {k i j} → Coprime i j → i ∣ j * k → i ∣ k -coprime-divisor {k} c (divides q eq′) with coprime-Bézout c -... | Bézout.+- x y eq = divides (x * k ∸ y * q) (lem₈ x y eq eq′) -... | Bézout.-+ x y eq = divides (y * q ∸ x * k) (lem₉ x y eq eq′) +-- If m divides n*o and is coprime to n, then it divides o. --- If d is a common divisor of mk and nk, and m and n are coprime, --- then d divides k. +coprime-divisor : Coprime m n → m ∣ n * o → m ∣ o +coprime-divisor {o = o} c (divides q eq′) with coprime-Bézout c +... | Bézout.+- x y eq = divides (x * o ∸ y * q) (lem₈ x y eq eq′) +... | Bézout.-+ x y eq = divides (y * q ∸ x * o) (lem₉ x y eq eq′) -coprime-factors : ∀ {d m n k} → - Coprime m n → d ∣ m * k × d ∣ n * k → d ∣ k -coprime-factors c (divides q₁ eq₁ , divides q₂ eq₂) with coprime-Bézout c -... | Bézout.+- x y eq = divides (x * q₁ ∸ y * q₂) (lem₁₁ x y eq eq₁ eq₂) -... | Bézout.-+ x y eq = divides (y * q₂ ∸ x * q₁) (lem₁₁ y x eq eq₂ eq₁) +-- If d is a common divisor of m*o and n*o, and m and n are coprime, +-- then d divides o. ------------------------------------------------------------------------- --- Primality implies coprimality. +coprime-factors : Coprime m n → d ∣ m * o × d ∣ n * o → d ∣ o +coprime-factors c (divides q₁ eq₁ , divides q₂ eq₂) with coprime-Bézout c +... | Bézout.+- x y eq = divides (x * q₁ ∸ y * q₂) (lem₁₁ x y eq eq₁ eq₂) +... | Bézout.-+ x y eq = divides (y * q₂ ∸ x * q₁) (lem₁₁ y x eq eq₂ eq₁) -prime⇒coprime : ∀ m → Prime m → - ∀ n → 0 < n → n < m → Coprime m n -prime⇒coprime (suc (suc _)) p _ _ _ {0} (0∣m , _) = - contradiction (0∣⇒≡0 0∣m) λ() -prime⇒coprime (suc (suc _)) _ _ _ _ {1} _ = refl -prime⇒coprime (suc (suc _)) p (suc _) _ n<m {(suc (suc _))} (d∣m , d∣n) = - contradiction d∣m (p 2≤d d<m) - where 2≤d = s≤s (s≤s z≤n); d<m = <-transˡ (s≤s (∣⇒≤ d∣n)) n<m +------------------------------------------------------------------------ +-- Primality implies coprimality. + +prime⇒coprime : Prime p → .{{NonZero n}} → n < p → Coprime p n +prime⇒coprime p n<p (d∣p , d∣n) with prime⇒irreducible p d∣p +... | inj₁ d≡1 = d≡1 +... | inj₂ d≡p@refl = contradiction n<p (≤⇒≯ (∣⇒≤ d∣n)) \ No newline at end of file diff --git a/Data.Nat.DivMod.Core.html b/Data.Nat.DivMod.Core.html index a5078658..768bc03d 100644 --- a/Data.Nat.DivMod.Core.html +++ b/Data.Nat.DivMod.Core.html @@ -15,250 +15,250 @@ open import Data.Nat.Base open import Data.Nat.Properties open import Data.Sum.Base using (_⊎_; inj₁; inj₂) -open import Data.Product using (_×_; _,_) -open import Relation.Binary.PropositionalEquality -open import Relation.Nullary.Decidable using (yes; no) -open import Relation.Nullary.Negation using (contradiction) - -open ≤-Reasoning - -------------------------------------------------------------------------- --- Helper lemmas that have no interpretation for _%_, only for modₕ - -private - - mod-cong₃ : ∀ {c n a₁ a₂ b} → a₁ ≡ a₂ → modₕ c n a₁ b ≡ modₕ c n a₂ b - mod-cong₃ refl = refl - - modₕ-skipTo0 : ∀ acc n a b → modₕ acc n (b + a) a ≡ modₕ (a + acc) n b 0 - modₕ-skipTo0 acc n zero b = cong (λ v → modₕ acc n v 0) (+-identityʳ b) - modₕ-skipTo0 acc n (suc a) b = begin-equality - modₕ acc n (b + suc a) (suc a) ≡⟨ mod-cong₃ (+-suc b a) ⟩ - modₕ acc n (suc b + a) (suc a) ≡⟨⟩ - modₕ (suc acc) n (b + a) a ≡⟨ modₕ-skipTo0 (suc acc) n a b ⟩ - modₕ (a + suc acc) n b 0 ≡⟨ cong (λ v → modₕ v n b 0) (+-suc a acc) ⟩ - modₕ (suc a + acc) n b 0 ∎ - -------------------------------------------------------------------------- --- Lemmas for modₕ that also have an interpretation for _%_ - -a[modₕ]1≡0 : ∀ a → modₕ 0 0 a 0 ≡ 0 -a[modₕ]1≡0 zero = refl -a[modₕ]1≡0 (suc a) = a[modₕ]1≡0 a - -n[modₕ]n≡0 : ∀ acc v → modₕ acc (acc + v) (suc v) v ≡ 0 -n[modₕ]n≡0 acc v = modₕ-skipTo0 acc (acc + v) v 1 - -a[modₕ]n<n : ∀ acc d n → modₕ acc (acc + n) d n ≤ acc + n -a[modₕ]n<n acc zero n = m≤m+n acc n -a[modₕ]n<n acc (suc d) zero = a[modₕ]n<n zero d (acc + 0) -a[modₕ]n<n acc (suc d) (suc n) rewrite +-suc acc n = a[modₕ]n<n (suc acc) d n - -a[modₕ]n≤a : ∀ acc a n → modₕ acc (acc + n) a n ≤ acc + a -a[modₕ]n≤a acc zero n = ≤-reflexive (sym (+-identityʳ acc)) -a[modₕ]n≤a acc (suc a) (suc n) = begin - modₕ acc (acc + suc n) (suc a) (suc n) ≡⟨ cong (λ v → modₕ acc v (suc a) (suc n)) (+-suc acc n) ⟩ - modₕ acc (suc acc + n) (suc a) (suc n) ≤⟨ a[modₕ]n≤a (suc acc) a n ⟩ - suc acc + a ≡⟨ sym (+-suc acc a) ⟩ - acc + suc a ∎ -a[modₕ]n≤a acc (suc a) zero = begin - modₕ acc (acc + 0) (suc a) 0 ≡⟨ cong (λ v → modₕ acc v (suc a) 0) (+-identityʳ acc) ⟩ - modₕ acc acc (suc a) 0 ≤⟨ a[modₕ]n≤a 0 a acc ⟩ - a ≤⟨ n≤1+n a ⟩ - suc a ≤⟨ m≤n+m (suc a) acc ⟩ - acc + suc a ∎ - -a≤n⇒a[modₕ]n≡a : ∀ acc n a b → modₕ acc n a (a + b) ≡ acc + a -a≤n⇒a[modₕ]n≡a acc n zero b = sym (+-identityʳ acc) -a≤n⇒a[modₕ]n≡a acc n (suc a) b = begin-equality - modₕ (suc acc) n a (a + b) ≡⟨ a≤n⇒a[modₕ]n≡a (suc acc) n a b ⟩ - suc acc + a ≡⟨ sym (+-suc acc a) ⟩ - acc + suc a ∎ - -modₕ-idem : ∀ acc a n → modₕ 0 (acc + n) (modₕ acc (acc + n) a n) (acc + n) ≡ modₕ acc (acc + n) a n -modₕ-idem acc zero n = a≤n⇒a[modₕ]n≡a 0 (acc + n) acc n -modₕ-idem acc (suc a) zero rewrite +-identityʳ acc = modₕ-idem 0 a acc -modₕ-idem acc (suc a) (suc n) rewrite +-suc acc n = modₕ-idem (suc acc) a n - -a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 : ∀ acc l n → modₕ acc (acc + l) (suc n) l ≡ 0 → modₕ acc (acc + l) n l ≡ acc + l -a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 acc zero zero eq rewrite +-identityʳ acc = refl -a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 acc zero (suc n) eq rewrite +-identityʳ acc = a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 0 acc n eq -a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 acc (suc l) (suc n) eq rewrite +-suc acc l = a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 (suc acc) l n eq - -k<1+a[modₕ]n⇒k≤a[modₕ]n : ∀ acc k n l → suc k ≤ modₕ acc (acc + l) (suc n) l → k ≤ modₕ acc (acc + l) n l -k<1+a[modₕ]n⇒k≤a[modₕ]n acc k zero (suc l) (s≤s leq) = leq -k<1+a[modₕ]n⇒k≤a[modₕ]n acc k (suc n) zero leq rewrite +-identityʳ acc = k<1+a[modₕ]n⇒k≤a[modₕ]n 0 k n acc leq -k<1+a[modₕ]n⇒k≤a[modₕ]n acc k (suc n) (suc l) leq rewrite +-suc acc l = k<1+a[modₕ]n⇒k≤a[modₕ]n (suc acc) k n l leq - -1+a[modₕ]n≤1+k⇒a[modₕ]n≤k : ∀ acc k n l → 0 < modₕ acc (acc + l) (suc n) l → - modₕ acc (acc + l) (suc n) l ≤ suc k → modₕ acc (acc + l) n l ≤ k -1+a[modₕ]n≤1+k⇒a[modₕ]n≤k acc k zero (suc l) 0<mod (s≤s leq) = leq -1+a[modₕ]n≤1+k⇒a[modₕ]n≤k acc k (suc n) zero 0<mod leq rewrite +-identityʳ acc = 1+a[modₕ]n≤1+k⇒a[modₕ]n≤k 0 k n acc 0<mod leq -1+a[modₕ]n≤1+k⇒a[modₕ]n≤k acc k (suc n) (suc l) 0<mod leq rewrite +-suc acc l = 1+a[modₕ]n≤1+k⇒a[modₕ]n≤k (suc acc) k n l 0<mod leq - -a+n[modₕ]n≡a[modₕ]n : ∀ acc a n → modₕ acc (acc + n) (acc + a + suc n) n ≡ modₕ acc (acc + n) a n -a+n[modₕ]n≡a[modₕ]n acc zero n rewrite +-identityʳ acc = begin-equality - modₕ acc (acc + n) (acc + suc n) n ≡⟨ mod-cong₃ (+-suc acc n) ⟩ - modₕ acc (acc + n) (suc acc + n) n ≡⟨ modₕ-skipTo0 acc (acc + n) n (suc acc) ⟩ - modₕ (acc + n) (acc + n) (suc acc) 0 ≡⟨⟩ - modₕ 0 (acc + n) acc (acc + n) ≡⟨ a≤n⇒a[modₕ]n≡a 0 (acc + n) acc n ⟩ - acc ∎ -a+n[modₕ]n≡a[modₕ]n acc (suc a) zero rewrite +-identityʳ acc = begin-equality - modₕ acc acc (acc + suc a + 1) 0 ≡⟨ mod-cong₃ (+-comm (acc + suc a) 1) ⟩ - modₕ acc acc (1 + (acc + suc a)) 0 ≡⟨⟩ - modₕ 0 acc (acc + suc a) acc ≡⟨ mod-cong₃ (+-comm acc (suc a)) ⟩ - modₕ 0 acc (suc a + acc) acc ≡⟨ mod-cong₃ (sym (+-suc a acc)) ⟩ - modₕ 0 acc (a + suc acc) acc ≡⟨ a+n[modₕ]n≡a[modₕ]n 0 a acc ⟩ - modₕ 0 acc a acc ∎ -a+n[modₕ]n≡a[modₕ]n acc (suc a) (suc n) rewrite +-suc acc n = begin-equality - mod₁ (acc + suc a + (2 + n)) (suc n) ≡⟨ cong (λ v → mod₁ (v + suc (suc n)) (suc n)) (+-suc acc a) ⟩ - mod₁ (suc acc + a + (2 + n)) (suc n) ≡⟨⟩ - mod₂ (acc + a + (2 + n)) n ≡⟨ mod-cong₃ (sym (+-assoc (acc + a) 1 (suc n))) ⟩ - mod₂ (acc + a + 1 + suc n) n ≡⟨ mod-cong₃ (cong (_+ suc n) (+-comm (acc + a) 1)) ⟩ - mod₂ (suc acc + a + suc n) n ≡⟨ a+n[modₕ]n≡a[modₕ]n (suc acc) a n ⟩ - mod₂ a n ∎ - where - mod₁ = modₕ acc (suc acc + n) - mod₂ = modₕ (suc acc) (suc acc + n) - -------------------------------------------------------------------------- --- Helper lemmas that have no interpretation for `_/_`, only for `divₕ` - -private - - div-cong₃ : ∀ {c n a₁ a₂ b} → a₁ ≡ a₂ → divₕ c n a₁ b ≡ divₕ c n a₂ b - div-cong₃ refl = refl - - acc≤divₕ[acc] : ∀ {acc} d n j → acc ≤ divₕ acc d n j - acc≤divₕ[acc] {acc} d zero j = ≤-refl - acc≤divₕ[acc] {acc} d (suc n) zero = ≤-trans (n≤1+n acc) (acc≤divₕ[acc] d n d) - acc≤divₕ[acc] {acc} d (suc n) (suc j) = acc≤divₕ[acc] d n j - - pattern inj₂′ x = inj₂ (inj₁ x) - pattern inj₃ x = inj₂ (inj₂ x) - - -- This hideous lemma details the conditions needed for two divisions to - -- be equal when the two offsets (i.e. the 4ᵗʰ parameters) are different. - -- It may be that this triple sum has an elegant simplification to a - -- set of inequalities involving the modulus but I can't find it. - divₕ-offsetEq : ∀ {acc₁ acc₂} d n j k → j ≤ d → k ≤ d → - (acc₁ ≡ acc₂ × j ≤ k × k < modₕ 0 d n d) ⊎ - (acc₁ ≡ acc₂ × modₕ 0 d n d ≤ j × j ≤ k) ⊎ - (acc₁ ≡ suc acc₂ × k < modₕ 0 d n d × modₕ 0 d n d ≤ j) → - divₕ acc₁ d n j ≡ divₕ acc₂ d n k - divₕ-offsetEq d zero j k j≤d k≤d (inj₁ (refl , _)) = refl - divₕ-offsetEq d zero j k j≤d k≤d (inj₂′ (refl , _)) = refl - divₕ-offsetEq d zero j k j≤d k≤d (inj₃ (eq , () , _)) - -- (0 , 0) cases - divₕ-offsetEq d (suc n) zero zero j≤d k≤d (inj₁ (refl , _)) = - divₕ-offsetEq d n d d ≤-refl ≤-refl (inj₂′ (refl , a[modₕ]n<n 0 n d , ≤-refl)) - divₕ-offsetEq d (suc n) zero zero j≤d k≤d (inj₂′ (refl , _)) = - divₕ-offsetEq d n d d ≤-refl ≤-refl (inj₂′ (refl , a[modₕ]n<n 0 n d , ≤-refl)) - divₕ-offsetEq d (suc n) zero zero j≤d k≤d (inj₃ (_ , 0<mod , mod≤0)) = - contradiction (<-transˡ 0<mod mod≤0) λ() - -- (0 , suc) cases - divₕ-offsetEq d (suc n) zero (suc k) j≤d k≤d (inj₁ (refl , _ , 1+k<mod)) = - divₕ-offsetEq d n d k ≤-refl (<⇒≤ k≤d) (inj₃ (refl , k<1+a[modₕ]n⇒k≤a[modₕ]n 0 (suc k) n d 1+k<mod , a[modₕ]n<n 0 n d)) - divₕ-offsetEq d (suc n) zero (suc k) j≤d k≤d (inj₂′ (refl , mod≤0 , _)) = - divₕ-offsetEq d n d k ≤-refl (<⇒≤ k≤d) (inj₃ (refl , subst (k <_) (sym (a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 0 d n (n≤0⇒n≡0 mod≤0))) k≤d , a[modₕ]n<n 0 n d)) - divₕ-offsetEq d (suc n) zero (suc k) j≤d k≤d (inj₃ (_ , 1+k<mod , mod≤0)) = - contradiction (<-transˡ 1+k<mod mod≤0) λ() - -- (suc , 0) cases - divₕ-offsetEq d (suc n) (suc j) zero j≤d k≤d (inj₁ (_ , () , _)) - divₕ-offsetEq d (suc n) (suc j) zero j≤d k≤d (inj₂′ (_ , _ , ())) - divₕ-offsetEq d (suc n) (suc j) zero j≤d k≤d (inj₃ (eq , 0<mod , mod≤1+j)) = - divₕ-offsetEq d n j d (<⇒≤ j≤d) ≤-refl (inj₂′ (eq , 1+a[modₕ]n≤1+k⇒a[modₕ]n≤k 0 j n d 0<mod mod≤1+j , <⇒≤ j≤d)) - -- (suc , suc) cases - divₕ-offsetEq d (suc n) (suc j) (suc k) j≤d k≤d (inj₁ (eq , s≤s j≤k , 1+k<mod)) = - divₕ-offsetEq d n j k (<⇒≤ j≤d) (<⇒≤ k≤d) (inj₁ (eq , j≤k , k<1+a[modₕ]n⇒k≤a[modₕ]n 0 (suc k) n d 1+k<mod)) - divₕ-offsetEq d (suc n) (suc j) (suc k) j≤d k≤d (inj₂′ (eq , mod≤1+j , (s≤s j≤k))) with modₕ 0 d (suc n) d ≟ 0 - ... | yes mod≡0 = divₕ-offsetEq d n j k (<⇒≤ j≤d) (<⇒≤ k≤d) (inj₁ (eq , j≤k , subst (k <_) (sym (a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 0 d n mod≡0)) k≤d)) - ... | no mod≢0 = divₕ-offsetEq d n j k (<⇒≤ j≤d) (<⇒≤ k≤d) (inj₂′ (eq , 1+a[modₕ]n≤1+k⇒a[modₕ]n≤k 0 j n d (n≢0⇒n>0 mod≢0) mod≤1+j , j≤k)) - divₕ-offsetEq d (suc n) (suc j) (suc k) j≤d k≤d (inj₃ (eq , k<mod , mod≤1+j)) = - divₕ-offsetEq d n j k (<⇒≤ j≤d) (<⇒≤ k≤d) (inj₃ (eq , k<1+a[modₕ]n⇒k≤a[modₕ]n 0 (suc k) n d k<mod , 1+a[modₕ]n≤1+k⇒a[modₕ]n≤k 0 j n d (<-transʳ z≤n k<mod) mod≤1+j)) - -------------------------------------------------------------------------- --- Lemmas for divₕ that also have an interpretation for _/_ - --- The quotient and remainder are related to the dividend and --- divisor in the right way. - -div-mod-lemma : ∀ accᵐ accᵈ d n → - accᵐ + accᵈ * suc (accᵐ + n) + d ≡ - modₕ accᵐ (accᵐ + n) d n + divₕ accᵈ (accᵐ + n) d n * suc (accᵐ + n) -div-mod-lemma accᵐ accᵈ zero n = +-identityʳ _ -div-mod-lemma accᵐ accᵈ (suc d) zero rewrite +-identityʳ accᵐ = begin-equality - accᵐ + accᵈ * suc accᵐ + suc d ≡⟨ +-suc _ d ⟩ - suc accᵈ * suc accᵐ + d ≡⟨ div-mod-lemma zero (suc accᵈ) d accᵐ ⟩ - modₕ 0 accᵐ d accᵐ + - divₕ (suc accᵈ) accᵐ d accᵐ * suc accᵐ ≡⟨⟩ - modₕ accᵐ accᵐ (suc d) 0 + - divₕ accᵈ accᵐ (suc d) 0 * suc accᵐ ∎ -div-mod-lemma accᵐ accᵈ (suc d) (suc n) rewrite +-suc accᵐ n = begin-equality - accᵐ + accᵈ * m + suc d ≡⟨ +-suc _ d ⟩ - suc (accᵐ + accᵈ * m + d) ≡⟨ div-mod-lemma (suc accᵐ) accᵈ d n ⟩ - modₕ _ _ d n + divₕ accᵈ _ d n * m ∎ - where - m = 2 + accᵐ + n - -divₕ-restart : ∀ {acc} d n j → j < n → divₕ acc d n j ≡ divₕ (suc acc) d (n ∸ suc j) d -divₕ-restart d (suc n) zero j<n = refl -divₕ-restart d (suc n) (suc j) (s≤s j<n) = divₕ-restart d n j j<n - -divₕ-extractAcc : ∀ acc d n j → divₕ acc d n j ≡ acc + divₕ 0 d n j -divₕ-extractAcc acc d zero j = sym (+-identityʳ acc) -divₕ-extractAcc acc d (suc n) (suc j) = divₕ-extractAcc acc d n j -divₕ-extractAcc acc d (suc n) zero = begin-equality - divₕ (suc acc) d n d ≡⟨ divₕ-extractAcc (suc acc) d n d ⟩ - suc acc + divₕ 0 d n d ≡⟨ sym (+-suc acc _) ⟩ - acc + suc (divₕ 0 d n d) ≡⟨ cong (acc +_) (sym (divₕ-extractAcc 1 d n d)) ⟩ - acc + divₕ 1 d n d ∎ - -divₕ-finish : ∀ {acc} d n j → j ≥ n → divₕ acc d n j ≡ acc -divₕ-finish d zero j j≥n = refl -divₕ-finish d (suc n) (suc j) (s≤s j≥n) = divₕ-finish d n j j≥n - -n[divₕ]n≡1 : ∀ n m → divₕ 0 n (suc m) m ≡ 1 -n[divₕ]n≡1 n zero = refl -n[divₕ]n≡1 n (suc m) = n[divₕ]n≡1 n m - -a[divₕ]1≡a : ∀ acc a → divₕ acc 0 a 0 ≡ acc + a -a[divₕ]1≡a acc zero = sym (+-identityʳ acc) -a[divₕ]1≡a acc (suc a) = trans (a[divₕ]1≡a (suc acc) a) (sym (+-suc acc a)) - -a*n[divₕ]n≡a : ∀ acc a n → divₕ acc n (a * suc n) n ≡ acc + a -a*n[divₕ]n≡a acc zero n = sym (+-identityʳ acc) -a*n[divₕ]n≡a acc (suc a) n = begin-equality - divₕ acc n (suc a * suc n) n ≡⟨ divₕ-restart n (suc a * suc n) n (m≤m+n (suc n) _) ⟩ - divₕ (suc acc) n (suc a * suc n ∸ suc n) n ≡⟨⟩ - divₕ (suc acc) n (suc n + a * suc n ∸ suc n) n ≡⟨ div-cong₃ (m+n∸m≡n (suc n) (a * suc n)) ⟩ - divₕ (suc acc) n (a * suc n) n ≡⟨ a*n[divₕ]n≡a (suc acc) a n ⟩ - suc acc + a ≡⟨ sym (+-suc acc a) ⟩ - acc + suc a ∎ - -+-distrib-divₕ : ∀ acc k m n j → modₕ k (k + j) m j + modₕ 0 (k + j) n (k + j) < suc (k + j) → - divₕ acc (k + j) (m + n) j ≡ divₕ acc (k + j) m j + divₕ 0 (k + j) n (k + j) -+-distrib-divₕ acc k (suc m) n zero leq rewrite +-identityʳ k = +-distrib-divₕ (suc acc) 0 m n k leq -+-distrib-divₕ acc k (suc m) n (suc j) leq rewrite +-suc k j = +-distrib-divₕ acc (suc k) m n j leq -+-distrib-divₕ acc k zero n j leq = begin-equality - divₕ acc (k + j) n j ≡⟨ divₕ-extractAcc acc (k + j) n j ⟩ - acc + divₕ 0 (k + j) n j ≡⟨ cong (acc +_) (divₕ-offsetEq _ n j _ (m≤n+m j k) ≤-refl case) ⟩ - acc + divₕ 0 (k + j) n (k + j) ∎ - where - case = inj₂′ (refl , +-cancelˡ-≤ (suc k) _ _ leq , m≤n+m j k) - -divₕ-mono-≤ : ∀ {acc} k {m n o p} → m ≤ n → p ≤ o → divₕ acc (k + o) m o ≤ divₕ acc (k + p) n p -divₕ-mono-≤ {acc} k {0} {n} {_} {p} z≤n p≤o = acc≤divₕ[acc] (k + p) n p -divₕ-mono-≤ {acc} k {_} {_} {suc o} {suc p} (s≤s m≤n) (s≤s p≤o) - rewrite +-suc k o | +-suc k p = divₕ-mono-≤ (suc k) m≤n p≤o -divₕ-mono-≤ {acc} k {suc m} {suc n} {o} {0} (s≤s m≤n) z≤n with o <? suc m -... | no o≮1+m rewrite +-identityʳ k = begin - divₕ acc (k + o) (suc m) o ≡⟨ divₕ-finish (k + o) (suc m) o (≮⇒≥ o≮1+m) ⟩ - acc ≤⟨ n≤1+n acc ⟩ - suc acc ≤⟨ acc≤divₕ[acc] k n k ⟩ - divₕ (suc acc) k n k ∎ -... | yes o<1+m rewrite +-identityʳ k = begin - divₕ acc (k + o) (suc m) o ≡⟨ divₕ-restart (k + o) (suc m) o o<1+m ⟩ - divₕ (suc acc) (k + o) (m ∸ o) (k + o) ≤⟨ divₕ-mono-≤ 0 (≤-trans (m∸n≤m m o) m≤n) (m≤m+n k o) ⟩ - divₕ (suc acc) k n k ∎ +open import Data.Product.Base using (_×_; _,_) +open import Relation.Binary.PropositionalEquality +open import Relation.Nullary.Decidable using (yes; no) +open import Relation.Nullary.Negation using (contradiction) + +open ≤-Reasoning + +------------------------------------------------------------------------ +-- Helper lemmas that have no interpretation for _%_, only for modₕ + +private + + mod-cong₃ : ∀ {c n a₁ a₂ b} → a₁ ≡ a₂ → modₕ c n a₁ b ≡ modₕ c n a₂ b + mod-cong₃ refl = refl + + modₕ-skipTo0 : ∀ acc n a b → modₕ acc n (b + a) a ≡ modₕ (a + acc) n b 0 + modₕ-skipTo0 acc n zero b = cong (λ v → modₕ acc n v 0) (+-identityʳ b) + modₕ-skipTo0 acc n (suc a) b = begin-equality + modₕ acc n (b + suc a) (suc a) ≡⟨ mod-cong₃ (+-suc b a) ⟩ + modₕ acc n (suc b + a) (suc a) ≡⟨⟩ + modₕ (suc acc) n (b + a) a ≡⟨ modₕ-skipTo0 (suc acc) n a b ⟩ + modₕ (a + suc acc) n b 0 ≡⟨ cong (λ v → modₕ v n b 0) (+-suc a acc) ⟩ + modₕ (suc a + acc) n b 0 ∎ + +------------------------------------------------------------------------ +-- Lemmas for modₕ that also have an interpretation for _%_ + +a[modₕ]1≡0 : ∀ a → modₕ 0 0 a 0 ≡ 0 +a[modₕ]1≡0 zero = refl +a[modₕ]1≡0 (suc a) = a[modₕ]1≡0 a + +n[modₕ]n≡0 : ∀ acc v → modₕ acc (acc + v) (suc v) v ≡ 0 +n[modₕ]n≡0 acc v = modₕ-skipTo0 acc (acc + v) v 1 + +a[modₕ]n<n : ∀ acc d n → modₕ acc (acc + n) d n ≤ acc + n +a[modₕ]n<n acc zero n = m≤m+n acc n +a[modₕ]n<n acc (suc d) zero = a[modₕ]n<n zero d (acc + 0) +a[modₕ]n<n acc (suc d) (suc n) rewrite +-suc acc n = a[modₕ]n<n (suc acc) d n + +a[modₕ]n≤a : ∀ acc a n → modₕ acc (acc + n) a n ≤ acc + a +a[modₕ]n≤a acc zero n = ≤-reflexive (sym (+-identityʳ acc)) +a[modₕ]n≤a acc (suc a) (suc n) = begin + modₕ acc (acc + suc n) (suc a) (suc n) ≡⟨ cong (λ v → modₕ acc v (suc a) (suc n)) (+-suc acc n) ⟩ + modₕ acc (suc acc + n) (suc a) (suc n) ≤⟨ a[modₕ]n≤a (suc acc) a n ⟩ + suc acc + a ≡⟨ sym (+-suc acc a) ⟩ + acc + suc a ∎ +a[modₕ]n≤a acc (suc a) zero = begin + modₕ acc (acc + 0) (suc a) 0 ≡⟨ cong (λ v → modₕ acc v (suc a) 0) (+-identityʳ acc) ⟩ + modₕ acc acc (suc a) 0 ≤⟨ a[modₕ]n≤a 0 a acc ⟩ + a ≤⟨ n≤1+n a ⟩ + suc a ≤⟨ m≤n+m (suc a) acc ⟩ + acc + suc a ∎ + +a≤n⇒a[modₕ]n≡a : ∀ acc n a b → modₕ acc n a (a + b) ≡ acc + a +a≤n⇒a[modₕ]n≡a acc n zero b = sym (+-identityʳ acc) +a≤n⇒a[modₕ]n≡a acc n (suc a) b = begin-equality + modₕ (suc acc) n a (a + b) ≡⟨ a≤n⇒a[modₕ]n≡a (suc acc) n a b ⟩ + suc acc + a ≡⟨ sym (+-suc acc a) ⟩ + acc + suc a ∎ + +modₕ-idem : ∀ acc a n → modₕ 0 (acc + n) (modₕ acc (acc + n) a n) (acc + n) ≡ modₕ acc (acc + n) a n +modₕ-idem acc zero n = a≤n⇒a[modₕ]n≡a 0 (acc + n) acc n +modₕ-idem acc (suc a) zero rewrite +-identityʳ acc = modₕ-idem 0 a acc +modₕ-idem acc (suc a) (suc n) rewrite +-suc acc n = modₕ-idem (suc acc) a n + +a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 : ∀ acc l n → modₕ acc (acc + l) (suc n) l ≡ 0 → modₕ acc (acc + l) n l ≡ acc + l +a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 acc zero zero eq rewrite +-identityʳ acc = refl +a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 acc zero (suc n) eq rewrite +-identityʳ acc = a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 0 acc n eq +a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 acc (suc l) (suc n) eq rewrite +-suc acc l = a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 (suc acc) l n eq + +k<1+a[modₕ]n⇒k≤a[modₕ]n : ∀ acc k n l → suc k ≤ modₕ acc (acc + l) (suc n) l → k ≤ modₕ acc (acc + l) n l +k<1+a[modₕ]n⇒k≤a[modₕ]n acc k zero (suc l) (s≤s leq) = leq +k<1+a[modₕ]n⇒k≤a[modₕ]n acc k (suc n) zero leq rewrite +-identityʳ acc = k<1+a[modₕ]n⇒k≤a[modₕ]n 0 k n acc leq +k<1+a[modₕ]n⇒k≤a[modₕ]n acc k (suc n) (suc l) leq rewrite +-suc acc l = k<1+a[modₕ]n⇒k≤a[modₕ]n (suc acc) k n l leq + +1+a[modₕ]n≤1+k⇒a[modₕ]n≤k : ∀ acc k n l → 0 < modₕ acc (acc + l) (suc n) l → + modₕ acc (acc + l) (suc n) l ≤ suc k → modₕ acc (acc + l) n l ≤ k +1+a[modₕ]n≤1+k⇒a[modₕ]n≤k acc k zero (suc l) 0<mod (s≤s leq) = leq +1+a[modₕ]n≤1+k⇒a[modₕ]n≤k acc k (suc n) zero 0<mod leq rewrite +-identityʳ acc = 1+a[modₕ]n≤1+k⇒a[modₕ]n≤k 0 k n acc 0<mod leq +1+a[modₕ]n≤1+k⇒a[modₕ]n≤k acc k (suc n) (suc l) 0<mod leq rewrite +-suc acc l = 1+a[modₕ]n≤1+k⇒a[modₕ]n≤k (suc acc) k n l 0<mod leq + +a+n[modₕ]n≡a[modₕ]n : ∀ acc a n → modₕ acc (acc + n) (acc + a + suc n) n ≡ modₕ acc (acc + n) a n +a+n[modₕ]n≡a[modₕ]n acc zero n rewrite +-identityʳ acc = begin-equality + modₕ acc (acc + n) (acc + suc n) n ≡⟨ mod-cong₃ (+-suc acc n) ⟩ + modₕ acc (acc + n) (suc acc + n) n ≡⟨ modₕ-skipTo0 acc (acc + n) n (suc acc) ⟩ + modₕ (acc + n) (acc + n) (suc acc) 0 ≡⟨⟩ + modₕ 0 (acc + n) acc (acc + n) ≡⟨ a≤n⇒a[modₕ]n≡a 0 (acc + n) acc n ⟩ + acc ∎ +a+n[modₕ]n≡a[modₕ]n acc (suc a) zero rewrite +-identityʳ acc = begin-equality + modₕ acc acc (acc + suc a + 1) 0 ≡⟨ mod-cong₃ (+-comm (acc + suc a) 1) ⟩ + modₕ acc acc (1 + (acc + suc a)) 0 ≡⟨⟩ + modₕ 0 acc (acc + suc a) acc ≡⟨ mod-cong₃ (+-comm acc (suc a)) ⟩ + modₕ 0 acc (suc a + acc) acc ≡⟨ mod-cong₃ (sym (+-suc a acc)) ⟩ + modₕ 0 acc (a + suc acc) acc ≡⟨ a+n[modₕ]n≡a[modₕ]n 0 a acc ⟩ + modₕ 0 acc a acc ∎ +a+n[modₕ]n≡a[modₕ]n acc (suc a) (suc n) rewrite +-suc acc n = begin-equality + mod₁ (acc + suc a + (2 + n)) (suc n) ≡⟨ cong (λ v → mod₁ (v + suc (suc n)) (suc n)) (+-suc acc a) ⟩ + mod₁ (suc acc + a + (2 + n)) (suc n) ≡⟨⟩ + mod₂ (acc + a + (2 + n)) n ≡⟨ mod-cong₃ (sym (+-assoc (acc + a) 1 (suc n))) ⟩ + mod₂ (acc + a + 1 + suc n) n ≡⟨ mod-cong₃ (cong (_+ suc n) (+-comm (acc + a) 1)) ⟩ + mod₂ (suc acc + a + suc n) n ≡⟨ a+n[modₕ]n≡a[modₕ]n (suc acc) a n ⟩ + mod₂ a n ∎ + where + mod₁ = modₕ acc (suc acc + n) + mod₂ = modₕ (suc acc) (suc acc + n) + +------------------------------------------------------------------------ +-- Helper lemmas that have no interpretation for `_/_`, only for `divₕ` + +private + + div-cong₃ : ∀ {c n a₁ a₂ b} → a₁ ≡ a₂ → divₕ c n a₁ b ≡ divₕ c n a₂ b + div-cong₃ refl = refl + + acc≤divₕ[acc] : ∀ {acc} d n j → acc ≤ divₕ acc d n j + acc≤divₕ[acc] {acc} d zero j = ≤-refl + acc≤divₕ[acc] {acc} d (suc n) zero = ≤-trans (n≤1+n acc) (acc≤divₕ[acc] d n d) + acc≤divₕ[acc] {acc} d (suc n) (suc j) = acc≤divₕ[acc] d n j + + pattern inj₂′ x = inj₂ (inj₁ x) + pattern inj₃ x = inj₂ (inj₂ x) + + -- This hideous lemma details the conditions needed for two divisions to + -- be equal when the two offsets (i.e. the 4ᵗʰ parameters) are different. + -- It may be that this triple sum has an elegant simplification to a + -- set of inequalities involving the modulus but I can't find it. + divₕ-offsetEq : ∀ {acc₁ acc₂} d n j k → j ≤ d → k ≤ d → + (acc₁ ≡ acc₂ × j ≤ k × k < modₕ 0 d n d) ⊎ + (acc₁ ≡ acc₂ × modₕ 0 d n d ≤ j × j ≤ k) ⊎ + (acc₁ ≡ suc acc₂ × k < modₕ 0 d n d × modₕ 0 d n d ≤ j) → + divₕ acc₁ d n j ≡ divₕ acc₂ d n k + divₕ-offsetEq d zero j k j≤d k≤d (inj₁ (refl , _)) = refl + divₕ-offsetEq d zero j k j≤d k≤d (inj₂′ (refl , _)) = refl + divₕ-offsetEq d zero j k j≤d k≤d (inj₃ (eq , () , _)) + -- (0 , 0) cases + divₕ-offsetEq d (suc n) zero zero j≤d k≤d (inj₁ (refl , _)) = + divₕ-offsetEq d n d d ≤-refl ≤-refl (inj₂′ (refl , a[modₕ]n<n 0 n d , ≤-refl)) + divₕ-offsetEq d (suc n) zero zero j≤d k≤d (inj₂′ (refl , _)) = + divₕ-offsetEq d n d d ≤-refl ≤-refl (inj₂′ (refl , a[modₕ]n<n 0 n d , ≤-refl)) + divₕ-offsetEq d (suc n) zero zero j≤d k≤d (inj₃ (_ , 0<mod , mod≤0)) = + contradiction (<-≤-trans 0<mod mod≤0) λ() + -- (0 , suc) cases + divₕ-offsetEq d (suc n) zero (suc k) j≤d k≤d (inj₁ (refl , _ , 1+k<mod)) = + divₕ-offsetEq d n d k ≤-refl (<⇒≤ k≤d) (inj₃ (refl , k<1+a[modₕ]n⇒k≤a[modₕ]n 0 (suc k) n d 1+k<mod , a[modₕ]n<n 0 n d)) + divₕ-offsetEq d (suc n) zero (suc k) j≤d k≤d (inj₂′ (refl , mod≤0 , _)) = + divₕ-offsetEq d n d k ≤-refl (<⇒≤ k≤d) (inj₃ (refl , subst (k <_) (sym (a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 0 d n (n≤0⇒n≡0 mod≤0))) k≤d , a[modₕ]n<n 0 n d)) + divₕ-offsetEq d (suc n) zero (suc k) j≤d k≤d (inj₃ (_ , 1+k<mod , mod≤0)) = + contradiction (<-≤-trans 1+k<mod mod≤0) λ() + -- (suc , 0) cases + divₕ-offsetEq d (suc n) (suc j) zero j≤d k≤d (inj₁ (_ , () , _)) + divₕ-offsetEq d (suc n) (suc j) zero j≤d k≤d (inj₂′ (_ , _ , ())) + divₕ-offsetEq d (suc n) (suc j) zero j≤d k≤d (inj₃ (eq , 0<mod , mod≤1+j)) = + divₕ-offsetEq d n j d (<⇒≤ j≤d) ≤-refl (inj₂′ (eq , 1+a[modₕ]n≤1+k⇒a[modₕ]n≤k 0 j n d 0<mod mod≤1+j , <⇒≤ j≤d)) + -- (suc , suc) cases + divₕ-offsetEq d (suc n) (suc j) (suc k) j≤d k≤d (inj₁ (eq , s≤s j≤k , 1+k<mod)) = + divₕ-offsetEq d n j k (<⇒≤ j≤d) (<⇒≤ k≤d) (inj₁ (eq , j≤k , k<1+a[modₕ]n⇒k≤a[modₕ]n 0 (suc k) n d 1+k<mod)) + divₕ-offsetEq d (suc n) (suc j) (suc k) j≤d k≤d (inj₂′ (eq , mod≤1+j , (s≤s j≤k))) with modₕ 0 d (suc n) d ≟ 0 + ... | yes mod≡0 = divₕ-offsetEq d n j k (<⇒≤ j≤d) (<⇒≤ k≤d) (inj₁ (eq , j≤k , subst (k <_) (sym (a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 0 d n mod≡0)) k≤d)) + ... | no mod≢0 = divₕ-offsetEq d n j k (<⇒≤ j≤d) (<⇒≤ k≤d) (inj₂′ (eq , 1+a[modₕ]n≤1+k⇒a[modₕ]n≤k 0 j n d (n≢0⇒n>0 mod≢0) mod≤1+j , j≤k)) + divₕ-offsetEq d (suc n) (suc j) (suc k) j≤d k≤d (inj₃ (eq , k<mod , mod≤1+j)) = + divₕ-offsetEq d n j k (<⇒≤ j≤d) (<⇒≤ k≤d) (inj₃ (eq , k<1+a[modₕ]n⇒k≤a[modₕ]n 0 (suc k) n d k<mod , 1+a[modₕ]n≤1+k⇒a[modₕ]n≤k 0 j n d (≤-<-trans z≤n k<mod) mod≤1+j)) + +------------------------------------------------------------------------ +-- Lemmas for divₕ that also have an interpretation for _/_ + +-- The quotient and remainder are related to the dividend and +-- divisor in the right way. + +div-mod-lemma : ∀ accᵐ accᵈ d n → + accᵐ + accᵈ * suc (accᵐ + n) + d ≡ + modₕ accᵐ (accᵐ + n) d n + divₕ accᵈ (accᵐ + n) d n * suc (accᵐ + n) +div-mod-lemma accᵐ accᵈ zero n = +-identityʳ _ +div-mod-lemma accᵐ accᵈ (suc d) zero rewrite +-identityʳ accᵐ = begin-equality + accᵐ + accᵈ * suc accᵐ + suc d ≡⟨ +-suc _ d ⟩ + suc accᵈ * suc accᵐ + d ≡⟨ div-mod-lemma zero (suc accᵈ) d accᵐ ⟩ + modₕ 0 accᵐ d accᵐ + + divₕ (suc accᵈ) accᵐ d accᵐ * suc accᵐ ≡⟨⟩ + modₕ accᵐ accᵐ (suc d) 0 + + divₕ accᵈ accᵐ (suc d) 0 * suc accᵐ ∎ +div-mod-lemma accᵐ accᵈ (suc d) (suc n) rewrite +-suc accᵐ n = begin-equality + accᵐ + accᵈ * m + suc d ≡⟨ +-suc _ d ⟩ + suc (accᵐ + accᵈ * m + d) ≡⟨ div-mod-lemma (suc accᵐ) accᵈ d n ⟩ + modₕ _ _ d n + divₕ accᵈ _ d n * m ∎ + where + m = 2 + accᵐ + n + +divₕ-restart : ∀ {acc} d n j → j < n → divₕ acc d n j ≡ divₕ (suc acc) d (n ∸ suc j) d +divₕ-restart d (suc n) zero j<n = refl +divₕ-restart d (suc n) (suc j) (s≤s j<n) = divₕ-restart d n j j<n + +divₕ-extractAcc : ∀ acc d n j → divₕ acc d n j ≡ acc + divₕ 0 d n j +divₕ-extractAcc acc d zero j = sym (+-identityʳ acc) +divₕ-extractAcc acc d (suc n) (suc j) = divₕ-extractAcc acc d n j +divₕ-extractAcc acc d (suc n) zero = begin-equality + divₕ (suc acc) d n d ≡⟨ divₕ-extractAcc (suc acc) d n d ⟩ + suc acc + divₕ 0 d n d ≡⟨ sym (+-suc acc _) ⟩ + acc + suc (divₕ 0 d n d) ≡⟨ cong (acc +_) (sym (divₕ-extractAcc 1 d n d)) ⟩ + acc + divₕ 1 d n d ∎ + +divₕ-finish : ∀ {acc} d n j → j ≥ n → divₕ acc d n j ≡ acc +divₕ-finish d zero j j≥n = refl +divₕ-finish d (suc n) (suc j) (s≤s j≥n) = divₕ-finish d n j j≥n + +n[divₕ]n≡1 : ∀ n m → divₕ 0 n (suc m) m ≡ 1 +n[divₕ]n≡1 n zero = refl +n[divₕ]n≡1 n (suc m) = n[divₕ]n≡1 n m + +a[divₕ]1≡a : ∀ acc a → divₕ acc 0 a 0 ≡ acc + a +a[divₕ]1≡a acc zero = sym (+-identityʳ acc) +a[divₕ]1≡a acc (suc a) = trans (a[divₕ]1≡a (suc acc) a) (sym (+-suc acc a)) + +a*n[divₕ]n≡a : ∀ acc a n → divₕ acc n (a * suc n) n ≡ acc + a +a*n[divₕ]n≡a acc zero n = sym (+-identityʳ acc) +a*n[divₕ]n≡a acc (suc a) n = begin-equality + divₕ acc n (suc a * suc n) n ≡⟨ divₕ-restart n (suc a * suc n) n (m≤m+n (suc n) _) ⟩ + divₕ (suc acc) n (suc a * suc n ∸ suc n) n ≡⟨⟩ + divₕ (suc acc) n (suc n + a * suc n ∸ suc n) n ≡⟨ div-cong₃ (m+n∸m≡n (suc n) (a * suc n)) ⟩ + divₕ (suc acc) n (a * suc n) n ≡⟨ a*n[divₕ]n≡a (suc acc) a n ⟩ + suc acc + a ≡⟨ sym (+-suc acc a) ⟩ + acc + suc a ∎ + ++-distrib-divₕ : ∀ acc k m n j → modₕ k (k + j) m j + modₕ 0 (k + j) n (k + j) < suc (k + j) → + divₕ acc (k + j) (m + n) j ≡ divₕ acc (k + j) m j + divₕ 0 (k + j) n (k + j) ++-distrib-divₕ acc k (suc m) n zero leq rewrite +-identityʳ k = +-distrib-divₕ (suc acc) 0 m n k leq ++-distrib-divₕ acc k (suc m) n (suc j) leq rewrite +-suc k j = +-distrib-divₕ acc (suc k) m n j leq ++-distrib-divₕ acc k zero n j leq = begin-equality + divₕ acc (k + j) n j ≡⟨ divₕ-extractAcc acc (k + j) n j ⟩ + acc + divₕ 0 (k + j) n j ≡⟨ cong (acc +_) (divₕ-offsetEq _ n j _ (m≤n+m j k) ≤-refl case) ⟩ + acc + divₕ 0 (k + j) n (k + j) ∎ + where + case = inj₂′ (refl , +-cancelˡ-≤ (suc k) _ _ leq , m≤n+m j k) + +divₕ-mono-≤ : ∀ {acc} k {m n o p} → m ≤ n → p ≤ o → divₕ acc (k + o) m o ≤ divₕ acc (k + p) n p +divₕ-mono-≤ {acc} k {0} {n} {_} {p} z≤n p≤o = acc≤divₕ[acc] (k + p) n p +divₕ-mono-≤ {acc} k {_} {_} {suc o} {suc p} (s≤s m≤n) (s≤s p≤o) + rewrite +-suc k o | +-suc k p = divₕ-mono-≤ (suc k) m≤n p≤o +divₕ-mono-≤ {acc} k {suc m} {suc n} {o} {0} (s≤s m≤n) z≤n with o <? suc m +... | no o≮1+m rewrite +-identityʳ k = begin + divₕ acc (k + o) (suc m) o ≡⟨ divₕ-finish (k + o) (suc m) o (≮⇒≥ o≮1+m) ⟩ + acc ≤⟨ n≤1+n acc ⟩ + suc acc ≤⟨ acc≤divₕ[acc] k n k ⟩ + divₕ (suc acc) k n k ∎ +... | yes o<1+m rewrite +-identityʳ k = begin + divₕ acc (k + o) (suc m) o ≡⟨ divₕ-restart (k + o) (suc m) o o<1+m ⟩ + divₕ (suc acc) (k + o) (m ∸ o) (k + o) ≤⟨ divₕ-mono-≤ 0 (≤-trans (m∸n≤m m o) m≤n) (m≤m+n k o) ⟩ + divₕ (suc acc) k n k ∎ \ No newline at end of file diff --git a/Data.Nat.DivMod.html b/Data.Nat.DivMod.html index ab6b8868..6cff7e16 100644 --- a/Data.Nat.DivMod.html +++ b/Data.Nat.DivMod.html @@ -11,464 +11,468 @@ open import Agda.Builtin.Nat using (div-helper; mod-helper) -open import Data.Fin.Base using (Fin; toℕ; fromℕ<) -open import Data.Fin.Properties using (toℕ-fromℕ<) +open import Data.Fin.Base using (Fin; toℕ; fromℕ<) +open import Data.Fin.Properties using (toℕ-fromℕ<) open import Data.Nat.Base as Nat open import Data.Nat.DivMod.Core open import Data.Nat.Divisibility.Core open import Data.Nat.Induction open import Data.Nat.Properties -open import Function using (_$_) -open import Relation.Binary.PropositionalEquality -open import Relation.Nullary.Decidable using (yes; no) -open import Relation.Nullary.Decidable using (False; toWitnessFalse) - -import Algebra.Properties.CommutativeSemigroup *-commutativeSemigroup as *-CS - -open ≤-Reasoning - ------------------------------------------------------------------------- --- Definitions - -open import Data.Nat.Base public - using (_%_; _/_) - ------------------------------------------------------------------------- --- Relationship between _%_ and _div_ - -m≡m%n+[m/n]*n : ∀ m n .{{_ : NonZero n}} → m ≡ m % n + (m / n) * n -m≡m%n+[m/n]*n m (suc n) = div-mod-lemma 0 0 m n - -m%n≡m∸m/n*n : ∀ m n .{{_ : NonZero n}} → m % n ≡ m ∸ (m / n) * n -m%n≡m∸m/n*n m n = begin-equality - m % n ≡˘⟨ m+n∸n≡m (m % n) m/n*n ⟩ - m % n + m/n*n ∸ m/n*n ≡˘⟨ cong (_∸ m/n*n) (m≡m%n+[m/n]*n m n) ⟩ - m ∸ m/n*n ∎ - where m/n*n = (m / n) * n - ------------------------------------------------------------------------- --- Properties of _%_ - -%-congˡ : ∀ {m n o} .⦃ _ : NonZero o ⦄ → m ≡ n → m % o ≡ n % o -%-congˡ refl = refl - -%-congʳ : ∀ {m n o} .⦃ _ : NonZero m ⦄ .⦃ _ : NonZero n ⦄ → m ≡ n → - o % m ≡ o % n -%-congʳ refl = refl - -n%1≡0 : ∀ n → n % 1 ≡ 0 -n%1≡0 = a[modₕ]1≡0 - -n%n≡0 : ∀ n .{{_ : NonZero n}} → n % n ≡ 0 -n%n≡0 (suc n-1) = n[modₕ]n≡0 0 n-1 - -m%n%n≡m%n : ∀ m n .{{_ : NonZero n}} → m % n % n ≡ m % n -m%n%n≡m%n m (suc n-1) = modₕ-idem 0 m n-1 - -[m+n]%n≡m%n : ∀ m n .{{_ : NonZero n}} → (m + n) % n ≡ m % n -[m+n]%n≡m%n m (suc n-1) = a+n[modₕ]n≡a[modₕ]n 0 m n-1 - -[m+kn]%n≡m%n : ∀ m k n .{{_ : NonZero n}} → (m + k * n) % n ≡ m % n -[m+kn]%n≡m%n m zero n = cong (_% n) (+-identityʳ m) -[m+kn]%n≡m%n m (suc k) n = begin-equality - (m + (n + k * n)) % n ≡⟨ cong (_% n) (sym (+-assoc m n (k * n))) ⟩ - (m + n + k * n) % n ≡⟨ [m+kn]%n≡m%n (m + n) k n ⟩ - (m + n) % n ≡⟨ [m+n]%n≡m%n m n ⟩ - m % n ∎ - -m≤n⇒[n∸m]%m≡n%m : ∀ {m n} .⦃ _ : NonZero m ⦄ → m ≤ n → - (n ∸ m) % m ≡ n % m -m≤n⇒[n∸m]%m≡n%m {m} {n} m≤n = begin-equality - (n ∸ m) % m ≡˘⟨ [m+n]%n≡m%n (n ∸ m) m ⟩ - (n ∸ m + m) % m ≡⟨ cong (_% m) (m∸n+n≡m m≤n) ⟩ - n % m ∎ - -m*n≤o⇒[o∸m*n]%n≡o%n : ∀ m {n o} .⦃ _ : NonZero n ⦄ → m * n ≤ o → - (o ∸ m * n) % n ≡ o % n -m*n≤o⇒[o∸m*n]%n≡o%n m {n} {o} m*n≤o = begin-equality - (o ∸ m * n) % n ≡˘⟨ [m+kn]%n≡m%n (o ∸ m * n) m n ⟩ - (o ∸ m * n + m * n) % n ≡⟨ cong (_% n) (m∸n+n≡m m*n≤o) ⟩ - o % n ∎ - -m∣n⇒o%n%m≡o%m : ∀ m n o .⦃ _ : NonZero m ⦄ .⦃ _ : NonZero n ⦄ → m ∣ n → - o % n % m ≡ o % m -m∣n⇒o%n%m≡o%m m n o (divides p refl) = begin-equality - o % pm % m ≡⟨ %-congˡ (m%n≡m∸m/n*n o pm) ⟩ - (o ∸ o / pm * pm) % m ≡˘⟨ cong (λ # → (o ∸ #) % m) (*-assoc (o / pm) p m) ⟩ - (o ∸ o / pm * p * m) % m ≡⟨ m*n≤o⇒[o∸m*n]%n≡o%n (o / pm * p) lem ⟩ - o % m ∎ - where - pm = p * m - - lem : o / pm * p * m ≤ o - lem = begin - o / pm * p * m ≡⟨ *-assoc (o / pm) p m ⟩ - -- Sort out dependencies in this file, then use m/n*n≤m instead. - o / pm * pm ≤⟨ m≤m+n (o / pm * pm) (o % pm) ⟩ - o / pm * pm + o % pm ≡⟨ +-comm _ (o % pm) ⟩ - o % pm + o / pm * pm ≡˘⟨ m≡m%n+[m/n]*n o pm ⟩ - o ∎ - -m*n%n≡0 : ∀ m n .{{_ : NonZero n}} → (m * n) % n ≡ 0 -m*n%n≡0 m (suc n-1) = [m+kn]%n≡m%n 0 m (suc n-1) - -m%n<n : ∀ m n .{{_ : NonZero n}} → m % n < n -m%n<n m (suc n-1) = s≤s (a[modₕ]n<n 0 m n-1) - -m%n≤n : ∀ m n .{{_ : NonZero n}} → m % n ≤ n -m%n≤n m n = <⇒≤ (m%n<n m n) - -m%n≤m : ∀ m n .{{_ : NonZero n}} → m % n ≤ m -m%n≤m m (suc n-1) = a[modₕ]n≤a 0 m n-1 - -m≤n⇒m%n≡m : ∀ {m n} → m ≤ n → m % suc n ≡ m -m≤n⇒m%n≡m {m} {n} m≤n with ≤⇒≤″ m≤n -... | less-than-or-equal {k} refl = a≤n⇒a[modₕ]n≡a 0 (m + k) m k - -m<n⇒m%n≡m : ∀ {m n} .⦃ _ : NonZero n ⦄ → m < n → m % n ≡ m -m<n⇒m%n≡m {m} {suc n} m<n = m≤n⇒m%n≡m (<⇒≤pred m<n) - -%-pred-≡0 : ∀ {m n} .{{_ : NonZero n}} → (suc m % n) ≡ 0 → (m % n) ≡ n ∸ 1 -%-pred-≡0 {m} {suc n-1} eq = a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 0 n-1 m eq - -m<[1+n%d]⇒m≤[n%d] : ∀ {m} n d .{{_ : NonZero d}} → m < suc n % d → m ≤ n % d -m<[1+n%d]⇒m≤[n%d] {m} n (suc d-1) = k<1+a[modₕ]n⇒k≤a[modₕ]n 0 m n d-1 - -[1+m%d]≤1+n⇒[m%d]≤n : ∀ m n d .{{_ : NonZero d}} → 0 < suc m % d → suc m % d ≤ suc n → m % d ≤ n -[1+m%d]≤1+n⇒[m%d]≤n m n (suc d-1) leq = 1+a[modₕ]n≤1+k⇒a[modₕ]n≤k 0 n m d-1 leq - -%-distribˡ-+ : ∀ m n d .{{_ : NonZero d}} → (m + n) % d ≡ ((m % d) + (n % d)) % d -%-distribˡ-+ m n d@(suc d-1) = begin-equality - (m + n) % d ≡⟨ cong (λ v → (v + n) % d) (m≡m%n+[m/n]*n m d) ⟩ - (m % d + m / d * d + n) % d ≡⟨ cong (_% d) (+-assoc (m % d) _ n) ⟩ - (m % d + (m / d * d + n)) % d ≡⟨ cong (λ v → (m % d + v) % d) (+-comm _ n) ⟩ - (m % d + (n + m / d * d)) % d ≡⟨ cong (_% d) (sym (+-assoc (m % d) n _)) ⟩ - (m % d + n + m / d * d) % d ≡⟨ [m+kn]%n≡m%n (m % d + n) (m / d) d ⟩ - (m % d + n) % d ≡⟨ cong (λ v → (m % d + v) % d) (m≡m%n+[m/n]*n n d) ⟩ - (m % d + (n % d + (n / d) * d)) % d ≡⟨ sym (cong (_% d) (+-assoc (m % d) (n % d) _)) ⟩ - (m % d + n % d + (n / d) * d) % d ≡⟨ [m+kn]%n≡m%n (m % d + n % d) (n / d) d ⟩ - (m % d + n % d) % d ∎ - -%-distribˡ-* : ∀ m n d .{{_ : NonZero d}} → (m * n) % d ≡ ((m % d) * (n % d)) % d -%-distribˡ-* m n d@(suc d-1) = begin-equality - (m * n) % d ≡⟨ cong (λ h → (h * n) % d) (m≡m%n+[m/n]*n m d) ⟩ - ((m′ + k * d) * n) % d ≡⟨ cong (λ h → ((m′ + k * d) * h) % d) (m≡m%n+[m/n]*n n d) ⟩ - ((m′ + k * d) * (n′ + j * d)) % d ≡⟨ cong (_% d) lemma ⟩ - (m′ * n′ + (m′ * j + (n′ + j * d) * k) * d) % d ≡⟨ [m+kn]%n≡m%n (m′ * n′) (m′ * j + (n′ + j * d) * k) d ⟩ - (m′ * n′) % d ≡⟨⟩ - ((m % d) * (n % d)) % d ∎ - where - m′ = m % d - n′ = n % d - k = m / d - j = n / d - lemma : (m′ + k * d) * (n′ + j * d) ≡ m′ * n′ + (m′ * j + (n′ + j * d) * k) * d - lemma = begin-equality - (m′ + k * d) * (n′ + j * d) ≡⟨ *-distribʳ-+ (n′ + j * d) m′ (k * d) ⟩ - m′ * (n′ + j * d) + (k * d) * (n′ + j * d) ≡⟨ cong₂ _+_ (*-distribˡ-+ m′ n′ (j * d)) (*-comm (k * d) (n′ + j * d)) ⟩ - (m′ * n′ + m′ * (j * d)) + (n′ + j * d) * (k * d) ≡⟨ +-assoc (m′ * n′) (m′ * (j * d)) ((n′ + j * d) * (k * d)) ⟩ - m′ * n′ + (m′ * (j * d) + (n′ + j * d) * (k * d)) ≡˘⟨ cong (m′ * n′ +_) (cong₂ _+_ (*-assoc m′ j d) (*-assoc (n′ + j * d) k d)) ⟩ - m′ * n′ + ((m′ * j) * d + ((n′ + j * d) * k) * d) ≡˘⟨ cong (m′ * n′ +_) (*-distribʳ-+ d (m′ * j) ((n′ + j * d) * k)) ⟩ - m′ * n′ + (m′ * j + (n′ + j * d) * k) * d ∎ - -%-remove-+ˡ : ∀ {m} n {d} .{{_ : NonZero d}} → d ∣ m → (m + n) % d ≡ n % d -%-remove-+ˡ {m} n {d@(suc d-1)} (divides p refl) = begin-equality - (p * d + n) % d ≡⟨ cong (_% d) (+-comm (p * d) n) ⟩ - (n + p * d) % d ≡⟨ [m+kn]%n≡m%n n p d ⟩ - n % d ∎ - -%-remove-+ʳ : ∀ m {n d} .{{_ : NonZero d}} → d ∣ n → (m + n) % d ≡ m % d -%-remove-+ʳ m {n} {suc _} eq rewrite +-comm m n = %-remove-+ˡ {n} m eq - ------------------------------------------------------------------------- --- Properties of _/_ - -/-congˡ : ∀ {m n o : ℕ} .{{_ : NonZero o}} → - m ≡ n → m / o ≡ n / o -/-congˡ refl = refl - -/-congʳ : ∀ {m n o : ℕ} .{{_ : NonZero n}} .{{_ : NonZero o}} → - n ≡ o → m / n ≡ m / o -/-congʳ refl = refl - -0/n≡0 : ∀ n .{{_ : NonZero n}} → 0 / n ≡ 0 -0/n≡0 (suc n-1) = refl - -n/1≡n : ∀ n → n / 1 ≡ n -n/1≡n n = a[divₕ]1≡a 0 n - -n/n≡1 : ∀ n .{{_ : NonZero n}} → n / n ≡ 1 -n/n≡1 (suc n-1) = n[divₕ]n≡1 n-1 n-1 - -m*n/n≡m : ∀ m n .{{_ : NonZero n}} → m * n / n ≡ m -m*n/n≡m m (suc n-1) = a*n[divₕ]n≡a 0 m n-1 - -m/n*n≡m : ∀ {m n} .{{_ : NonZero n}} → n ∣ m → m / n * n ≡ m -m/n*n≡m {_} {n@(suc n-1)} (divides q refl) = cong (_* n) (m*n/n≡m q n) - -m*[n/m]≡n : ∀ {m n} .{{_ : NonZero m}} → m ∣ n → m * (n / m) ≡ n -m*[n/m]≡n {m} m∣n = trans (*-comm m (_ / m)) (m/n*n≡m m∣n) - -m/n*n≤m : ∀ m n .{{_ : NonZero n}} → (m / n) * n ≤ m -m/n*n≤m m n@(suc n-1) = begin - (m / n) * n ≤⟨ m≤m+n ((m / n) * n) (m % n) ⟩ - (m / n) * n + m % n ≡⟨ +-comm _ (m % n) ⟩ - m % n + (m / n) * n ≡⟨ sym (m≡m%n+[m/n]*n m n) ⟩ - m ∎ - -m/n≤m : ∀ m n .{{_ : NonZero n}} → (m / n) ≤ m -m/n≤m m n = *-cancelʳ-≤ (m / n) m n (begin - (m / n) * n ≤⟨ m/n*n≤m m n ⟩ - m ≤⟨ m≤m*n m n ⟩ - m * n ∎) - -m/n<m : ∀ m n .{{_ : NonZero m}} .{{_ : NonZero n}} → n ≥ 2 → m / n < m -m/n<m m n n≥2 = *-cancelʳ-< _ (m / n) m (begin-strict - (m / n) * n ≤⟨ m/n*n≤m m n ⟩ - m <⟨ m<m*n m n n≥2 ⟩ - m * n ∎) - -/-mono-≤ : ∀ {m n o p} .{{_ : NonZero o}} .{{_ : NonZero p}} → - m ≤ n → o ≥ p → m / o ≤ n / p -/-mono-≤ m≤n (s≤s o≥p) = divₕ-mono-≤ 0 m≤n o≥p - -/-monoˡ-≤ : ∀ {m n} o .{{_ : NonZero o}} → m ≤ n → m / o ≤ n / o -/-monoˡ-≤ o m≤n = /-mono-≤ m≤n (≤-refl {o}) - -/-monoʳ-≤ : ∀ m {n o} .{{_ : NonZero n}} .{{_ : NonZero o}} → - n ≥ o → m / n ≤ m / o -/-monoʳ-≤ m n≥o = /-mono-≤ ≤-refl n≥o - -/-cancelʳ-≡ : ∀ {m n o} .{{_ : NonZero o}} → - o ∣ m → o ∣ n → m / o ≡ n / o → m ≡ n -/-cancelʳ-≡ {m} {n} {o} o∣m o∣n m/o≡n/o = begin-equality - m ≡˘⟨ m*[n/m]≡n {o} {m} o∣m ⟩ - o * (m / o) ≡⟨ cong (o *_) m/o≡n/o ⟩ - o * (n / o) ≡⟨ m*[n/m]≡n {o} {n} o∣n ⟩ - n ∎ - -m<n⇒m/n≡0 : ∀ {m n} .{{_ : NonZero n}} → m < n → m / n ≡ 0 -m<n⇒m/n≡0 {m} {suc n-1} (s≤s m≤n) = divₕ-finish n-1 m n-1 m≤n - -m≥n⇒m/n>0 : ∀ {m n} .{{_ : NonZero n}} → m ≥ n → m / n > 0 -m≥n⇒m/n>0 {m@(suc _)} {n@(suc _)} m≥n = begin - 1 ≡⟨ sym (n/n≡1 m) ⟩ - m / m ≤⟨ /-monoʳ-≤ m m≥n ⟩ - m / n ∎ - -+-distrib-/ : ∀ m n {d} .{{_ : NonZero d}} → m % d + n % d < d → - (m + n) / d ≡ m / d + n / d -+-distrib-/ m n {suc d-1} leq = +-distrib-divₕ 0 0 m n d-1 leq - -+-distrib-/-∣ˡ : ∀ {m} n {d} .{{_ : NonZero d}} → - d ∣ m → (m + n) / d ≡ m / d + n / d -+-distrib-/-∣ˡ {m} n {d} (divides p refl) = +-distrib-/ m n (begin-strict - p * d % d + n % d ≡⟨ cong (_+ n % d) (m*n%n≡0 p d) ⟩ - n % d <⟨ m%n<n n d ⟩ - d ∎) - -+-distrib-/-∣ʳ : ∀ m {n} {d} .{{_ : NonZero d}} → - d ∣ n → (m + n) / d ≡ m / d + n / d -+-distrib-/-∣ʳ m {n} {d} (divides p refl) = +-distrib-/ m n (begin-strict - m % d + p * d % d ≡⟨ cong (m % d +_) (m*n%n≡0 p d) ⟩ - m % d + 0 ≡⟨ +-identityʳ _ ⟩ - m % d <⟨ m%n<n m d ⟩ - d ∎) - -m/n≡1+[m∸n]/n : ∀ {m n} .{{_ : NonZero n}} → m ≥ n → m / n ≡ 1 + ((m ∸ n) / n) -m/n≡1+[m∸n]/n {m@(suc m-1)} {n@(suc n-1)} m≥n = begin-equality - m / n ≡⟨⟩ - div-helper 0 n-1 m n-1 ≡⟨ divₕ-restart n-1 m n-1 m≥n ⟩ - div-helper 1 n-1 (m ∸ n) n-1 ≡⟨ divₕ-extractAcc 1 n-1 (m ∸ n) n-1 ⟩ - 1 + (div-helper 0 n-1 (m ∸ n) n-1) ≡⟨⟩ - 1 + (m ∸ n) / n ∎ - -m*n/m*o≡n/o : ∀ m n o .{{_ : NonZero o}} .{{_ : NonZero (m * o)}} → - (m * n) / (m * o) ≡ n / o -m*n/m*o≡n/o m@(suc m-1) n o = helper (<-wellFounded n) - where - helper : ∀ {n} → Acc _<_ n → (m * n) / (m * o) ≡ n / o - helper {n} (acc rec) with n <? o - ... | yes n<o = trans (m<n⇒m/n≡0 (*-monoʳ-< m n<o)) (sym (m<n⇒m/n≡0 n<o)) - ... | no n≮o = begin-equality - (m * n) / (m * o) ≡⟨ m/n≡1+[m∸n]/n (*-monoʳ-≤ m (≮⇒≥ n≮o)) ⟩ - 1 + (m * n ∸ m * o) / (m * o) ≡˘⟨ cong (λ v → 1 + v / (m * o)) (*-distribˡ-∸ m n o) ⟩ - 1 + (m * (n ∸ o)) / (m * o) ≡⟨ cong suc (helper (rec (n ∸ o) n∸o<n)) ⟩ - 1 + (n ∸ o) / o ≡˘⟨ cong₂ _+_ (n/n≡1 o) refl ⟩ - o / o + (n ∸ o) / o ≡˘⟨ +-distrib-/-∣ˡ (n ∸ o) (divides 1 ((sym (*-identityˡ o)))) ⟩ - (o + (n ∸ o)) / o ≡⟨ cong (_/ o) (m+[n∸m]≡n (≮⇒≥ n≮o)) ⟩ - n / o ∎ - where n∸o<n = ∸-monoʳ-< (n≢0⇒n>0 (≢-nonZero⁻¹ o)) (≮⇒≥ n≮o) - -m*n/o*n≡m/o : ∀ m n o .⦃ _ : NonZero o ⦄ ⦃ _ : NonZero (o * n) ⦄ → - m * n / (o * n) ≡ m / o -m*n/o*n≡m/o m n o ⦃ _ ⦄ ⦃ o*n≢0 ⦄ = begin-equality - m * n / (o * n) ≡⟨ /-congˡ (*-comm m n) ⟩ - n * m / (o * n) ≡⟨ /-congʳ (*-comm o n) ⟩ - n * m / (n * o) ≡⟨ m*n/m*o≡n/o n m o ⟩ - m / o ∎ - where instance n*o≢0 = subst NonZero (*-comm o n) o*n≢0 - -m<n*o⇒m/o<n : ∀ {m n o} .⦃ _ : NonZero o ⦄ → m < n * o → m / o < n -m<n*o⇒m/o<n {m} {suc n} {o} m<n*o with m <? o -... | yes m<o = begin-strict - m / o ≡⟨ m<n⇒m/n≡0 m<o ⟩ - 0 <⟨ z<s ⟩ - suc n ∎ -... | no m≮o = begin-strict - m / o ≡⟨ m/n≡1+[m∸n]/n (≮⇒≥ m≮o) ⟩ - suc ((m ∸ o) / o) <⟨ s≤s (m<n*o⇒m/o<n lem) ⟩ - suc n ∎ - where - lem : m ∸ o < n * o - lem = begin-strict - m ∸ o <⟨ ∸-monoˡ-< m<n*o (≮⇒≥ m≮o) ⟩ - o + n * o ∸ o ≡⟨ m+n∸m≡n o (n * o) ⟩ - n * o ∎ - -[m∸n]/n≡m/n∸1 : ∀ m n .⦃ _ : NonZero n ⦄ → (m ∸ n) / n ≡ pred (m / n) -[m∸n]/n≡m/n∸1 m n with m <? n -... | yes m<n = begin-equality - (m ∸ n) / n ≡⟨ m<n⇒m/n≡0 (<-transʳ (m∸n≤m m n) m<n) ⟩ - 0 ≡⟨⟩ - 0 ∸ 1 ≡˘⟨ cong (_∸ 1) (m<n⇒m/n≡0 m<n) ⟩ - m / n ∸ 1 ≡⟨⟩ - pred (m / n) ∎ -... | no m≮n = begin-equality - (m ∸ n) / n ≡⟨⟩ - suc ((m ∸ n) / n) ∸ 1 ≡˘⟨ cong (_∸ 1) (m/n≡1+[m∸n]/n (≮⇒≥ m≮n)) ⟩ - m / n ∸ 1 ≡⟨⟩ - pred (m / n) ∎ - -[m∸n*o]/o≡m/o∸n : ∀ m n o .⦃ _ : NonZero o ⦄ → (m ∸ n * o) / o ≡ m / o ∸ n -[m∸n*o]/o≡m/o∸n m zero o = refl -[m∸n*o]/o≡m/o∸n m (suc n) o = begin-equality - (m ∸ (o + n * o)) / o ≡˘⟨ /-congˡ (∸-+-assoc m o (n * o)) ⟩ - (m ∸ o ∸ n * o) / o ≡⟨ [m∸n*o]/o≡m/o∸n (m ∸ o) n o ⟩ - (m ∸ o) / o ∸ n ≡⟨ cong (_∸ n) ([m∸n]/n≡m/n∸1 m o) ⟩ - m / o ∸ 1 ∸ n ≡⟨ ∸-+-assoc (m / o) 1 n ⟩ - m / o ∸ suc n ∎ - -m/n/o≡m/[n*o] : ∀ m n o .⦃ _ : NonZero n ⦄ .⦃ _ : NonZero o ⦄ - .⦃ _ : NonZero (n * o) ⦄ → m / n / o ≡ m / (n * o) -m/n/o≡m/[n*o] m n o = begin-equality - m / n / o ≡⟨ /-congˡ {o = o} (/-congˡ (m≡m%n+[m/n]*n m n*o)) ⟩ - (m % n*o + m / n*o * n*o) / n / o ≡⟨ /-congˡ (+-distrib-/-∣ʳ (m % n*o) lem₁) ⟩ - (m % n*o / n + m / n*o * n*o / n) / o ≡⟨ cong (λ # → (m % n*o / n + #) / o) lem₂ ⟩ - (m % n*o / n + m / n*o * o) / o ≡⟨ +-distrib-/-∣ʳ (m % n*o / n) (divides (m / n*o) refl) ⟩ - m % n*o / n / o + m / n*o * o / o ≡⟨ cong (m % n*o / n / o +_) (m*n/n≡m (m / n*o) o) ⟩ - m % n*o / n / o + m / n*o ≡⟨ cong (_+ m / n*o) (m<n⇒m/n≡0 (m<n*o⇒m/o<n {n = o} lem₃)) ⟩ - m / n*o ∎ - where - n*o = n * o - o*n = o * n - - lem₁ : n ∣ m / n*o * n*o - lem₁ = divides (m / n*o * o) $ begin-equality - m / n*o * n*o ≡⟨ cong (m / n*o *_) (*-comm n o) ⟩ - m / n*o * o*n ≡˘⟨ *-assoc (m / n*o) o n ⟩ - m / n*o * o * n ∎ - - lem₂ : m / n*o * n*o / n ≡ m / n*o * o - lem₂ = begin-equality - m / n*o * n*o / n ≡⟨ cong (λ # → m / n*o * # / n) (*-comm n o) ⟩ - m / n*o * o*n / n ≡˘⟨ /-congˡ (*-assoc (m / n*o) o n) ⟩ - m / n*o * o * n / n ≡⟨ m*n/n≡m (m / n*o * o) n ⟩ - m / n*o * o ∎ - - lem₃ : m % n*o < o*n - lem₃ = begin-strict - m % n*o <⟨ m%n<n m n*o ⟩ - n*o ≡⟨ *-comm n o ⟩ - o*n ∎ - -*-/-assoc : ∀ m {n d} .{{_ : NonZero d}} → d ∣ n → m * n / d ≡ m * (n / d) -*-/-assoc zero {_} {d@(suc _)} d∣n = 0/n≡0 (suc d) -*-/-assoc (suc m) {n} {d@(suc _)} d∣n = begin-equality - (n + m * n) / d ≡⟨ +-distrib-/-∣ˡ _ d∣n ⟩ - n / d + (m * n) / d ≡⟨ cong (n / d +_) (*-/-assoc m d∣n) ⟩ - n / d + m * (n / d) ∎ - -/-*-interchange : ∀ {m n o p} .{{_ : NonZero o}} .{{_ : NonZero p}} .{{_ : NonZero (o * p)}} → - o ∣ m → p ∣ n → (m * n) / (o * p) ≡ (m / o) * (n / p) -/-*-interchange {m} {n} {o@(suc _)} {p@(suc _)} o∣m p∣n = *-cancelˡ-≡ _ _ (o * p) (begin-equality - (o * p) * ((m * n) / (o * p)) ≡⟨ m*[n/m]≡n (*-pres-∣ o∣m p∣n) ⟩ - m * n ≡˘⟨ cong₂ _*_ (m*[n/m]≡n o∣m) (m*[n/m]≡n p∣n) ⟩ - (o * (m / o)) * (p * (n / p)) ≡⟨ [m*n]*[o*p]≡[m*o]*[n*p] o (m / o) p (n / p) ⟩ - (o * p) * ((m / o) * (n / p)) ∎) - -m*n/m!≡n/[m∸1]! : ∀ m n .{{_ : NonZero m}} → - (m * n / m !) {{m !≢0}} ≡ (n / (pred m) !) {{pred m !≢0}} -m*n/m!≡n/[m∸1]! (suc m) n = m*n/m*o≡n/o (suc m) n (m !) {{m !≢0}} {{suc m !≢0}} - -m%[n*o]/o≡m/o%n : ∀ m n o .⦃ _ : NonZero n ⦄ .⦃ _ : NonZero o ⦄ - ⦃ _ : NonZero (n * o) ⦄ → m % (n * o) / o ≡ m / o % n -m%[n*o]/o≡m/o%n m n o ⦃ _ ⦄ ⦃ _ ⦄ ⦃ n*o≢0 ⦄ = begin-equality - m % (n * o) / o ≡⟨ /-congˡ (m%n≡m∸m/n*n m (n * o)) ⟩ - (m ∸ (m / (n * o) * (n * o))) / o ≡˘⟨ cong (λ # → (m ∸ #) / o) (*-assoc (m / (n * o)) n o) ⟩ - (m ∸ (m / (n * o) * n * o)) / o ≡⟨ [m∸n*o]/o≡m/o∸n m (m / (n * o) * n) o ⟩ - m / o ∸ m / (n * o) * n ≡⟨ cong (λ # → m / o ∸ # * n) (/-congʳ (*-comm n o)) ⟩ - m / o ∸ m / (o * n) * n ≡˘⟨ cong (λ # → m / o ∸ # * n) (m/n/o≡m/[n*o] m o n ) ⟩ - m / o ∸ m / o / n * n ≡˘⟨ m%n≡m∸m/n*n (m / o) n ⟩ - m / o % n ∎ - where instance o*n≢0 = subst NonZero (*-comm n o) n*o≢0 - -m%n*o≡m*o%[n*o] : ∀ m n o .⦃ _ : NonZero n ⦄ ⦃ _ : NonZero (n * o) ⦄ → - m % n * o ≡ m * o % (n * o) -m%n*o≡m*o%[n*o] m n o ⦃ _ ⦄ ⦃ n*o≢0 ⦄ = begin-equality - m % n * o ≡⟨ cong (_* o) (m%n≡m∸m/n*n m n) ⟩ - (m ∸ m / n * n) * o ≡⟨ *-distribʳ-∸ o m (m / n * n) ⟩ - m * o ∸ m / n * n * o ≡˘⟨ cong (λ # → m * o ∸ # * n * o) (m*n/o*n≡m/o m o n) ⟩ - m * o ∸ m * o / (n * o) * n * o ≡⟨ cong (m * o ∸_) (*-assoc (m * o / (n * o)) n o) ⟩ - m * o ∸ m * o / (n * o) * (n * o) ≡˘⟨ m%n≡m∸m/n*n (m * o) (n * o) ⟩ - m * o % (n * o) ∎ - -[m*n+o]%[p*n]≡[m*n]%[p*n]+o : ∀ m {n o} p ⦃ _ : NonZero (p * n) ⦄ → o < n → - (m * n + o) % (p * n) ≡ (m * n) % (p * n) + o -[m*n+o]%[p*n]≡[m*n]%[p*n]+o m {n} {o} p@(suc p-1) ⦃ p*n≢0 ⦄ o<n = begin-equality - (mn + o) % pn ≡⟨ %-distribˡ-+ mn o pn ⟩ - (mn % pn + o % pn) % pn ≡⟨ cong (λ # → (mn % pn + #) % pn) (m<n⇒m%n≡m (m<n⇒m<o*n p o<n)) ⟩ - (mn % pn + o) % pn ≡⟨ m<n⇒m%n≡m lem₂ ⟩ - mn % pn + o ∎ - where - mn = m * n - pn = p * n - - lem₁ : mn % pn ≤ p-1 * n - lem₁ = begin - mn % pn ≡˘⟨ m%n*o≡m*o%[n*o] m p n ⟩ - (m % p) * n ≤⟨ *-monoˡ-≤ n (m<1+n⇒m≤n (m%n<n m p)) ⟩ - p-1 * n ∎ - - lem₂ : mn % pn + o < pn - lem₂ = begin-strict - mn % pn + o <⟨ +-mono-≤-< lem₁ o<n ⟩ - p-1 * n + n ≡⟨ +-comm (p-1 * n) n ⟩ - pn ∎ - ------------------------------------------------------------------------- --- A specification of integer division. - -record DivMod (dividend divisor : ℕ) : Set where - constructor result - field - quotient : ℕ - remainder : Fin divisor - property : dividend ≡ toℕ remainder + quotient * divisor - -infixl 7 _div_ _mod_ _divMod_ - -_div_ : (dividend divisor : ℕ) .{{_ : NonZero divisor}} → ℕ -_div_ = _/_ - -_mod_ : (dividend divisor : ℕ) .{{_ : NonZero divisor}} → Fin divisor -m mod (suc n) = fromℕ< (m%n<n m (suc n)) - -_divMod_ : (dividend divisor : ℕ) .{{_ : NonZero divisor}} → - DivMod dividend divisor -m divMod n@(suc n-1) = result (m / n) (m mod n) (begin-equality - m ≡⟨ m≡m%n+[m/n]*n m n ⟩ - m % n + [m/n]*n ≡˘⟨ cong (_+ [m/n]*n) (toℕ-fromℕ< (m%n<n m n)) ⟩ - toℕ (fromℕ< (m%n<n m n)) + [m/n]*n ∎) - where [m/n]*n = m / n * n +open import Function.Base using (_$_) +open import Relation.Binary.PropositionalEquality +open import Relation.Nullary.Decidable using (yes; no) + +open ≤-Reasoning + +private + variable + m n o p : ℕ + +------------------------------------------------------------------------ +-- Definitions + +open import Data.Nat.Base public + using (_%_; _/_) + +------------------------------------------------------------------------ +-- Relationship between _%_ and _div_ + +m≡m%n+[m/n]*n : ∀ m n .{{_ : NonZero n}} → m ≡ m % n + (m / n) * n +m≡m%n+[m/n]*n m (suc n) = div-mod-lemma 0 0 m n + +m%n≡m∸m/n*n : ∀ m n .{{_ : NonZero n}} → m % n ≡ m ∸ (m / n) * n +m%n≡m∸m/n*n m n = begin-equality + m % n ≡⟨ m+n∸n≡m (m % n) m/n*n ⟨ + m % n + m/n*n ∸ m/n*n ≡⟨ cong (_∸ m/n*n) (m≡m%n+[m/n]*n m n) ⟨ + m ∸ m/n*n ∎ + where m/n*n = (m / n) * n + +------------------------------------------------------------------------ +-- Properties of _%_ + +%-congˡ : .⦃ _ : NonZero o ⦄ → m ≡ n → m % o ≡ n % o +%-congˡ refl = refl + +%-congʳ : .⦃ _ : NonZero m ⦄ .⦃ _ : NonZero n ⦄ → m ≡ n → + o % m ≡ o % n +%-congʳ refl = refl + +n%1≡0 : ∀ n → n % 1 ≡ 0 +n%1≡0 = a[modₕ]1≡0 + +n%n≡0 : ∀ n .{{_ : NonZero n}} → n % n ≡ 0 +n%n≡0 (suc n-1) = n[modₕ]n≡0 0 n-1 + +m%n%n≡m%n : ∀ m n .{{_ : NonZero n}} → m % n % n ≡ m % n +m%n%n≡m%n m (suc n-1) = modₕ-idem 0 m n-1 + +[m+n]%n≡m%n : ∀ m n .{{_ : NonZero n}} → (m + n) % n ≡ m % n +[m+n]%n≡m%n m (suc n-1) = a+n[modₕ]n≡a[modₕ]n 0 m n-1 + +[m+kn]%n≡m%n : ∀ m k n .{{_ : NonZero n}} → (m + k * n) % n ≡ m % n +[m+kn]%n≡m%n m zero n = cong (_% n) (+-identityʳ m) +[m+kn]%n≡m%n m (suc k) n = begin-equality + (m + (n + k * n)) % n ≡⟨ cong (_% n) (sym (+-assoc m n (k * n))) ⟩ + (m + n + k * n) % n ≡⟨ [m+kn]%n≡m%n (m + n) k n ⟩ + (m + n) % n ≡⟨ [m+n]%n≡m%n m n ⟩ + m % n ∎ + +m≤n⇒[n∸m]%m≡n%m : .⦃ _ : NonZero m ⦄ → m ≤ n → + (n ∸ m) % m ≡ n % m +m≤n⇒[n∸m]%m≡n%m {m} {n} m≤n = begin-equality + (n ∸ m) % m ≡⟨ [m+n]%n≡m%n (n ∸ m) m ⟨ + (n ∸ m + m) % m ≡⟨ cong (_% m) (m∸n+n≡m m≤n) ⟩ + n % m ∎ + +m*n≤o⇒[o∸m*n]%n≡o%n : ∀ m {n o} .⦃ _ : NonZero n ⦄ → m * n ≤ o → + (o ∸ m * n) % n ≡ o % n +m*n≤o⇒[o∸m*n]%n≡o%n m {n} {o} m*n≤o = begin-equality + (o ∸ m * n) % n ≡⟨ [m+kn]%n≡m%n (o ∸ m * n) m n ⟨ + (o ∸ m * n + m * n) % n ≡⟨ cong (_% n) (m∸n+n≡m m*n≤o) ⟩ + o % n ∎ + +m∣n⇒o%n%m≡o%m : ∀ m n o .⦃ _ : NonZero m ⦄ .⦃ _ : NonZero n ⦄ → m ∣ n → + o % n % m ≡ o % m +m∣n⇒o%n%m≡o%m m n@.(p * m) o (divides-refl p) = begin-equality + o % n % m ≡⟨⟩ + o % pm % m ≡⟨ %-congˡ (m%n≡m∸m/n*n o pm) ⟩ + (o ∸ o / pm * pm) % m ≡⟨ cong (λ # → (o ∸ #) % m) (*-assoc (o / pm) p m) ⟨ + (o ∸ o / pm * p * m) % m ≡⟨ m*n≤o⇒[o∸m*n]%n≡o%n (o / pm * p) lem ⟩ + o % m ∎ + where + pm = p * m + + lem : o / pm * p * m ≤ o + lem = begin + o / pm * p * m ≡⟨ *-assoc (o / pm) p m ⟩ + -- Sort out dependencies in this file, then use m/n*n≤m instead. + o / pm * pm ≤⟨ m≤m+n (o / pm * pm) (o % pm) ⟩ + o / pm * pm + o % pm ≡⟨ +-comm _ (o % pm) ⟩ + o % pm + o / pm * pm ≡⟨ m≡m%n+[m/n]*n o pm ⟨ + o ∎ + +m*n%n≡0 : ∀ m n .{{_ : NonZero n}} → (m * n) % n ≡ 0 +m*n%n≡0 m n@(suc _) = [m+kn]%n≡m%n 0 m n + +m%n<n : ∀ m n .{{_ : NonZero n}} → m % n < n +m%n<n m (suc n-1) = s≤s (a[modₕ]n<n 0 m n-1) + +m%n≤n : ∀ m n .{{_ : NonZero n}} → m % n ≤ n +m%n≤n m n = <⇒≤ (m%n<n m n) + +m%n≤m : ∀ m n .{{_ : NonZero n}} → m % n ≤ m +m%n≤m m (suc n-1) = a[modₕ]n≤a 0 m n-1 + +m≤n⇒m%n≡m : m ≤ n → m % suc n ≡ m +m≤n⇒m%n≡m {m = m} m≤n with less-than-or-equal {k} refl ← ≤⇒≤″ m≤n + = a≤n⇒a[modₕ]n≡a 0 (m + k) m k + +m<n⇒m%n≡m : .⦃ _ : NonZero n ⦄ → m < n → m % n ≡ m +m<n⇒m%n≡m {n = suc _} m<n = m≤n⇒m%n≡m (<⇒≤pred m<n) + +%-pred-≡0 : ∀ {m n} .{{_ : NonZero n}} → (suc m % n) ≡ 0 → (m % n) ≡ n ∸ 1 +%-pred-≡0 {m} {suc n-1} eq = a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 0 n-1 m eq + +m<[1+n%d]⇒m≤[n%d] : ∀ {m} n d .{{_ : NonZero d}} → m < suc n % d → m ≤ n % d +m<[1+n%d]⇒m≤[n%d] {m} n (suc d-1) = k<1+a[modₕ]n⇒k≤a[modₕ]n 0 m n d-1 + +[1+m%d]≤1+n⇒[m%d]≤n : ∀ m n d .{{_ : NonZero d}} → 0 < suc m % d → suc m % d ≤ suc n → m % d ≤ n +[1+m%d]≤1+n⇒[m%d]≤n m n (suc d-1) leq = 1+a[modₕ]n≤1+k⇒a[modₕ]n≤k 0 n m d-1 leq + +%-distribˡ-+ : ∀ m n d .{{_ : NonZero d}} → (m + n) % d ≡ ((m % d) + (n % d)) % d +%-distribˡ-+ m n d@(suc d-1) = begin-equality + (m + n) % d ≡⟨ cong (λ v → (v + n) % d) (m≡m%n+[m/n]*n m d) ⟩ + (m % d + m / d * d + n) % d ≡⟨ cong (_% d) (+-assoc (m % d) _ n) ⟩ + (m % d + (m / d * d + n)) % d ≡⟨ cong (λ v → (m % d + v) % d) (+-comm _ n) ⟩ + (m % d + (n + m / d * d)) % d ≡⟨ cong (_% d) (sym (+-assoc (m % d) n _)) ⟩ + (m % d + n + m / d * d) % d ≡⟨ [m+kn]%n≡m%n (m % d + n) (m / d) d ⟩ + (m % d + n) % d ≡⟨ cong (λ v → (m % d + v) % d) (m≡m%n+[m/n]*n n d) ⟩ + (m % d + (n % d + (n / d) * d)) % d ≡⟨ sym (cong (_% d) (+-assoc (m % d) (n % d) _)) ⟩ + (m % d + n % d + (n / d) * d) % d ≡⟨ [m+kn]%n≡m%n (m % d + n % d) (n / d) d ⟩ + (m % d + n % d) % d ∎ + +%-distribˡ-* : ∀ m n d .{{_ : NonZero d}} → (m * n) % d ≡ ((m % d) * (n % d)) % d +%-distribˡ-* m n d@(suc d-1) = begin-equality + (m * n) % d ≡⟨ cong (λ h → (h * n) % d) (m≡m%n+[m/n]*n m d) ⟩ + ((m′ + k * d) * n) % d ≡⟨ cong (λ h → ((m′ + k * d) * h) % d) (m≡m%n+[m/n]*n n d) ⟩ + ((m′ + k * d) * (n′ + j * d)) % d ≡⟨ cong (_% d) lemma ⟩ + (m′ * n′ + (m′ * j + (n′ + j * d) * k) * d) % d ≡⟨ [m+kn]%n≡m%n (m′ * n′) (m′ * j + (n′ + j * d) * k) d ⟩ + (m′ * n′) % d ≡⟨⟩ + ((m % d) * (n % d)) % d ∎ + where + m′ = m % d + n′ = n % d + k = m / d + j = n / d + lemma : (m′ + k * d) * (n′ + j * d) ≡ m′ * n′ + (m′ * j + (n′ + j * d) * k) * d + lemma = begin-equality + (m′ + k * d) * (n′ + j * d) ≡⟨ *-distribʳ-+ (n′ + j * d) m′ (k * d) ⟩ + m′ * (n′ + j * d) + (k * d) * (n′ + j * d) ≡⟨ cong₂ _+_ (*-distribˡ-+ m′ n′ (j * d)) (*-comm (k * d) (n′ + j * d)) ⟩ + (m′ * n′ + m′ * (j * d)) + (n′ + j * d) * (k * d) ≡⟨ +-assoc (m′ * n′) (m′ * (j * d)) ((n′ + j * d) * (k * d)) ⟩ + m′ * n′ + (m′ * (j * d) + (n′ + j * d) * (k * d)) ≡⟨ cong (m′ * n′ +_) (cong₂ _+_ (*-assoc m′ j d) (*-assoc (n′ + j * d) k d)) ⟨ + m′ * n′ + ((m′ * j) * d + ((n′ + j * d) * k) * d) ≡⟨ cong (m′ * n′ +_) (*-distribʳ-+ d (m′ * j) ((n′ + j * d) * k)) ⟨ + m′ * n′ + (m′ * j + (n′ + j * d) * k) * d ∎ + +%-remove-+ˡ : ∀ {m} n {d} .{{_ : NonZero d}} → d ∣ m → (m + n) % d ≡ n % d +%-remove-+ˡ {m@.(p * d)} n {d@(suc _)} (divides-refl p) = begin-equality + (m + n) % d ≡⟨⟩ + (p * d + n) % d ≡⟨ cong (_% d) (+-comm (p * d) n) ⟩ + (n + p * d) % d ≡⟨ [m+kn]%n≡m%n n p d ⟩ + n % d ∎ + +%-remove-+ʳ : ∀ m {n d} .{{_ : NonZero d}} → d ∣ n → (m + n) % d ≡ m % d +%-remove-+ʳ m {n} {suc _} eq rewrite +-comm m n = %-remove-+ˡ {n} m eq + +------------------------------------------------------------------------ +-- Properties of _/_ + +/-congˡ : .{{_ : NonZero o}} → m ≡ n → m / o ≡ n / o +/-congˡ refl = refl + +/-congʳ : .{{_ : NonZero n}} .{{_ : NonZero o}} → n ≡ o → m / n ≡ m / o +/-congʳ refl = refl + +0/n≡0 : ∀ n .{{_ : NonZero n}} → 0 / n ≡ 0 +0/n≡0 (suc _) = refl + +n/1≡n : ∀ n → n / 1 ≡ n +n/1≡n n = a[divₕ]1≡a 0 n + +n/n≡1 : ∀ n .{{_ : NonZero n}} → n / n ≡ 1 +n/n≡1 (suc n-1) = n[divₕ]n≡1 n-1 n-1 + +m*n/n≡m : ∀ m n .{{_ : NonZero n}} → m * n / n ≡ m +m*n/n≡m m (suc n-1) = a*n[divₕ]n≡a 0 m n-1 + +m/n*n≡m : ∀ {m n} .{{_ : NonZero n}} → n ∣ m → m / n * n ≡ m +m/n*n≡m {_} {n@(suc _)} (divides-refl q) = cong (_* n) (m*n/n≡m q n) + +m*[n/m]≡n : .{{_ : NonZero m}} → m ∣ n → m * (n / m) ≡ n +m*[n/m]≡n {m} m∣n = trans (*-comm m (_ / m)) (m/n*n≡m m∣n) + +m/n*n≤m : ∀ m n .{{_ : NonZero n}} → (m / n) * n ≤ m +m/n*n≤m m n@(suc n-1) = begin + (m / n) * n ≤⟨ m≤m+n ((m / n) * n) (m % n) ⟩ + (m / n) * n + m % n ≡⟨ +-comm _ (m % n) ⟩ + m % n + (m / n) * n ≡⟨ sym (m≡m%n+[m/n]*n m n) ⟩ + m ∎ + +m/n≤m : ∀ m n .{{_ : NonZero n}} → (m / n) ≤ m +m/n≤m m n = *-cancelʳ-≤ (m / n) m n (begin + (m / n) * n ≤⟨ m/n*n≤m m n ⟩ + m ≤⟨ m≤m*n m n ⟩ + m * n ∎) + +m/n<m : ∀ m n .{{_ : NonZero m}} .{{_ : NonZero n}} → n ≥ 2 → m / n < m +m/n<m m n n≥2 = *-cancelʳ-< _ (m / n) m (begin-strict + (m / n) * n ≤⟨ m/n*n≤m m n ⟩ + m <⟨ m<m*n m n n≥2 ⟩ + m * n ∎) + +/-mono-≤ : .{{_ : NonZero o}} .{{_ : NonZero p}} → + m ≤ n → o ≥ p → m / o ≤ n / p +/-mono-≤ m≤n (s≤s o≥p) = divₕ-mono-≤ 0 m≤n o≥p + +/-monoˡ-≤ : ∀ o .{{_ : NonZero o}} → m ≤ n → m / o ≤ n / o +/-monoˡ-≤ o m≤n = /-mono-≤ m≤n (≤-refl {o}) + +/-monoʳ-≤ : ∀ m {n o} .{{_ : NonZero n}} .{{_ : NonZero o}} → + n ≥ o → m / n ≤ m / o +/-monoʳ-≤ m n≥o = /-mono-≤ ≤-refl n≥o + +/-cancelʳ-≡ : ∀ {m n o} .{{_ : NonZero o}} → + o ∣ m → o ∣ n → m / o ≡ n / o → m ≡ n +/-cancelʳ-≡ {m} {n} {o} o∣m o∣n m/o≡n/o = begin-equality + m ≡⟨ m*[n/m]≡n {o} {m} o∣m ⟨ + o * (m / o) ≡⟨ cong (o *_) m/o≡n/o ⟩ + o * (n / o) ≡⟨ m*[n/m]≡n {o} {n} o∣n ⟩ + n ∎ + +m<n⇒m/n≡0 : ∀ {m n} .{{_ : NonZero n}} → m < n → m / n ≡ 0 +m<n⇒m/n≡0 {m} {suc n-1} (s≤s m≤n) = divₕ-finish n-1 m n-1 m≤n + +m≥n⇒m/n>0 : ∀ {m n} .{{_ : NonZero n}} → m ≥ n → m / n > 0 +m≥n⇒m/n>0 {m@(suc _)} {n@(suc _)} m≥n = begin + 1 ≡⟨ sym (n/n≡1 m) ⟩ + m / m ≤⟨ /-monoʳ-≤ m m≥n ⟩ + m / n ∎ + ++-distrib-/ : ∀ m n {d} .{{_ : NonZero d}} → m % d + n % d < d → + (m + n) / d ≡ m / d + n / d ++-distrib-/ m n {suc d-1} leq = +-distrib-divₕ 0 0 m n d-1 leq + ++-distrib-/-∣ˡ : ∀ {m} n {d} .{{_ : NonZero d}} → + d ∣ m → (m + n) / d ≡ m / d + n / d ++-distrib-/-∣ˡ {m@.(p * d)} n {d} (divides-refl p) = +-distrib-/ m n (begin-strict + m % d + n % d ≡⟨⟩ + p * d % d + n % d ≡⟨ cong (_+ n % d) (m*n%n≡0 p d) ⟩ + n % d <⟨ m%n<n n d ⟩ + d ∎) + ++-distrib-/-∣ʳ : ∀ m {n} {d} .{{_ : NonZero d}} → + d ∣ n → (m + n) / d ≡ m / d + n / d ++-distrib-/-∣ʳ m {n@.(p * d)} {d} (divides-refl p) = +-distrib-/ m n (begin-strict + m % d + n % d ≡⟨⟩ + m % d + p * d % d ≡⟨ cong (m % d +_) (m*n%n≡0 p d) ⟩ + m % d + 0 ≡⟨ +-identityʳ _ ⟩ + m % d <⟨ m%n<n m d ⟩ + d ∎) + +m/n≡1+[m∸n]/n : ∀ {m n} .{{_ : NonZero n}} → m ≥ n → m / n ≡ 1 + ((m ∸ n) / n) +m/n≡1+[m∸n]/n {m@(suc m-1)} {n@(suc n-1)} m≥n = begin-equality + m / n ≡⟨⟩ + div-helper 0 n-1 m n-1 ≡⟨ divₕ-restart n-1 m n-1 m≥n ⟩ + div-helper 1 n-1 (m ∸ n) n-1 ≡⟨ divₕ-extractAcc 1 n-1 (m ∸ n) n-1 ⟩ + 1 + (div-helper 0 n-1 (m ∸ n) n-1) ≡⟨⟩ + 1 + (m ∸ n) / n ∎ + +m*n/m*o≡n/o : ∀ m n o .{{_ : NonZero o}} .{{_ : NonZero (m * o)}} → + (m * n) / (m * o) ≡ n / o +m*n/m*o≡n/o m@(suc _) n o = helper (<-wellFounded n) + where + helper : ∀ {n} → Acc _<_ n → (m * n) / (m * o) ≡ n / o + helper {n} (acc rec) with n <? o + ... | yes n<o = trans (m<n⇒m/n≡0 (*-monoʳ-< m n<o)) (sym (m<n⇒m/n≡0 n<o)) + ... | no n≮o = begin-equality + (m * n) / (m * o) ≡⟨ m/n≡1+[m∸n]/n (*-monoʳ-≤ m (≮⇒≥ n≮o)) ⟩ + 1 + (m * n ∸ m * o) / (m * o) ≡⟨ cong (λ v → 1 + v / (m * o)) (*-distribˡ-∸ m n o) ⟨ + 1 + (m * (n ∸ o)) / (m * o) ≡⟨ cong suc (helper (rec n∸o<n)) ⟩ + 1 + (n ∸ o) / o ≡⟨ cong₂ _+_ (n/n≡1 o) refl ⟨ + o / o + (n ∸ o) / o ≡⟨ +-distrib-/-∣ˡ (n ∸ o) (divides 1 ((sym (*-identityˡ o)))) ⟨ + (o + (n ∸ o)) / o ≡⟨ cong (_/ o) (m+[n∸m]≡n (≮⇒≥ n≮o)) ⟩ + n / o ∎ + where n∸o<n = ∸-monoʳ-< (n≢0⇒n>0 (≢-nonZero⁻¹ o)) (≮⇒≥ n≮o) + +m*n/o*n≡m/o : ∀ m n o .⦃ _ : NonZero o ⦄ ⦃ _ : NonZero (o * n) ⦄ → + m * n / (o * n) ≡ m / o +m*n/o*n≡m/o m n o ⦃ _ ⦄ ⦃ o*n≢0 ⦄ = begin-equality + m * n / (o * n) ≡⟨ /-congˡ (*-comm m n) ⟩ + n * m / (o * n) ≡⟨ /-congʳ (*-comm o n) ⟩ + n * m / (n * o) ≡⟨ m*n/m*o≡n/o n m o ⟩ + m / o ∎ + where instance n*o≢0 = subst NonZero (*-comm o n) o*n≢0 + +m<n*o⇒m/o<n : ∀ {m n o} .⦃ _ : NonZero o ⦄ → m < n * o → m / o < n +m<n*o⇒m/o<n {m} {suc n} {o} m<n*o with m <? o +... | yes m<o = begin-strict + m / o ≡⟨ m<n⇒m/n≡0 m<o ⟩ + 0 <⟨ z<s ⟩ + suc n ∎ +... | no m≮o = begin-strict + m / o ≡⟨ m/n≡1+[m∸n]/n (≮⇒≥ m≮o) ⟩ + suc ((m ∸ o) / o) <⟨ s≤s (m<n*o⇒m/o<n lem) ⟩ + suc n ∎ + where + lem : m ∸ o < n * o + lem = begin-strict + m ∸ o <⟨ ∸-monoˡ-< m<n*o (≮⇒≥ m≮o) ⟩ + o + n * o ∸ o ≡⟨ m+n∸m≡n o (n * o) ⟩ + n * o ∎ + +[m∸n]/n≡m/n∸1 : ∀ m n .⦃ _ : NonZero n ⦄ → (m ∸ n) / n ≡ pred (m / n) +[m∸n]/n≡m/n∸1 m n with m <? n +... | yes m<n = begin-equality + (m ∸ n) / n ≡⟨ m<n⇒m/n≡0 (≤-<-trans (m∸n≤m m n) m<n) ⟩ + 0 ≡⟨⟩ + 0 ∸ 1 ≡⟨ cong (_∸ 1) (m<n⇒m/n≡0 m<n) ⟨ + m / n ∸ 1 ≡⟨⟩ + pred (m / n) ∎ +... | no m≮n = begin-equality + (m ∸ n) / n ≡⟨⟩ + suc ((m ∸ n) / n) ∸ 1 ≡⟨ cong (_∸ 1) (m/n≡1+[m∸n]/n (≮⇒≥ m≮n)) ⟨ + m / n ∸ 1 ≡⟨⟩ + pred (m / n) ∎ + +[m∸n*o]/o≡m/o∸n : ∀ m n o .⦃ _ : NonZero o ⦄ → (m ∸ n * o) / o ≡ m / o ∸ n +[m∸n*o]/o≡m/o∸n m zero o = refl +[m∸n*o]/o≡m/o∸n m (suc n) o = begin-equality + (m ∸ (o + n * o)) / o ≡⟨ /-congˡ (∸-+-assoc m o (n * o)) ⟨ + (m ∸ o ∸ n * o) / o ≡⟨ [m∸n*o]/o≡m/o∸n (m ∸ o) n o ⟩ + (m ∸ o) / o ∸ n ≡⟨ cong (_∸ n) ([m∸n]/n≡m/n∸1 m o) ⟩ + m / o ∸ 1 ∸ n ≡⟨ ∸-+-assoc (m / o) 1 n ⟩ + m / o ∸ suc n ∎ + +m/n/o≡m/[n*o] : ∀ m n o .⦃ _ : NonZero n ⦄ .⦃ _ : NonZero o ⦄ + .⦃ _ : NonZero (n * o) ⦄ → m / n / o ≡ m / (n * o) +m/n/o≡m/[n*o] m n o = begin-equality + m / n / o ≡⟨ /-congˡ {o = o} (/-congˡ (m≡m%n+[m/n]*n m n*o)) ⟩ + (m % n*o + m / n*o * n*o) / n / o ≡⟨ /-congˡ (+-distrib-/-∣ʳ (m % n*o) lem₁) ⟩ + (m % n*o / n + m / n*o * n*o / n) / o ≡⟨ cong (λ # → (m % n*o / n + #) / o) lem₂ ⟩ + (m % n*o / n + m / n*o * o) / o ≡⟨ +-distrib-/-∣ʳ (m % n*o / n) (divides-refl (m / n*o)) ⟩ + m % n*o / n / o + m / n*o * o / o ≡⟨ cong (m % n*o / n / o +_) (m*n/n≡m (m / n*o) o) ⟩ + m % n*o / n / o + m / n*o ≡⟨ cong (_+ m / n*o) (m<n⇒m/n≡0 (m<n*o⇒m/o<n {n = o} lem₃)) ⟩ + m / n*o ∎ + where + n*o = n * o + o*n = o * n + + lem₁ : n ∣ m / n*o * n*o + lem₁ = divides (m / n*o * o) $ begin-equality + m / n*o * n*o ≡⟨ cong (m / n*o *_) (*-comm n o) ⟩ + m / n*o * o*n ≡⟨ *-assoc (m / n*o) o n ⟨ + m / n*o * o * n ∎ + + lem₂ : m / n*o * n*o / n ≡ m / n*o * o + lem₂ = begin-equality + m / n*o * n*o / n ≡⟨ cong (λ # → m / n*o * # / n) (*-comm n o) ⟩ + m / n*o * o*n / n ≡⟨ /-congˡ (*-assoc (m / n*o) o n) ⟨ + m / n*o * o * n / n ≡⟨ m*n/n≡m (m / n*o * o) n ⟩ + m / n*o * o ∎ + + lem₃ : m % n*o < o*n + lem₃ = begin-strict + m % n*o <⟨ m%n<n m n*o ⟩ + n*o ≡⟨ *-comm n o ⟩ + o*n ∎ + +*-/-assoc : ∀ m {n d} .{{_ : NonZero d}} → d ∣ n → m * n / d ≡ m * (n / d) +*-/-assoc zero {_} {d@(suc _)} d∣n = 0/n≡0 (suc d) +*-/-assoc (suc m) {n} {d@(suc _)} d∣n = begin-equality + (n + m * n) / d ≡⟨ +-distrib-/-∣ˡ _ d∣n ⟩ + n / d + (m * n) / d ≡⟨ cong (n / d +_) (*-/-assoc m d∣n) ⟩ + n / d + m * (n / d) ∎ + +/-*-interchange : ∀ {m n o p} .{{_ : NonZero o}} .{{_ : NonZero p}} .{{_ : NonZero (o * p)}} → + o ∣ m → p ∣ n → (m * n) / (o * p) ≡ (m / o) * (n / p) +/-*-interchange {m} {n} {o@(suc _)} {p@(suc _)} o∣m p∣n = *-cancelˡ-≡ _ _ (o * p) (begin-equality + (o * p) * ((m * n) / (o * p)) ≡⟨ m*[n/m]≡n (*-pres-∣ o∣m p∣n) ⟩ + m * n ≡⟨ cong₂ _*_ (m*[n/m]≡n o∣m) (m*[n/m]≡n p∣n) ⟨ + (o * (m / o)) * (p * (n / p)) ≡⟨ [m*n]*[o*p]≡[m*o]*[n*p] o (m / o) p (n / p) ⟩ + (o * p) * ((m / o) * (n / p)) ∎) + +m*n/m!≡n/[m∸1]! : ∀ m n .{{_ : NonZero m}} → + (m * n / m !) {{m !≢0}} ≡ (n / (pred m) !) {{pred m !≢0}} +m*n/m!≡n/[m∸1]! (suc m) n = m*n/m*o≡n/o (suc m) n (m !) {{m !≢0}} {{suc m !≢0}} + +m%[n*o]/o≡m/o%n : ∀ m n o .⦃ _ : NonZero n ⦄ .⦃ _ : NonZero o ⦄ + ⦃ _ : NonZero (n * o) ⦄ → m % (n * o) / o ≡ m / o % n +m%[n*o]/o≡m/o%n m n o ⦃ _ ⦄ ⦃ _ ⦄ ⦃ n*o≢0 ⦄ = begin-equality + m % (n * o) / o ≡⟨ /-congˡ (m%n≡m∸m/n*n m (n * o)) ⟩ + (m ∸ (m / (n * o) * (n * o))) / o ≡⟨ cong (λ # → (m ∸ #) / o) (*-assoc (m / (n * o)) n o) ⟨ + (m ∸ (m / (n * o) * n * o)) / o ≡⟨ [m∸n*o]/o≡m/o∸n m (m / (n * o) * n) o ⟩ + m / o ∸ m / (n * o) * n ≡⟨ cong (λ # → m / o ∸ # * n) (/-congʳ (*-comm n o)) ⟩ + m / o ∸ m / (o * n) * n ≡⟨ cong (λ # → m / o ∸ # * n) (m/n/o≡m/[n*o] m o n ) ⟨ + m / o ∸ m / o / n * n ≡⟨ m%n≡m∸m/n*n (m / o) n ⟨ + m / o % n ∎ + where instance o*n≢0 = subst NonZero (*-comm n o) n*o≢0 + +m%n*o≡m*o%[n*o] : ∀ m n o .⦃ _ : NonZero n ⦄ ⦃ _ : NonZero (n * o) ⦄ → + m % n * o ≡ m * o % (n * o) +m%n*o≡m*o%[n*o] m n o ⦃ _ ⦄ ⦃ n*o≢0 ⦄ = begin-equality + m % n * o ≡⟨ cong (_* o) (m%n≡m∸m/n*n m n) ⟩ + (m ∸ m / n * n) * o ≡⟨ *-distribʳ-∸ o m (m / n * n) ⟩ + m * o ∸ m / n * n * o ≡⟨ cong (λ # → m * o ∸ # * n * o) (m*n/o*n≡m/o m o n) ⟨ + m * o ∸ m * o / (n * o) * n * o ≡⟨ cong (m * o ∸_) (*-assoc (m * o / (n * o)) n o) ⟩ + m * o ∸ m * o / (n * o) * (n * o) ≡⟨ m%n≡m∸m/n*n (m * o) (n * o) ⟨ + m * o % (n * o) ∎ + +[m*n+o]%[p*n]≡[m*n]%[p*n]+o : ∀ m {n o} p ⦃ _ : NonZero (p * n) ⦄ → o < n → + (m * n + o) % (p * n) ≡ (m * n) % (p * n) + o +[m*n+o]%[p*n]≡[m*n]%[p*n]+o m {n} {o} p@(suc p-1) ⦃ p*n≢0 ⦄ o<n = begin-equality + (mn + o) % pn ≡⟨ %-distribˡ-+ mn o pn ⟩ + (mn % pn + o % pn) % pn ≡⟨ cong (λ # → (mn % pn + #) % pn) (m<n⇒m%n≡m (m<n⇒m<o*n p o<n)) ⟩ + (mn % pn + o) % pn ≡⟨ m<n⇒m%n≡m lem₂ ⟩ + mn % pn + o ∎ + where + mn = m * n + pn = p * n + + lem₁ : mn % pn ≤ p-1 * n + lem₁ = begin + mn % pn ≡⟨ m%n*o≡m*o%[n*o] m p n ⟨ + (m % p) * n ≤⟨ *-monoˡ-≤ n (m<1+n⇒m≤n (m%n<n m p)) ⟩ + p-1 * n ∎ + + lem₂ : mn % pn + o < pn + lem₂ = begin-strict + mn % pn + o <⟨ +-mono-≤-< lem₁ o<n ⟩ + p-1 * n + n ≡⟨ +-comm (p-1 * n) n ⟩ + pn ∎ + +------------------------------------------------------------------------ +-- A specification of integer division. + +record DivMod (dividend divisor : ℕ) : Set where + constructor result + field + quotient : ℕ + remainder : Fin divisor + property : dividend ≡ toℕ remainder + quotient * divisor + +infixl 7 _div_ _mod_ _divMod_ + +_div_ : (dividend divisor : ℕ) .{{_ : NonZero divisor}} → ℕ +_div_ = _/_ + +_mod_ : (dividend divisor : ℕ) .{{_ : NonZero divisor}} → Fin divisor +m mod n = fromℕ< (m%n<n m n) + +_divMod_ : (dividend divisor : ℕ) .{{_ : NonZero divisor}} → + DivMod dividend divisor +m divMod n = result (m / n) (m mod n) $ begin-equality + m ≡⟨ m≡m%n+[m/n]*n m n ⟩ + m % n + [m/n]*n ≡⟨ cong (_+ [m/n]*n) (toℕ-fromℕ< [m%n]<n) ⟨ + toℕ (fromℕ< [m%n]<n) + [m/n]*n ∎ + where [m/n]*n = m / n * n ; [m%n]<n = m%n<n m n + \ No newline at end of file diff --git a/Data.Nat.Divisibility.Core.html b/Data.Nat.Divisibility.Core.html index be91201a..178a32d8 100644 --- a/Data.Nat.Divisibility.Core.html +++ b/Data.Nat.Divisibility.Core.html @@ -13,43 +13,61 @@ module Data.Nat.Divisibility.Core where -open import Data.Nat.Base using (ℕ; _*_) -open import Data.Nat.Properties -open import Level using (0ℓ) -open import Relation.Nullary.Negation using (¬_) -open import Relation.Binary using (Rel) -open import Relation.Binary.PropositionalEquality - using (_≡_; refl; sym; cong₂; module ≡-Reasoning) - ------------------------------------------------------------------------- --- Definition --- --- m ∣ n is inhabited iff m divides n. Some sources, like Hardy and --- Wright's "An Introduction to the Theory of Numbers", require m to --- be non-zero. However, some things become a bit nicer if m is --- allowed to be zero. For instance, _∣_ becomes a partial order, and --- the gcd of 0 and 0 becomes defined. - -infix 4 _∣_ _∤_ - -record _∣_ (m n : ℕ) : Set where - constructor divides - field quotient : ℕ - equality : n ≡ quotient * m -open _∣_ using (quotient) public - -_∤_ : Rel ℕ 0ℓ -m ∤ n = ¬ (m ∣ n) - - ------------------------------------------------------------------------- --- Basic properties - -*-pres-∣ : ∀ {m n o p} → o ∣ m → p ∣ n → o * p ∣ m * n -*-pres-∣ {m} {n} {o} {p} (divides c m≡c*o) (divides d n≡d*p) = - divides (c * d) (begin - m * n ≡⟨ cong₂ _*_ m≡c*o n≡d*p ⟩ - (c * o) * (d * p) ≡⟨ [m*n]*[o*p]≡[m*o]*[n*p] c o d p ⟩ - (c * d) * (o * p) ∎) - where open ≡-Reasoning +open import Data.Nat.Base using (ℕ; _*_; _<_; NonTrivial) +open import Data.Nat.Properties +open import Level using (0ℓ) +open import Relation.Nullary.Negation using (¬_) +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.PropositionalEquality + using (_≡_; refl; sym; cong₂; module ≡-Reasoning) + +------------------------------------------------------------------------ +-- Main definition +-- +-- m ∣ n is inhabited iff m divides n. Some sources, like Hardy and +-- Wright's "An Introduction to the Theory of Numbers", require m to +-- be non-zero. However, some things become a bit nicer if m is +-- allowed to be zero. For instance, _∣_ becomes a partial order, and +-- the gcd of 0 and 0 becomes defined. + +infix 4 _∣_ _∤_ + +record _∣_ (m n : ℕ) : Set where + constructor divides + field quotient : ℕ + equality : n ≡ quotient * m +open _∣_ using (quotient) public + +_∤_ : Rel ℕ 0ℓ +m ∤ n = ¬ (m ∣ n) + +-- Smart constructor + +pattern divides-refl q = divides q refl + +------------------------------------------------------------------------ +-- Restricted divisor relation + +-- Relation for having a non-trivial divisor below a given bound. +-- Useful when reasoning about primality. +infix 10 _HasNonTrivialDivisorLessThan_ + +record _HasNonTrivialDivisorLessThan_ (m n : ℕ) : Set where + constructor hasNonTrivialDivisor + field + {divisor} : ℕ + .{{nontrivial}} : NonTrivial divisor + divisor-< : divisor < n + divisor-∣ : divisor ∣ m + +------------------------------------------------------------------------ +-- Basic properties + +*-pres-∣ : ∀ {m n o p} → o ∣ m → p ∣ n → o * p ∣ m * n +*-pres-∣ {m} {n} {o} {p} (divides c m≡c*o) (divides d n≡d*p) = + divides (c * d) (begin + m * n ≡⟨ cong₂ _*_ m≡c*o n≡d*p ⟩ + (c * o) * (d * p) ≡⟨ [m*n]*[o*p]≡[m*o]*[n*p] c o d p ⟩ + (c * d) * (o * p) ∎) + where open ≡-Reasoning \ No newline at end of file diff --git a/Data.Nat.Divisibility.html b/Data.Nat.Divisibility.html index 4426413f..cd347242 100644 --- a/Data.Nat.Divisibility.html +++ b/Data.Nat.Divisibility.html @@ -13,292 +13,323 @@ open import Data.Nat.Base open import Data.Nat.DivMod open import Data.Nat.Properties -open import Data.Product -open import Data.Unit using (tt) -open import Function.Base -open import Function.Bundles using (_⇔_; mk⇔) -open import Level using (0ℓ) -open import Relation.Nullary.Decidable using (yes; no) -open import Relation.Nullary.Decidable as Dec using (False) -open import Relation.Nullary.Negation using (contradiction) -open import Relation.Binary -import Relation.Binary.Reasoning.Preorder as PreorderReasoning -open import Relation.Binary.PropositionalEquality as PropEq - using (_≡_; _≢_; refl; sym; trans; cong; cong₂; subst) - ------------------------------------------------------------------------- --- Definition - -open import Data.Nat.Divisibility.Core public - ------------------------------------------------------------------------- --- Relationship with _%_ - -m%n≡0⇒n∣m : ∀ m n .{{_ : NonZero n}} → m % n ≡ 0 → n ∣ m -m%n≡0⇒n∣m m n eq = divides (m / n) (begin-equality - m ≡⟨ m≡m%n+[m/n]*n m n ⟩ - m % n + m / n * n ≡⟨ cong₂ _+_ eq refl ⟩ - m / n * n ∎) - where open ≤-Reasoning - -n∣m⇒m%n≡0 : ∀ m n .{{_ : NonZero n}} → n ∣ m → m % n ≡ 0 -n∣m⇒m%n≡0 m n (divides v eq) = begin-equality - m % n ≡⟨ cong (_% n) eq ⟩ - (v * n) % n ≡⟨ m*n%n≡0 v n ⟩ - 0 ∎ - where open ≤-Reasoning - -m%n≡0⇔n∣m : ∀ m n .{{_ : NonZero n}} → m % n ≡ 0 ⇔ n ∣ m -m%n≡0⇔n∣m m n = mk⇔ (m%n≡0⇒n∣m m n) (n∣m⇒m%n≡0 m n) - ------------------------------------------------------------------------- --- Properties of _∣_ and _≤_ - -∣⇒≤ : ∀ {m n} .{{_ : NonZero n}} → m ∣ n → m ≤ n -∣⇒≤ {m} {n@(suc _)} (divides (suc q) eq) = begin - m ≤⟨ m≤m+n m (q * m) ⟩ - suc q * m ≡⟨ sym eq ⟩ - n ∎ - where open ≤-Reasoning - ->⇒∤ : ∀ {m n} .{{_ : NonZero n}} → m > n → m ∤ n ->⇒∤ (s≤s m>n) m∣n = contradiction (∣⇒≤ m∣n) (≤⇒≯ m>n) - ------------------------------------------------------------------------- --- _∣_ is a partial order - -∣-reflexive : _≡_ ⇒ _∣_ -∣-reflexive {n} refl = divides 1 (sym (*-identityˡ n)) - -∣-refl : Reflexive _∣_ -∣-refl = ∣-reflexive refl - -∣-trans : Transitive _∣_ -∣-trans (divides p refl) (divides q refl) = - divides (q * p) (sym (*-assoc q p _)) - -∣-antisym : Antisymmetric _≡_ _∣_ -∣-antisym {m} {zero} _ (divides q refl) = *-zeroʳ q -∣-antisym {zero} {n} (divides p eq) _ = sym (trans eq (*-comm p 0)) -∣-antisym {suc m} {suc n} p∣q q∣p = ≤-antisym (∣⇒≤ p∣q) (∣⇒≤ q∣p) - -infix 4 _∣?_ +open import Function.Base using (_∘′_; _$_) +open import Function.Bundles using (_⇔_; mk⇔) +open import Level using (0ℓ) +open import Relation.Nullary.Decidable as Dec using (yes; no) +open import Relation.Nullary.Negation.Core using (contradiction) +open import Relation.Binary.Core using (_⇒_) +open import Relation.Binary.Bundles using (Preorder; Poset) +open import Relation.Binary.Structures + using (IsPreorder; IsPartialOrder) +open import Relation.Binary.Definitions + using (Reflexive; Transitive; Antisymmetric; Decidable) +import Relation.Binary.Reasoning.Preorder as PreorderReasoning +open import Relation.Binary.PropositionalEquality.Core + using (_≡_; _≢_; refl; sym; trans; cong; cong₂; subst) +open import Relation.Binary.Reasoning.Syntax +import Relation.Binary.PropositionalEquality.Properties as PropEq + +------------------------------------------------------------------------ +-- Definition + +open import Data.Nat.Divisibility.Core public + +------------------------------------------------------------------------ +-- Relationship with _%_ + +m%n≡0⇒n∣m : ∀ m n .{{_ : NonZero n}} → m % n ≡ 0 → n ∣ m +m%n≡0⇒n∣m m n eq = divides (m / n) (begin-equality + m ≡⟨ m≡m%n+[m/n]*n m n ⟩ + m % n + m / n * n ≡⟨ cong₂ _+_ eq refl ⟩ + m / n * n ∎) + where open ≤-Reasoning + +n∣m⇒m%n≡0 : ∀ m n .{{_ : NonZero n}} → n ∣ m → m % n ≡ 0 +n∣m⇒m%n≡0 .(q * n) n (divides-refl q) = m*n%n≡0 q n -_∣?_ : Decidable _∣_ -zero ∣? zero = yes (divides 0 refl) -zero ∣? suc m = no ((λ()) ∘′ ∣-antisym (divides 0 refl)) -suc n ∣? m = Dec.map (m%n≡0⇔n∣m m (suc n)) (m % suc n ≟ 0) - -∣-isPreorder : IsPreorder _≡_ _∣_ -∣-isPreorder = record - { isEquivalence = PropEq.isEquivalence - ; reflexive = ∣-reflexive - ; trans = ∣-trans - } - -∣-isPartialOrder : IsPartialOrder _≡_ _∣_ -∣-isPartialOrder = record - { isPreorder = ∣-isPreorder - ; antisym = ∣-antisym - } - -∣-preorder : Preorder 0ℓ 0ℓ 0ℓ -∣-preorder = record - { isPreorder = ∣-isPreorder - } - -∣-poset : Poset 0ℓ 0ℓ 0ℓ -∣-poset = record - { isPartialOrder = ∣-isPartialOrder - } - ------------------------------------------------------------------------- --- A reasoning module for the _∣_ relation - -module ∣-Reasoning where - private - module Base = PreorderReasoning ∣-preorder - - open Base public - hiding (step-≈; step-≈˘; step-∼) - - infixr 2 step-∣ - step-∣ = Base.step-∼ - syntax step-∣ x y∣z x∣y = x ∣⟨ x∣y ⟩ y∣z - ------------------------------------------------------------------------- --- Simple properties of _∣_ - -infix 10 1∣_ _∣0 - -1∣_ : ∀ n → 1 ∣ n -1∣ n = divides n (sym (*-identityʳ n)) - -_∣0 : ∀ n → n ∣ 0 -n ∣0 = divides 0 refl - -0∣⇒≡0 : ∀ {n} → 0 ∣ n → n ≡ 0 -0∣⇒≡0 {n} 0∣n = ∣-antisym (n ∣0) 0∣n - -∣1⇒≡1 : ∀ {n} → n ∣ 1 → n ≡ 1 -∣1⇒≡1 {n} n∣1 = ∣-antisym n∣1 (1∣ n) - -n∣n : ∀ {n} → n ∣ n -n∣n {n} = ∣-refl - ------------------------------------------------------------------------- --- Properties of _∣_ and _+_ - -∣m∣n⇒∣m+n : ∀ {i m n} → i ∣ m → i ∣ n → i ∣ m + n -∣m∣n⇒∣m+n (divides p refl) (divides q refl) = - divides (p + q) (sym (*-distribʳ-+ _ p q)) - -∣m+n∣m⇒∣n : ∀ {i m n} → i ∣ m + n → i ∣ m → i ∣ n -∣m+n∣m⇒∣n {i} {m} {n} (divides p m+n≡p*i) (divides q m≡q*i) = - divides (p ∸ q) $ begin-equality - n ≡⟨ sym (m+n∸n≡m n m) ⟩ - n + m ∸ m ≡⟨ cong (_∸ m) (+-comm n m) ⟩ - m + n ∸ m ≡⟨ cong₂ _∸_ m+n≡p*i m≡q*i ⟩ - p * i ∸ q * i ≡⟨ sym (*-distribʳ-∸ i p q) ⟩ - (p ∸ q) * i ∎ - where open ∣-Reasoning - ------------------------------------------------------------------------- --- Properties of _∣_ and _*_ - -n∣m*n : ∀ m {n} → n ∣ m * n -n∣m*n m = divides m refl - -m∣m*n : ∀ {m} n → m ∣ m * n -m∣m*n n = divides n (*-comm _ n) - -n∣m*n*o : ∀ m {n} o → n ∣ m * n * o -n∣m*n*o m o = ∣-trans (n∣m*n m) (m∣m*n o) - -∣m⇒∣m*n : ∀ {i m} n → i ∣ m → i ∣ m * n -∣m⇒∣m*n {i} {m} n (divides q refl) = ∣-trans (n∣m*n q) (m∣m*n n) - -∣n⇒∣m*n : ∀ {i} m {n} → i ∣ n → i ∣ m * n -∣n⇒∣m*n m {n} rewrite *-comm m n = ∣m⇒∣m*n m - -m*n∣⇒m∣ : ∀ {i} m n → m * n ∣ i → m ∣ i -m*n∣⇒m∣ m n (divides q refl) = ∣n⇒∣m*n q (m∣m*n n) - -m*n∣⇒n∣ : ∀ {i} m n → m * n ∣ i → n ∣ i -m*n∣⇒n∣ m n rewrite *-comm m n = m*n∣⇒m∣ n m - -*-monoʳ-∣ : ∀ {i j} k → i ∣ j → k * i ∣ k * j -*-monoʳ-∣ {i} {j} k (divides q refl) = divides q $ begin-equality - k * (q * i) ≡⟨ sym (*-assoc k q i) ⟩ - (k * q) * i ≡⟨ cong (_* i) (*-comm k q) ⟩ - (q * k) * i ≡⟨ *-assoc q k i ⟩ - q * (k * i) ∎ - where open ≤-Reasoning - -*-monoˡ-∣ : ∀ {i j} k → i ∣ j → i * k ∣ j * k -*-monoˡ-∣ {i} {j} k rewrite *-comm i k | *-comm j k = *-monoʳ-∣ k - -*-cancelˡ-∣ : ∀ {i j} k .{{_ : NonZero k}} → k * i ∣ k * j → i ∣ j -*-cancelˡ-∣ {i} {j} k@(suc _) (divides q eq) = - divides q $ *-cancelʳ-≡ j (q * i) _ $ begin-equality - j * k ≡⟨ *-comm j k ⟩ - k * j ≡⟨ eq ⟩ - q * (k * i) ≡⟨ cong (q *_) (*-comm k i) ⟩ - q * (i * k) ≡⟨ sym (*-assoc q i k) ⟩ - (q * i) * k ∎ - where open ≤-Reasoning - -*-cancelʳ-∣ : ∀ {i j} k .{{_ : NonZero k}} → i * k ∣ j * k → i ∣ j -*-cancelʳ-∣ {i} {j} k rewrite *-comm i k | *-comm j k = *-cancelˡ-∣ k - ------------------------------------------------------------------------- --- Properties of _∣_ and _∸_ - -∣m∸n∣n⇒∣m : ∀ i {m n} → n ≤ m → i ∣ m ∸ n → i ∣ n → i ∣ m -∣m∸n∣n⇒∣m i {m} {n} n≤m (divides p m∸n≡p*i) (divides q n≡q*o) = - divides (p + q) $ begin-equality - m ≡⟨ sym (m+[n∸m]≡n n≤m) ⟩ - n + (m ∸ n) ≡⟨ +-comm n (m ∸ n) ⟩ - m ∸ n + n ≡⟨ cong₂ _+_ m∸n≡p*i n≡q*o ⟩ - p * i + q * i ≡⟨ sym (*-distribʳ-+ i p q) ⟩ - (p + q) * i ∎ - where open ≤-Reasoning - ------------------------------------------------------------------------- --- Properties of _∣_ and _/_ - -m/n∣m : ∀ {m n} .{{_ : NonZero n}} → n ∣ m → m / n ∣ m -m/n∣m {m} {n} (divides p refl) = begin - p * n / n ≡⟨ m*n/n≡m p n ⟩ - p ∣⟨ m∣m*n n ⟩ - p * n ∎ - where open ∣-Reasoning - -m*n∣o⇒m∣o/n : ∀ m n {o} .{{_ : NonZero n}} → m * n ∣ o → m ∣ o / n -m*n∣o⇒m∣o/n m n {_} (divides p refl) = begin - m ∣⟨ n∣m*n p ⟩ - p * m ≡⟨ sym (*-identityʳ (p * m)) ⟩ - p * m * 1 ≡⟨ sym (cong (p * m *_) (n/n≡1 n)) ⟩ - p * m * (n / n) ≡⟨ sym (*-/-assoc (p * m) (n∣n {n})) ⟩ - p * m * n / n ≡⟨ cong (_/ n) (*-assoc p m n) ⟩ - p * (m * n) / n ∎ - where open ∣-Reasoning - -m*n∣o⇒n∣o/m : ∀ m n {o} .{{_ : NonZero m}} → m * n ∣ o → n ∣ (o / m) -m*n∣o⇒n∣o/m m n rewrite *-comm m n = m*n∣o⇒m∣o/n n m - -m∣n/o⇒m*o∣n : ∀ {m n o} .{{_ : NonZero o}} → o ∣ n → m ∣ n / o → m * o ∣ n -m∣n/o⇒m*o∣n {m} {n} {o} (divides p refl) m∣p*o/o = begin - m * o ∣⟨ *-monoˡ-∣ o (subst (m ∣_) (m*n/n≡m p o) m∣p*o/o) ⟩ - p * o ∎ - where open ∣-Reasoning - -m∣n/o⇒o*m∣n : ∀ {m n o} .{{_ : NonZero o}} → o ∣ n → m ∣ n / o → o * m ∣ n -m∣n/o⇒o*m∣n {m} {_} {o} rewrite *-comm o m = m∣n/o⇒m*o∣n - -m/n∣o⇒m∣o*n : ∀ {m n o} .{{_ : NonZero n}} → n ∣ m → m / n ∣ o → m ∣ o * n -m/n∣o⇒m∣o*n {_} {n} {o} (divides p refl) p*n/n∣o = begin - p * n ∣⟨ *-monoˡ-∣ n (subst (_∣ o) (m*n/n≡m p n) p*n/n∣o) ⟩ - o * n ∎ - where open ∣-Reasoning - -m∣n*o⇒m/n∣o : ∀ {m n o} .{{_ : NonZero n}} → n ∣ m → m ∣ o * n → m / n ∣ o -m∣n*o⇒m/n∣o {_} {n@(suc _)} {o} (divides p refl) pn∣on = begin - p * n / n ≡⟨ m*n/n≡m p n ⟩ - p ∣⟨ *-cancelʳ-∣ n pn∣on ⟩ - o ∎ - where open ∣-Reasoning - ------------------------------------------------------------------------- --- Properties of _∣_ and _%_ - -∣n∣m%n⇒∣m : ∀ {m n d} .{{_ : NonZero n}} → d ∣ n → d ∣ m % n → d ∣ m -∣n∣m%n⇒∣m {m} {n} {d} (divides a n≡ad) (divides b m%n≡bd) = - divides (b + (m / n) * a) (begin-equality - m ≡⟨ m≡m%n+[m/n]*n m n ⟩ - m % n + (m / n) * n ≡⟨ cong₂ _+_ m%n≡bd (cong (m / n *_) n≡ad) ⟩ - b * d + (m / n) * (a * d) ≡⟨ sym (cong (b * d +_) (*-assoc (m / n) a d)) ⟩ - b * d + ((m / n) * a) * d ≡⟨ sym (*-distribʳ-+ d b _) ⟩ - (b + (m / n) * a) * d ∎) - where open ≤-Reasoning - -%-presˡ-∣ : ∀ {m n d} .{{_ : NonZero n}} → d ∣ m → d ∣ n → d ∣ m % n -%-presˡ-∣ {m} {n} {d} (divides a refl) (divides b 1+n≡bd) = - divides (a ∸ ad/n * b) $ begin-equality - a * d % n ≡⟨ m%n≡m∸m/n*n (a * d) n ⟩ - a * d ∸ ad/n * n ≡⟨ cong (λ v → a * d ∸ ad/n * v) 1+n≡bd ⟩ - a * d ∸ ad/n * (b * d) ≡˘⟨ cong (a * d ∸_) (*-assoc ad/n b d) ⟩ - a * d ∸ (ad/n * b) * d ≡˘⟨ *-distribʳ-∸ d a (ad/n * b) ⟩ - (a ∸ ad/n * b) * d ∎ - where open ≤-Reasoning; ad/n = a * d / n - ------------------------------------------------------------------------- --- Properties of _∣_ and !_ - -m≤n⇒m!∣n! : ∀ {m n} → m ≤ n → m ! ∣ n ! -m≤n⇒m!∣n! m≤n = help (≤⇒≤′ m≤n) - where - help : ∀ {m n} → m ≤′ n → m ! ∣ n ! - help {m} {n} ≤′-refl = ∣-refl - help {m} {suc n} (≤′-step m≤′n) = ∣n⇒∣m*n (suc n) (help m≤′n) +m%n≡0⇔n∣m : ∀ m n .{{_ : NonZero n}} → m % n ≡ 0 ⇔ n ∣ m +m%n≡0⇔n∣m m n = mk⇔ (m%n≡0⇒n∣m m n) (n∣m⇒m%n≡0 m n) + +------------------------------------------------------------------------ +-- Properties of _∣_ and _≤_ + +∣⇒≤ : ∀ {m n} .{{_ : NonZero n}} → m ∣ n → m ≤ n +∣⇒≤ {m} {n@(suc _)} (divides (suc q) eq) = begin + m ≤⟨ m≤m+n m (q * m) ⟩ + suc q * m ≡⟨ sym eq ⟩ + n ∎ + where open ≤-Reasoning + +>⇒∤ : ∀ {m n} .{{_ : NonZero n}} → m > n → m ∤ n +>⇒∤ (s≤s m>n) m∣n = contradiction (∣⇒≤ m∣n) (≤⇒≯ m>n) + +------------------------------------------------------------------------ +-- _∣_ is a partial order + +-- these could/should inherit from Algebra.Properties.Monoid.Divisibility + +∣-reflexive : _≡_ ⇒ _∣_ +∣-reflexive {n} refl = divides 1 (sym (*-identityˡ n)) + +∣-refl : Reflexive _∣_ +∣-refl = ∣-reflexive refl + +∣-trans : Transitive _∣_ +∣-trans (divides-refl p) (divides-refl q) = + divides (q * p) (sym (*-assoc q p _)) + +∣-antisym : Antisymmetric _≡_ _∣_ +∣-antisym {m} {zero} _ (divides-refl q) = *-zeroʳ q +∣-antisym {zero} {n} (divides p eq) _ = sym (trans eq (*-comm p 0)) +∣-antisym {suc m} {suc n} p∣q q∣p = ≤-antisym (∣⇒≤ p∣q) (∣⇒≤ q∣p) + +infix 4 _∣?_ + +_∣?_ : Decidable _∣_ +zero ∣? zero = yes (divides-refl 0) +zero ∣? suc m = no ((λ()) ∘′ ∣-antisym (divides-refl 0)) +suc n ∣? m = Dec.map (m%n≡0⇔n∣m m (suc n)) (m % suc n ≟ 0) + +∣-isPreorder : IsPreorder _≡_ _∣_ +∣-isPreorder = record + { isEquivalence = PropEq.isEquivalence + ; reflexive = ∣-reflexive + ; trans = ∣-trans + } + +∣-isPartialOrder : IsPartialOrder _≡_ _∣_ +∣-isPartialOrder = record + { isPreorder = ∣-isPreorder + ; antisym = ∣-antisym + } + +∣-preorder : Preorder 0ℓ 0ℓ 0ℓ +∣-preorder = record + { isPreorder = ∣-isPreorder + } + +∣-poset : Poset 0ℓ 0ℓ 0ℓ +∣-poset = record + { isPartialOrder = ∣-isPartialOrder + } + +------------------------------------------------------------------------ +-- A reasoning module for the _∣_ relation + +module ∣-Reasoning where + private module Base = PreorderReasoning ∣-preorder + + open Base public + hiding (step-≈; step-≈˘; step-≈-⟩; step-≈-⟨; step-∼; step-≲) + renaming (≲-go to ∣-go) + + open ∣-syntax _IsRelatedTo_ _IsRelatedTo_ ∣-go public + +------------------------------------------------------------------------ +-- Simple properties of _∣_ + +infix 10 1∣_ _∣0 + +1∣_ : ∀ n → 1 ∣ n +1∣ n = divides n (sym (*-identityʳ n)) + +_∣0 : ∀ n → n ∣ 0 +n ∣0 = divides-refl 0 + +0∣⇒≡0 : ∀ {n} → 0 ∣ n → n ≡ 0 +0∣⇒≡0 {n} 0∣n = ∣-antisym (n ∣0) 0∣n + +∣1⇒≡1 : ∀ {n} → n ∣ 1 → n ≡ 1 +∣1⇒≡1 {n} n∣1 = ∣-antisym n∣1 (1∣ n) + +n∣n : ∀ {n} → n ∣ n +n∣n {n} = ∣-refl + +------------------------------------------------------------------------ +-- Properties of _∣_ and _+_ + +∣m∣n⇒∣m+n : ∀ {i m n} → i ∣ m → i ∣ n → i ∣ m + n +∣m∣n⇒∣m+n (divides-refl p) (divides-refl q) = + divides (p + q) (sym (*-distribʳ-+ _ p q)) + +∣m+n∣m⇒∣n : ∀ {i m n} → i ∣ m + n → i ∣ m → i ∣ n +∣m+n∣m⇒∣n {i} {m} {n} (divides p m+n≡p*i) (divides q m≡q*i) = + divides (p ∸ q) $ begin-equality + n ≡⟨ sym (m+n∸n≡m n m) ⟩ + n + m ∸ m ≡⟨ cong (_∸ m) (+-comm n m) ⟩ + m + n ∸ m ≡⟨ cong₂ _∸_ m+n≡p*i m≡q*i ⟩ + p * i ∸ q * i ≡⟨ sym (*-distribʳ-∸ i p q) ⟩ + (p ∸ q) * i ∎ + where open ∣-Reasoning + +------------------------------------------------------------------------ +-- Properties of _∣_ and _*_ + +n∣m*n : ∀ m {n} → n ∣ m * n +n∣m*n m = divides m refl + +m∣m*n : ∀ {m} n → m ∣ m * n +m∣m*n n = divides n (*-comm _ n) + +n∣m*n*o : ∀ m {n} o → n ∣ m * n * o +n∣m*n*o m o = ∣-trans (n∣m*n m) (m∣m*n o) + +∣m⇒∣m*n : ∀ {i m} n → i ∣ m → i ∣ m * n +∣m⇒∣m*n {i} {m} n (divides-refl q) = ∣-trans (n∣m*n q) (m∣m*n n) + +∣n⇒∣m*n : ∀ {i} m {n} → i ∣ n → i ∣ m * n +∣n⇒∣m*n m {n} rewrite *-comm m n = ∣m⇒∣m*n m + +m*n∣⇒m∣ : ∀ {i} m n → m * n ∣ i → m ∣ i +m*n∣⇒m∣ m n (divides-refl q) = ∣n⇒∣m*n q (m∣m*n n) + +m*n∣⇒n∣ : ∀ {i} m n → m * n ∣ i → n ∣ i +m*n∣⇒n∣ m n rewrite *-comm m n = m*n∣⇒m∣ n m + +*-monoʳ-∣ : ∀ {i j} k → i ∣ j → k * i ∣ k * j +*-monoʳ-∣ {i} {j@.(q * i)} k (divides-refl q) = divides q $ begin-equality + k * j ≡⟨⟩ + k * (q * i) ≡⟨ sym (*-assoc k q i) ⟩ + (k * q) * i ≡⟨ cong (_* i) (*-comm k q) ⟩ + (q * k) * i ≡⟨ *-assoc q k i ⟩ + q * (k * i) ∎ + where open ≤-Reasoning + +*-monoˡ-∣ : ∀ {i j} k → i ∣ j → i * k ∣ j * k +*-monoˡ-∣ {i} {j} k rewrite *-comm i k | *-comm j k = *-monoʳ-∣ k + +*-cancelˡ-∣ : ∀ {i j} k .{{_ : NonZero k}} → k * i ∣ k * j → i ∣ j +*-cancelˡ-∣ {i} {j} k@(suc _) (divides q eq) = + divides q $ *-cancelʳ-≡ j (q * i) _ $ begin-equality + j * k ≡⟨ *-comm j k ⟩ + k * j ≡⟨ eq ⟩ + q * (k * i) ≡⟨ cong (q *_) (*-comm k i) ⟩ + q * (i * k) ≡⟨ sym (*-assoc q i k) ⟩ + (q * i) * k ∎ + where open ≤-Reasoning + +*-cancelʳ-∣ : ∀ {i j} k .{{_ : NonZero k}} → i * k ∣ j * k → i ∣ j +*-cancelʳ-∣ {i} {j} k rewrite *-comm i k | *-comm j k = *-cancelˡ-∣ k + +------------------------------------------------------------------------ +-- Properties of _∣_ and _∸_ + +∣m∸n∣n⇒∣m : ∀ i {m n} → n ≤ m → i ∣ m ∸ n → i ∣ n → i ∣ m +∣m∸n∣n⇒∣m i {m} {n} n≤m (divides p m∸n≡p*i) (divides q n≡q*o) = + divides (p + q) $ begin-equality + m ≡⟨ sym (m+[n∸m]≡n n≤m) ⟩ + n + (m ∸ n) ≡⟨ +-comm n (m ∸ n) ⟩ + m ∸ n + n ≡⟨ cong₂ _+_ m∸n≡p*i n≡q*o ⟩ + p * i + q * i ≡⟨ sym (*-distribʳ-+ i p q) ⟩ + (p + q) * i ∎ + where open ≤-Reasoning + +------------------------------------------------------------------------ +-- Properties of _∣_ and _/_ + +m/n∣m : ∀ {m n} .{{_ : NonZero n}} → n ∣ m → m / n ∣ m +m/n∣m {m@.(p * n)} {n} (divides-refl p) = begin + m / n ≡⟨⟩ + p * n / n ≡⟨ m*n/n≡m p n ⟩ + p ∣⟨ m∣m*n n ⟩ + p * n ≡⟨⟩ + m ∎ + where open ∣-Reasoning + +m*n∣o⇒m∣o/n : ∀ m n {o} .{{_ : NonZero n}} → m * n ∣ o → m ∣ o / n +m*n∣o⇒m∣o/n m n {o@.(p * (m * n))} (divides-refl p) = begin + m ∣⟨ n∣m*n p ⟩ + p * m ≡⟨ sym (*-identityʳ (p * m)) ⟩ + p * m * 1 ≡⟨ sym (cong (p * m *_) (n/n≡1 n)) ⟩ + p * m * (n / n) ≡⟨ sym (*-/-assoc (p * m) (n∣n {n})) ⟩ + p * m * n / n ≡⟨ cong (_/ n) (*-assoc p m n) ⟩ + p * (m * n) / n ≡⟨⟩ + o / n ∎ + where open ∣-Reasoning + +m*n∣o⇒n∣o/m : ∀ m n {o} .{{_ : NonZero m}} → m * n ∣ o → n ∣ (o / m) +m*n∣o⇒n∣o/m m n rewrite *-comm m n = m*n∣o⇒m∣o/n n m + +m∣n/o⇒m*o∣n : ∀ {m n o} .{{_ : NonZero o}} → o ∣ n → m ∣ n / o → m * o ∣ n +m∣n/o⇒m*o∣n {m} {n} {o} (divides-refl p) m∣p*o/o = begin + m * o ∣⟨ *-monoˡ-∣ o (subst (m ∣_) (m*n/n≡m p o) m∣p*o/o) ⟩ + p * o ∎ + where open ∣-Reasoning + +m∣n/o⇒o*m∣n : ∀ {m n o} .{{_ : NonZero o}} → o ∣ n → m ∣ n / o → o * m ∣ n +m∣n/o⇒o*m∣n {m} {_} {o} rewrite *-comm o m = m∣n/o⇒m*o∣n + +m/n∣o⇒m∣o*n : ∀ {m n o} .{{_ : NonZero n}} → n ∣ m → m / n ∣ o → m ∣ o * n +m/n∣o⇒m∣o*n {_} {n} {o} (divides-refl p) p*n/n∣o = begin + p * n ∣⟨ *-monoˡ-∣ n (subst (_∣ o) (m*n/n≡m p n) p*n/n∣o) ⟩ + o * n ∎ + where open ∣-Reasoning + +m∣n*o⇒m/n∣o : ∀ {m n o} .{{_ : NonZero n}} → n ∣ m → m ∣ o * n → m / n ∣ o +m∣n*o⇒m/n∣o {m@.(p * n)} {n@(suc _)} {o} (divides-refl p) pn∣on = begin + m / n ≡⟨⟩ + p * n / n ≡⟨ m*n/n≡m p n ⟩ + p ∣⟨ *-cancelʳ-∣ n pn∣on ⟩ + o ∎ + where open ∣-Reasoning + +------------------------------------------------------------------------ +-- Properties of _∣_ and _%_ + +∣n∣m%n⇒∣m : ∀ {m n d} .{{_ : NonZero n}} → d ∣ n → d ∣ m % n → d ∣ m +∣n∣m%n⇒∣m {m} {n@.(a * d)} {d} (divides-refl a) (divides b m%n≡bd) = + divides (b + (m / n) * a) (begin-equality + m ≡⟨ m≡m%n+[m/n]*n m n ⟩ + m % n + (m / n) * n ≡⟨ cong (_+ (m / n) * n) m%n≡bd ⟩ + b * d + (m / n) * n ≡⟨⟩ + b * d + (m / n) * (a * d) ≡⟨ sym (cong (b * d +_) (*-assoc (m / n) a d)) ⟩ + b * d + ((m / n) * a) * d ≡⟨ sym (*-distribʳ-+ d b _) ⟩ + (b + (m / n) * a) * d ∎) + where open ≤-Reasoning + +%-presˡ-∣ : ∀ {m n d} .{{_ : NonZero n}} → d ∣ m → d ∣ n → d ∣ m % n +%-presˡ-∣ {m@.(a * d)} {n} {d} (divides-refl a) (divides b 1+n≡bd) = + divides (a ∸ m / n * b) $ begin-equality + m % n ≡⟨ m%n≡m∸m/n*n m n ⟩ + m ∸ m / n * n ≡⟨ cong (λ v → m ∸ m / n * v) 1+n≡bd ⟩ + m ∸ m / n * (b * d) ≡⟨ cong (m ∸_) (*-assoc (m / n) b d) ⟨ + m ∸ (m / n * b) * d ≡⟨⟩ + a * d ∸ (m / n * b) * d ≡⟨ *-distribʳ-∸ d a (m / n * b) ⟨ + (a ∸ m / n * b) * d ∎ + where open ≤-Reasoning + +------------------------------------------------------------------------ +-- Properties of _∣_ and !_ + +m≤n⇒m!∣n! : ∀ {m n} → m ≤ n → m ! ∣ n ! +m≤n⇒m!∣n! m≤n = help (≤⇒≤′ m≤n) + where + help : ∀ {m n} → m ≤′ n → m ! ∣ n ! + help {m} {n} ≤′-refl = ∣-refl + help {m} {suc n} (≤′-step m≤′n) = ∣n⇒∣m*n (suc n) (help m≤′n) + +------------------------------------------------------------------------ +-- Properties of _BoundedNonTrivialDivisor_ + +-- Smart constructor + +hasNonTrivialDivisor-≢ : ∀ {d n} → .{{NonTrivial d}} → .{{NonZero n}} → + d ≢ n → d ∣ n → n HasNonTrivialDivisorLessThan n +hasNonTrivialDivisor-≢ d≢n d∣n + = hasNonTrivialDivisor (≤∧≢⇒< (∣⇒≤ d∣n) d≢n) d∣n + +-- Monotonicity wrt ∣ + +hasNonTrivialDivisor-∣ : ∀ {m n o} → m HasNonTrivialDivisorLessThan n → m ∣ o → + o HasNonTrivialDivisorLessThan n +hasNonTrivialDivisor-∣ (hasNonTrivialDivisor d<n d∣m) n∣o + = hasNonTrivialDivisor d<n (∣-trans d∣m n∣o) + +-- Monotonicity wrt ≤ + +hasNonTrivialDivisor-≤ : ∀ {m n o} → m HasNonTrivialDivisorLessThan n → n ≤ o → + m HasNonTrivialDivisorLessThan o +hasNonTrivialDivisor-≤ (hasNonTrivialDivisor d<n d∣m) m≤o = + hasNonTrivialDivisor (<-≤-trans d<n m≤o) d∣m \ No newline at end of file diff --git a/Data.Nat.GCD.Lemmas.html b/Data.Nat.GCD.Lemmas.html index e6a8ce03..cbf4c37e 100644 --- a/Data.Nat.GCD.Lemmas.html +++ b/Data.Nat.GCD.Lemmas.html @@ -12,169 +12,169 @@ open import Data.Nat.Base open import Data.Nat.Properties open import Data.Nat.Solver -open import Function -open import Relation.Binary.PropositionalEquality - -open +-*-Solver -open ≡-Reasoning - -private - distrib-comm : ∀ x k n → x * k + x * n ≡ x * (n + k) - distrib-comm = - solve 3 (λ x k n → x :* k :+ x :* n := x :* (n :+ k)) refl - - distrib-comm₂ : ∀ d x k n → d + x * (n + k) ≡ d + x * k + x * n - distrib-comm₂ = - solve 4 (λ d x k n → d :+ x :* (n :+ k) := d :+ x :* k :+ x :* n) refl - --- Other properties --- TODO: Can this proof be simplified? An automatic solver which can --- handle ∸ would be nice... -lem₀ : ∀ i j m n → i * m ≡ j * m + n → (i ∸ j) * m ≡ n -lem₀ i j m n eq = begin - (i ∸ j) * m ≡⟨ *-distribʳ-∸ m i j ⟩ - (i * m) ∸ (j * m) ≡⟨ cong (_∸ j * m) eq ⟩ - (j * m + n) ∸ (j * m) ≡⟨ cong (_∸ j * m) (+-comm (j * m) n) ⟩ - (n + j * m) ∸ (j * m) ≡⟨ m+n∸n≡m n (j * m) ⟩ - n ∎ - -lem₁ : ∀ i j → 2 + i ≤′ 2 + j + i -lem₁ i j = ≤⇒≤′ $ s≤s $ s≤s $ m≤n+m i j - -lem₂ : ∀ d x {k n} → - d + x * k ≡ x * n → d + x * (n + k) ≡ 2 * x * n -lem₂ d x {k} {n} eq = begin - d + x * (n + k) ≡⟨ distrib-comm₂ d x k n ⟩ - d + x * k + x * n ≡⟨ cong₂ _+_ eq refl ⟩ - x * n + x * n ≡⟨ solve 3 (λ x n k → x :* n :+ x :* n - := con 2 :* x :* n) - refl x n k ⟩ - 2 * x * n ∎ - -lem₃ : ∀ d x {i k n} → - d + (1 + x + i) * k ≡ x * n → - d + (1 + x + i) * (n + k) ≡ (1 + 2 * x + i) * n -lem₃ d x {i} {k} {n} eq = begin - d + y * (n + k) ≡⟨ distrib-comm₂ d y k n ⟩ - d + y * k + y * n ≡⟨ cong₂ _+_ eq refl ⟩ - x * n + y * n ≡⟨ solve 3 (λ x n i → x :* n :+ (con 1 :+ x :+ i) :* n - := (con 1 :+ con 2 :* x :+ i) :* n) - refl x n i ⟩ - (1 + 2 * x + i) * n ∎ - where y = 1 + x + i - -lem₄ : ∀ d y {k i} n → - d + y * k ≡ (1 + y + i) * n → - d + y * (n + k) ≡ (1 + 2 * y + i) * n -lem₄ d y {k} {i} n eq = begin - d + y * (n + k) ≡⟨ distrib-comm₂ d y k n ⟩ - d + y * k + y * n ≡⟨ cong₂ _+_ eq refl ⟩ - (1 + y + i) * n + y * n ≡⟨ solve 3 (λ y i n → (con 1 :+ y :+ i) :* n :+ y :* n - := (con 1 :+ con 2 :* y :+ i) :* n) - refl y i n ⟩ - (1 + 2 * y + i) * n ∎ - -lem₅ : ∀ d x {n k} → - d + x * n ≡ x * k → - d + 2 * x * n ≡ x * (n + k) -lem₅ d x {n} {k} eq = begin - d + 2 * x * n ≡⟨ solve 3 (λ d x n → d :+ con 2 :* x :* n - := d :+ x :* n :+ x :* n) - refl d x n ⟩ - d + x * n + x * n ≡⟨ cong₂ _+_ eq refl ⟩ - x * k + x * n ≡⟨ distrib-comm x k n ⟩ - x * (n + k) ∎ - -lem₆ : ∀ d x {n i k} → - d + x * n ≡ (1 + x + i) * k → - d + (1 + 2 * x + i) * n ≡ (1 + x + i) * (n + k) -lem₆ d x {n} {i} {k} eq = begin - d + (1 + 2 * x + i) * n ≡⟨ solve 4 (λ d x i n → d :+ (con 1 :+ con 2 :* x :+ i) :* n - := d :+ x :* n :+ (con 1 :+ x :+ i) :* n) - refl d x i n ⟩ - d + x * n + y * n ≡⟨ cong₂ _+_ eq refl ⟩ - y * k + y * n ≡⟨ distrib-comm y k n ⟩ - y * (n + k) ∎ - where y = 1 + x + i - -lem₇ : ∀ d y {i} n {k} → - d + (1 + y + i) * n ≡ y * k → - d + (1 + 2 * y + i) * n ≡ y * (n + k) -lem₇ d y {i} n {k} eq = begin - d + (1 + 2 * y + i) * n ≡⟨ solve 4 (λ d y i n → d :+ (con 1 :+ con 2 :* y :+ i) :* n - := d :+ (con 1 :+ y :+ i) :* n :+ y :* n) - refl d y i n ⟩ - d + (1 + y + i) * n + y * n ≡⟨ cong₂ _+_ eq refl ⟩ - y * k + y * n ≡⟨ distrib-comm y k n ⟩ - y * (n + k) ∎ - -lem₈ : ∀ {i j k q} x y → - 1 + y * j ≡ x * i → j * k ≡ q * i → - k ≡ (x * k ∸ y * q) * i -lem₈ {i} {j} {k} {q} x y eq eq′ = - sym (lem₀ (x * k) (y * q) i k lemma) - where - lemma = begin - x * k * i ≡⟨ solve 3 (λ x k i → x :* k :* i - := x :* i :* k) - refl x k i ⟩ - x * i * k ≡⟨ cong (_* k) (sym eq) ⟩ - (1 + y * j) * k ≡⟨ solve 3 (λ y j k → (con 1 :+ y :* j) :* k - := y :* (j :* k) :+ k) - refl y j k ⟩ - y * (j * k) + k ≡⟨ cong (λ n → y * n + k) eq′ ⟩ - y * (q * i) + k ≡⟨ solve 4 (λ y q i k → y :* (q :* i) :+ k - := y :* q :* i :+ k) - refl y q i k ⟩ - y * q * i + k ∎ - -lem₉ : ∀ {i j k q} x y → - 1 + x * i ≡ y * j → j * k ≡ q * i → - k ≡ (y * q ∸ x * k) * i -lem₉ {i} {j} {k} {q} x y eq eq′ = - sym (lem₀ (y * q) (x * k) i k lemma) - where - lem = solve 3 (λ a b c → a :* b :* c := b :* c :* a) refl - lemma = begin - y * q * i ≡⟨ lem y q i ⟩ - q * i * y ≡⟨ cong (λ n → n * y) (sym eq′) ⟩ - j * k * y ≡⟨ sym (lem y j k) ⟩ - y * j * k ≡⟨ cong (λ n → n * k) (sym eq) ⟩ - (1 + x * i) * k ≡⟨ solve 3 (λ x i k → (con 1 :+ x :* i) :* k - := x :* k :* i :+ k) - refl x i k ⟩ - x * k * i + k ∎ - -lem₁₀ : ∀ {a′} b c {d} e f → let a = suc a′ in - a + b * (c * d * a) ≡ e * (f * d * a) → - d ≡ 1 -lem₁₀ {a′} b c {d} e f eq = - m*n≡1⇒n≡1 (e * f ∸ b * c) d - (lem₀ (e * f) (b * c) d 1 - (*-cancelʳ-≡ (e * f * d) (b * c * d + 1) _ (begin - e * f * d * a ≡⟨ solve 4 (λ e f d a → e :* f :* d :* a - := e :* (f :* d :* a)) - refl e f d a ⟩ - e * (f * d * a) ≡⟨ sym eq ⟩ - a + b * (c * d * a) ≡⟨ solve 4 (λ a b c d → a :+ b :* (c :* d :* a) - := (b :* c :* d :+ con 1) :* a) - refl a b c d ⟩ - (b * c * d + 1) * a ∎))) - where a = suc a′ - -lem₁₁ : ∀ {i j m n k d} x y → - 1 + y * j ≡ x * i → i * k ≡ m * d → j * k ≡ n * d → - k ≡ (x * m ∸ y * n) * d -lem₁₁ {i} {j} {m} {n} {k} {d} x y eq eq₁ eq₂ = - sym (lem₀ (x * m) (y * n) d k (begin - x * m * d ≡⟨ *-assoc x m d ⟩ - x * (m * d) ≡⟨ cong (x *_) (sym eq₁) ⟩ - x * (i * k) ≡⟨ sym (*-assoc x i k) ⟩ - x * i * k ≡⟨ cong₂ _*_ (sym eq) refl ⟩ - (1 + y * j) * k ≡⟨ solve 3 (λ y j k → (con 1 :+ y :* j) :* k - := y :* (j :* k) :+ k) - refl y j k ⟩ - y * (j * k) + k ≡⟨ cong (λ p → y * p + k) eq₂ ⟩ - y * (n * d) + k ≡⟨ cong₂ _+_ (sym $ *-assoc y n d) refl ⟩ - y * n * d + k ∎)) +open import Function.Base using (_$_) +open import Relation.Binary.PropositionalEquality + +open +-*-Solver +open ≡-Reasoning + +private + distrib-comm : ∀ x k n → x * k + x * n ≡ x * (n + k) + distrib-comm = + solve 3 (λ x k n → x :* k :+ x :* n := x :* (n :+ k)) refl + + distrib-comm₂ : ∀ d x k n → d + x * (n + k) ≡ d + x * k + x * n + distrib-comm₂ = + solve 4 (λ d x k n → d :+ x :* (n :+ k) := d :+ x :* k :+ x :* n) refl + +-- Other properties +-- TODO: Can this proof be simplified? An automatic solver which can +-- handle ∸ would be nice... +lem₀ : ∀ i j m n → i * m ≡ j * m + n → (i ∸ j) * m ≡ n +lem₀ i j m n eq = begin + (i ∸ j) * m ≡⟨ *-distribʳ-∸ m i j ⟩ + (i * m) ∸ (j * m) ≡⟨ cong (_∸ j * m) eq ⟩ + (j * m + n) ∸ (j * m) ≡⟨ cong (_∸ j * m) (+-comm (j * m) n) ⟩ + (n + j * m) ∸ (j * m) ≡⟨ m+n∸n≡m n (j * m) ⟩ + n ∎ + +lem₁ : ∀ i j → 2 + i ≤′ 2 + j + i +lem₁ i j = ≤⇒≤′ $ s≤s $ s≤s $ m≤n+m i j + +lem₂ : ∀ d x {k n} → + d + x * k ≡ x * n → d + x * (n + k) ≡ 2 * x * n +lem₂ d x {k} {n} eq = begin + d + x * (n + k) ≡⟨ distrib-comm₂ d x k n ⟩ + d + x * k + x * n ≡⟨ cong₂ _+_ eq refl ⟩ + x * n + x * n ≡⟨ solve 3 (λ x n k → x :* n :+ x :* n + := con 2 :* x :* n) + refl x n k ⟩ + 2 * x * n ∎ + +lem₃ : ∀ d x {i k n} → + d + (1 + x + i) * k ≡ x * n → + d + (1 + x + i) * (n + k) ≡ (1 + 2 * x + i) * n +lem₃ d x {i} {k} {n} eq = begin + d + y * (n + k) ≡⟨ distrib-comm₂ d y k n ⟩ + d + y * k + y * n ≡⟨ cong₂ _+_ eq refl ⟩ + x * n + y * n ≡⟨ solve 3 (λ x n i → x :* n :+ (con 1 :+ x :+ i) :* n + := (con 1 :+ con 2 :* x :+ i) :* n) + refl x n i ⟩ + (1 + 2 * x + i) * n ∎ + where y = 1 + x + i + +lem₄ : ∀ d y {k i} n → + d + y * k ≡ (1 + y + i) * n → + d + y * (n + k) ≡ (1 + 2 * y + i) * n +lem₄ d y {k} {i} n eq = begin + d + y * (n + k) ≡⟨ distrib-comm₂ d y k n ⟩ + d + y * k + y * n ≡⟨ cong₂ _+_ eq refl ⟩ + (1 + y + i) * n + y * n ≡⟨ solve 3 (λ y i n → (con 1 :+ y :+ i) :* n :+ y :* n + := (con 1 :+ con 2 :* y :+ i) :* n) + refl y i n ⟩ + (1 + 2 * y + i) * n ∎ + +lem₅ : ∀ d x {n k} → + d + x * n ≡ x * k → + d + 2 * x * n ≡ x * (n + k) +lem₅ d x {n} {k} eq = begin + d + 2 * x * n ≡⟨ solve 3 (λ d x n → d :+ con 2 :* x :* n + := d :+ x :* n :+ x :* n) + refl d x n ⟩ + d + x * n + x * n ≡⟨ cong₂ _+_ eq refl ⟩ + x * k + x * n ≡⟨ distrib-comm x k n ⟩ + x * (n + k) ∎ + +lem₆ : ∀ d x {n i k} → + d + x * n ≡ (1 + x + i) * k → + d + (1 + 2 * x + i) * n ≡ (1 + x + i) * (n + k) +lem₆ d x {n} {i} {k} eq = begin + d + (1 + 2 * x + i) * n ≡⟨ solve 4 (λ d x i n → d :+ (con 1 :+ con 2 :* x :+ i) :* n + := d :+ x :* n :+ (con 1 :+ x :+ i) :* n) + refl d x i n ⟩ + d + x * n + y * n ≡⟨ cong₂ _+_ eq refl ⟩ + y * k + y * n ≡⟨ distrib-comm y k n ⟩ + y * (n + k) ∎ + where y = 1 + x + i + +lem₇ : ∀ d y {i} n {k} → + d + (1 + y + i) * n ≡ y * k → + d + (1 + 2 * y + i) * n ≡ y * (n + k) +lem₇ d y {i} n {k} eq = begin + d + (1 + 2 * y + i) * n ≡⟨ solve 4 (λ d y i n → d :+ (con 1 :+ con 2 :* y :+ i) :* n + := d :+ (con 1 :+ y :+ i) :* n :+ y :* n) + refl d y i n ⟩ + d + (1 + y + i) * n + y * n ≡⟨ cong₂ _+_ eq refl ⟩ + y * k + y * n ≡⟨ distrib-comm y k n ⟩ + y * (n + k) ∎ + +lem₈ : ∀ {i j k q} x y → + 1 + y * j ≡ x * i → j * k ≡ q * i → + k ≡ (x * k ∸ y * q) * i +lem₈ {i} {j} {k} {q} x y eq eq′ = + sym (lem₀ (x * k) (y * q) i k lemma) + where + lemma = begin + x * k * i ≡⟨ solve 3 (λ x k i → x :* k :* i + := x :* i :* k) + refl x k i ⟩ + x * i * k ≡⟨ cong (_* k) (sym eq) ⟩ + (1 + y * j) * k ≡⟨ solve 3 (λ y j k → (con 1 :+ y :* j) :* k + := y :* (j :* k) :+ k) + refl y j k ⟩ + y * (j * k) + k ≡⟨ cong (λ n → y * n + k) eq′ ⟩ + y * (q * i) + k ≡⟨ solve 4 (λ y q i k → y :* (q :* i) :+ k + := y :* q :* i :+ k) + refl y q i k ⟩ + y * q * i + k ∎ + +lem₉ : ∀ {i j k q} x y → + 1 + x * i ≡ y * j → j * k ≡ q * i → + k ≡ (y * q ∸ x * k) * i +lem₉ {i} {j} {k} {q} x y eq eq′ = + sym (lem₀ (y * q) (x * k) i k lemma) + where + lem = solve 3 (λ a b c → a :* b :* c := b :* c :* a) refl + lemma = begin + y * q * i ≡⟨ lem y q i ⟩ + q * i * y ≡⟨ cong (λ n → n * y) (sym eq′) ⟩ + j * k * y ≡⟨ sym (lem y j k) ⟩ + y * j * k ≡⟨ cong (λ n → n * k) (sym eq) ⟩ + (1 + x * i) * k ≡⟨ solve 3 (λ x i k → (con 1 :+ x :* i) :* k + := x :* k :* i :+ k) + refl x i k ⟩ + x * k * i + k ∎ + +lem₁₀ : ∀ {a′} b c {d} e f → let a = suc a′ in + a + b * (c * d * a) ≡ e * (f * d * a) → + d ≡ 1 +lem₁₀ {a′} b c {d} e f eq = + m*n≡1⇒n≡1 (e * f ∸ b * c) d + (lem₀ (e * f) (b * c) d 1 + (*-cancelʳ-≡ (e * f * d) (b * c * d + 1) _ (begin + e * f * d * a ≡⟨ solve 4 (λ e f d a → e :* f :* d :* a + := e :* (f :* d :* a)) + refl e f d a ⟩ + e * (f * d * a) ≡⟨ sym eq ⟩ + a + b * (c * d * a) ≡⟨ solve 4 (λ a b c d → a :+ b :* (c :* d :* a) + := (b :* c :* d :+ con 1) :* a) + refl a b c d ⟩ + (b * c * d + 1) * a ∎))) + where a = suc a′ + +lem₁₁ : ∀ {i j m n k d} x y → + 1 + y * j ≡ x * i → i * k ≡ m * d → j * k ≡ n * d → + k ≡ (x * m ∸ y * n) * d +lem₁₁ {i} {j} {m} {n} {k} {d} x y eq eq₁ eq₂ = + sym (lem₀ (x * m) (y * n) d k (begin + x * m * d ≡⟨ *-assoc x m d ⟩ + x * (m * d) ≡⟨ cong (x *_) (sym eq₁) ⟩ + x * (i * k) ≡⟨ sym (*-assoc x i k) ⟩ + x * i * k ≡⟨ cong₂ _*_ (sym eq) refl ⟩ + (1 + y * j) * k ≡⟨ solve 3 (λ y j k → (con 1 :+ y :* j) :* k + := y :* (j :* k) :+ k) + refl y j k ⟩ + y * (j * k) + k ≡⟨ cong (λ p → y * p + k) eq₂ ⟩ + y * (n * d) + k ≡⟨ cong₂ _+_ (sym $ *-assoc y n d) refl ⟩ + y * n * d + k ∎)) \ No newline at end of file diff --git a/Data.Nat.GCD.html b/Data.Nat.GCD.html index cdfdb8b4..2ac3a0ae 100644 --- a/Data.Nat.GCD.html +++ b/Data.Nat.GCD.html @@ -15,393 +15,392 @@ open import Data.Nat.GCD.Lemmas open import Data.Nat.Properties open import Data.Nat.Induction - using (Acc; acc; <′-Rec; <′-recBuilder; <-wellFounded-fast) -open import Data.Product -open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂) -open import Function -open import Induction using (build) -open import Induction.Lexicographic using (_⊗_; [_⊗_]) -open import Relation.Binary -open import Relation.Binary.PropositionalEquality as P - using (_≡_; _≢_; subst; cong) -open import Relation.Nullary.Decidable using (Dec) -open import Relation.Nullary.Negation using (contradiction) -import Relation.Nullary.Decidable as Dec - -open import Algebra.Definitions {A = ℕ} _≡_ as Algebra - using (Associative; Commutative; LeftIdentity; RightIdentity; LeftZero; RightZero; Zero) - ------------------------------------------------------------------------- --- Definition - --- Calculated via Euclid's algorithm. In order to show progress, --- avoiding the initial step where the first argument may increase, it --- is necessary to first define a version `gcd′` which assumes that the --- second argument is strictly smaller than the first. The full `gcd` --- function then compares the two arguments and applies `gcd′` --- accordingly. - -gcd′ : ∀ m n → Acc _<_ m → n < m → ℕ -gcd′ m zero _ _ = m -gcd′ m n@(suc _) (acc rec) n<m = gcd′ n (m % n) (rec _ n<m) (m%n<n m n) - -gcd : ℕ → ℕ → ℕ -gcd m n with <-cmp m n -... | tri< m<n _ _ = gcd′ n m (<-wellFounded-fast n) m<n -... | tri≈ _ _ _ = m -... | tri> _ _ n<m = gcd′ m n (<-wellFounded-fast m) n<m - ------------------------------------------------------------------------- --- Core properties of gcd′ - -gcd′[m,n]∣m,n : ∀ {m n} rec n<m → gcd′ m n rec n<m ∣ m × gcd′ m n rec n<m ∣ n -gcd′[m,n]∣m,n {m} {zero} rec n<m = ∣-refl , m ∣0 -gcd′[m,n]∣m,n {m} {suc n} (acc rec) n<m - with gcd′[m,n]∣m,n (rec _ n<m) (m%n<n m (suc n)) -... | gcd∣n , gcd∣m%n = ∣n∣m%n⇒∣m gcd∣n gcd∣m%n , gcd∣n - -gcd′-greatest : ∀ {m n c} rec n<m → c ∣ m → c ∣ n → c ∣ gcd′ m n rec n<m -gcd′-greatest {m} {zero} rec n<m c∣m c∣n = c∣m -gcd′-greatest {m} {suc n} (acc rec) n<m c∣m c∣n = - gcd′-greatest (rec _ n<m) (m%n<n m (suc n)) c∣n (%-presˡ-∣ c∣m c∣n) - ------------------------------------------------------------------------- --- Core properties of gcd - -gcd[m,n]∣m : ∀ m n → gcd m n ∣ m -gcd[m,n]∣m m n with <-cmp m n -... | tri< n<m _ _ = proj₂ (gcd′[m,n]∣m,n {n} {m} _ _) -... | tri≈ _ _ _ = ∣-refl -... | tri> _ _ m<n = proj₁ (gcd′[m,n]∣m,n {m} {n} _ _) - -gcd[m,n]∣n : ∀ m n → gcd m n ∣ n -gcd[m,n]∣n m n with <-cmp m n -... | tri< n<m _ _ = proj₁ (gcd′[m,n]∣m,n {n} {m} _ _) -... | tri≈ _ P.refl _ = ∣-refl -... | tri> _ _ m<n = proj₂ (gcd′[m,n]∣m,n {m} {n} _ _) - -gcd-greatest : ∀ {m n c} → c ∣ m → c ∣ n → c ∣ gcd m n -gcd-greatest {m} {n} c∣m c∣n with <-cmp m n -... | tri< n<m _ _ = gcd′-greatest _ _ c∣n c∣m -... | tri≈ _ _ _ = c∣m -... | tri> _ _ m<n = gcd′-greatest _ _ c∣m c∣n - ------------------------------------------------------------------------- --- Other properties - --- Note that all other properties of `gcd` should be inferable from the --- 3 core properties above. - -gcd[0,0]≡0 : gcd 0 0 ≡ 0 -gcd[0,0]≡0 = ∣-antisym (gcd 0 0 ∣0) (gcd-greatest (0 ∣0) (0 ∣0)) - -gcd[m,n]≢0 : ∀ m n → m ≢ 0 ⊎ n ≢ 0 → gcd m n ≢ 0 -gcd[m,n]≢0 m n (inj₁ m≢0) eq = m≢0 (0∣⇒≡0 (subst (_∣ m) eq (gcd[m,n]∣m m n))) -gcd[m,n]≢0 m n (inj₂ n≢0) eq = n≢0 (0∣⇒≡0 (subst (_∣ n) eq (gcd[m,n]∣n m n))) - -gcd[m,n]≡0⇒m≡0 : ∀ {m n} → gcd m n ≡ 0 → m ≡ 0 -gcd[m,n]≡0⇒m≡0 {zero} {n} eq = P.refl -gcd[m,n]≡0⇒m≡0 {suc m} {n} eq = contradiction eq (gcd[m,n]≢0 (suc m) n (inj₁ λ())) - -gcd[m,n]≡0⇒n≡0 : ∀ m {n} → gcd m n ≡ 0 → n ≡ 0 -gcd[m,n]≡0⇒n≡0 m {zero} eq = P.refl -gcd[m,n]≡0⇒n≡0 m {suc n} eq = contradiction eq (gcd[m,n]≢0 m (suc n) (inj₂ λ())) - -gcd-comm : Commutative gcd -gcd-comm m n = ∣-antisym - (gcd-greatest (gcd[m,n]∣n m n) (gcd[m,n]∣m m n)) - (gcd-greatest (gcd[m,n]∣n n m) (gcd[m,n]∣m n m)) - -gcd-assoc : Associative gcd -gcd-assoc m n p = ∣-antisym - (gcd-greatest gcd[gcd[m,n],p]|m (gcd-greatest gcd[gcd[m,n],p]∣n gcd[gcd[m,n],p]∣p)) - (gcd-greatest (gcd-greatest gcd[m,gcd[n,p]]∣m gcd[m,gcd[n,p]]∣n) gcd[m,gcd[n,p]]∣p) - where - open ∣-Reasoning - gcd[gcd[m,n],p]|m = begin - gcd (gcd m n) p ∣⟨ gcd[m,n]∣m (gcd m n) p ⟩ - gcd m n ∣⟨ gcd[m,n]∣m m n ⟩ - m ∎ - gcd[gcd[m,n],p]∣n = begin - gcd (gcd m n) p ∣⟨ gcd[m,n]∣m (gcd m n) p ⟩ - gcd m n ∣⟨ gcd[m,n]∣n m n ⟩ - n ∎ - gcd[gcd[m,n],p]∣p = gcd[m,n]∣n (gcd m n) p - gcd[m,gcd[n,p]]∣m = gcd[m,n]∣m m (gcd n p) - gcd[m,gcd[n,p]]∣n = begin - gcd m (gcd n p) ∣⟨ gcd[m,n]∣n m (gcd n p) ⟩ - gcd n p ∣⟨ gcd[m,n]∣m n p ⟩ - n ∎ - gcd[m,gcd[n,p]]∣p = begin - gcd m (gcd n p) ∣⟨ gcd[m,n]∣n m (gcd n p) ⟩ - gcd n p ∣⟨ gcd[m,n]∣n n p ⟩ - p ∎ - -gcd-identityˡ : LeftIdentity 0 gcd -gcd-identityˡ zero = P.refl -gcd-identityˡ (suc _) = P.refl - -gcd-identityʳ : RightIdentity 0 gcd -gcd-identityʳ zero = P.refl -gcd-identityʳ (suc _) = P.refl - -gcd-identity : Algebra.Identity 0 gcd -gcd-identity = gcd-identityˡ , gcd-identityʳ - -gcd-zeroˡ : LeftZero 1 gcd -gcd-zeroˡ n = ∣-antisym gcd[1,n]∣1 1∣gcd[1,n] - where - gcd[1,n]∣1 = gcd[m,n]∣m 1 n - 1∣gcd[1,n] = 1∣ gcd 1 n - -gcd-zeroʳ : RightZero 1 gcd -gcd-zeroʳ n = ∣-antisym gcd[n,1]∣1 1∣gcd[n,1] - where - gcd[n,1]∣1 = gcd[m,n]∣n n 1 - 1∣gcd[n,1] = 1∣ gcd n 1 - -gcd-zero : Zero 1 gcd -gcd-zero = gcd-zeroˡ , gcd-zeroʳ - -gcd-universality : ∀ {m n g} → - (∀ {d} → d ∣ m × d ∣ n → d ∣ g) → - (∀ {d} → d ∣ g → d ∣ m × d ∣ n) → - g ≡ gcd m n -gcd-universality {m} {n} forwards backwards with backwards ∣-refl -... | back₁ , back₂ = ∣-antisym - (gcd-greatest back₁ back₂) - (forwards (gcd[m,n]∣m m n , gcd[m,n]∣n m n)) - --- This could be simplified with some nice backwards/forwards reasoning --- after the new function hierarchy is up and running. -gcd[cm,cn]/c≡gcd[m,n] : ∀ c m n .{{_ : NonZero c}} → gcd (c * m) (c * n) / c ≡ gcd m n -gcd[cm,cn]/c≡gcd[m,n] c m n = gcd-universality forwards backwards - where - forwards : ∀ {d : ℕ} → d ∣ m × d ∣ n → d ∣ gcd (c * m) (c * n) / c - forwards {d} (d∣m , d∣n) = m*n∣o⇒n∣o/m c d (gcd-greatest (*-monoʳ-∣ c d∣m) (*-monoʳ-∣ c d∣n)) - - backwards : ∀ {d : ℕ} → d ∣ gcd (c * m) (c * n) / c → d ∣ m × d ∣ n - backwards {d} d∣gcd[cm,cn]/c with m∣n/o⇒o*m∣n (gcd-greatest (m∣m*n m) (m∣m*n n)) d∣gcd[cm,cn]/c - ... | cd∣gcd[cm,n] = - *-cancelˡ-∣ c (∣-trans cd∣gcd[cm,n] (gcd[m,n]∣m (c * m) _)) , - *-cancelˡ-∣ c (∣-trans cd∣gcd[cm,n] (gcd[m,n]∣n (c * m) _)) - -c*gcd[m,n]≡gcd[cm,cn] : ∀ c m n → c * gcd m n ≡ gcd (c * m) (c * n) -c*gcd[m,n]≡gcd[cm,cn] zero m n = P.sym gcd[0,0]≡0 -c*gcd[m,n]≡gcd[cm,cn] c@(suc _) m n = begin - c * gcd m n ≡⟨ cong (c *_) (P.sym (gcd[cm,cn]/c≡gcd[m,n] c m n)) ⟩ - c * (gcd (c * m) (c * n) / c) ≡⟨ m*[n/m]≡n (gcd-greatest (m∣m*n m) (m∣m*n n)) ⟩ - gcd (c * m) (c * n) ∎ - where open P.≡-Reasoning - -gcd[m,n]≤n : ∀ m n .{{_ : NonZero n}} → gcd m n ≤ n -gcd[m,n]≤n m n = ∣⇒≤ (gcd[m,n]∣n m n) - -n/gcd[m,n]≢0 : ∀ m n .{{_ : NonZero n}} .{{gcd≢0 : NonZero (gcd m n)}} → - n / gcd m n ≢ 0 -n/gcd[m,n]≢0 m n = m<n⇒n≢0 (m≥n⇒m/n>0 {n} {gcd m n} (gcd[m,n]≤n m n)) - -m/gcd[m,n]≢0 : ∀ m n .{{_ : NonZero m}} .{{gcd≢0 : NonZero (gcd m n)}} → - m / gcd m n ≢ 0 -m/gcd[m,n]≢0 m n rewrite gcd-comm m n = n/gcd[m,n]≢0 n m - ------------------------------------------------------------------------- --- A formal specification of GCD - -module GCD where - - -- Specification of the greatest common divisor (gcd) of two natural - -- numbers. - - record GCD (m n gcd : ℕ) : Set where - constructor is - field - -- The gcd is a common divisor. - commonDivisor : gcd ∣ m × gcd ∣ n - - -- All common divisors divide the gcd, i.e. the gcd is the - -- greatest common divisor according to the partial order _∣_. - greatest : ∀ {d} → d ∣ m × d ∣ n → d ∣ gcd + using (Acc; acc; <′-Rec; <′-recBuilder; <-wellFounded-fast) +open import Data.Product.Base + using (_×_; _,_; proj₂; proj₁; swap; uncurry′; ∃; map) +open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂) +open import Function.Base using (_$_; _∘_) +open import Induction using (build) +open import Induction.Lexicographic using (_⊗_; [_⊗_]) +open import Relation.Binary.Definitions using (tri<; tri>; tri≈; Symmetric) +open import Relation.Binary.PropositionalEquality.Core as P + using (_≡_; _≢_; subst; cong) +open import Relation.Binary.PropositionalEquality.Properties + using (module ≡-Reasoning) +open import Relation.Nullary.Decidable using (Dec) +open import Relation.Nullary.Negation using (contradiction) +import Relation.Nullary.Decidable as Dec + +open import Algebra.Definitions {A = ℕ} _≡_ as Algebra + using (Associative; Commutative; LeftIdentity; RightIdentity; LeftZero; RightZero; Zero) + +------------------------------------------------------------------------ +-- Definition + +-- Calculated via Euclid's algorithm. In order to show progress, +-- avoiding the initial step where the first argument may increase, it +-- is necessary to first define a version `gcd′` which assumes that the +-- second argument is strictly smaller than the first. The full `gcd` +-- function then compares the two arguments and applies `gcd′` +-- accordingly. + +gcd′ : ∀ m n → Acc _<_ m → n < m → ℕ +gcd′ m zero _ _ = m +gcd′ m n@(suc _) (acc rec) n<m = gcd′ n (m % n) (rec n<m) (m%n<n m n) + +gcd : ℕ → ℕ → ℕ +gcd m n with <-cmp m n +... | tri< m<n _ _ = gcd′ n m (<-wellFounded-fast n) m<n +... | tri≈ _ _ _ = m +... | tri> _ _ n<m = gcd′ m n (<-wellFounded-fast m) n<m + +------------------------------------------------------------------------ +-- Core properties of gcd′ + +gcd′[m,n]∣m,n : ∀ {m n} rec n<m → gcd′ m n rec n<m ∣ m × gcd′ m n rec n<m ∣ n +gcd′[m,n]∣m,n {m} {zero} rec n<m = ∣-refl , m ∣0 +gcd′[m,n]∣m,n {m} {n@(suc _)} (acc rec) n<m + with gcd∣n , gcd∣m%n ← gcd′[m,n]∣m,n (rec n<m) (m%n<n m n) + = ∣n∣m%n⇒∣m gcd∣n gcd∣m%n , gcd∣n + +gcd′-greatest : ∀ {m n c} rec n<m → c ∣ m → c ∣ n → c ∣ gcd′ m n rec n<m +gcd′-greatest {m} {zero} rec n<m c∣m c∣n = c∣m +gcd′-greatest {m} {n@(suc _)} (acc rec) n<m c∣m c∣n = + gcd′-greatest (rec n<m) (m%n<n m n) c∣n (%-presˡ-∣ c∣m c∣n) + +------------------------------------------------------------------------ +-- Core properties of gcd + +gcd[m,n]∣m : ∀ m n → gcd m n ∣ m +gcd[m,n]∣m m n with <-cmp m n +... | tri< n<m _ _ = proj₂ (gcd′[m,n]∣m,n {n} {m} _ _) +... | tri≈ _ _ _ = ∣-refl +... | tri> _ _ m<n = proj₁ (gcd′[m,n]∣m,n {m} {n} _ _) + +gcd[m,n]∣n : ∀ m n → gcd m n ∣ n +gcd[m,n]∣n m n with <-cmp m n +... | tri< n<m _ _ = proj₁ (gcd′[m,n]∣m,n {n} {m} _ _) +... | tri≈ _ P.refl _ = ∣-refl +... | tri> _ _ m<n = proj₂ (gcd′[m,n]∣m,n {m} {n} _ _) + +gcd-greatest : ∀ {m n c} → c ∣ m → c ∣ n → c ∣ gcd m n +gcd-greatest {m} {n} c∣m c∣n with <-cmp m n +... | tri< n<m _ _ = gcd′-greatest _ _ c∣n c∣m +... | tri≈ _ _ _ = c∣m +... | tri> _ _ m<n = gcd′-greatest _ _ c∣m c∣n + +------------------------------------------------------------------------ +-- Other properties + +-- Note that all other properties of `gcd` should be inferable from the +-- 3 core properties above. + +gcd[0,0]≡0 : gcd 0 0 ≡ 0 +gcd[0,0]≡0 = ∣-antisym (gcd 0 0 ∣0) (gcd-greatest (0 ∣0) (0 ∣0)) + +gcd[m,n]≢0 : ∀ m n → m ≢ 0 ⊎ n ≢ 0 → gcd m n ≢ 0 +gcd[m,n]≢0 m n (inj₁ m≢0) eq = m≢0 (0∣⇒≡0 (subst (_∣ m) eq (gcd[m,n]∣m m n))) +gcd[m,n]≢0 m n (inj₂ n≢0) eq = n≢0 (0∣⇒≡0 (subst (_∣ n) eq (gcd[m,n]∣n m n))) + +gcd[m,n]≡0⇒m≡0 : ∀ {m n} → gcd m n ≡ 0 → m ≡ 0 +gcd[m,n]≡0⇒m≡0 {zero} {n} eq = P.refl +gcd[m,n]≡0⇒m≡0 {suc m} {n} eq = contradiction eq (gcd[m,n]≢0 (suc m) n (inj₁ λ())) + +gcd[m,n]≡0⇒n≡0 : ∀ m {n} → gcd m n ≡ 0 → n ≡ 0 +gcd[m,n]≡0⇒n≡0 m {zero} eq = P.refl +gcd[m,n]≡0⇒n≡0 m {suc n} eq = contradiction eq (gcd[m,n]≢0 m (suc n) (inj₂ λ())) + +gcd-comm : Commutative gcd +gcd-comm m n = ∣-antisym + (gcd-greatest (gcd[m,n]∣n m n) (gcd[m,n]∣m m n)) + (gcd-greatest (gcd[m,n]∣n n m) (gcd[m,n]∣m n m)) + +gcd-assoc : Associative gcd +gcd-assoc m n p = ∣-antisym + (gcd-greatest gcd[gcd[m,n],p]|m (gcd-greatest gcd[gcd[m,n],p]∣n gcd[gcd[m,n],p]∣p)) + (gcd-greatest (gcd-greatest gcd[m,gcd[n,p]]∣m gcd[m,gcd[n,p]]∣n) gcd[m,gcd[n,p]]∣p) + where + open ∣-Reasoning + gcd[gcd[m,n],p]|m = begin + gcd (gcd m n) p ∣⟨ gcd[m,n]∣m (gcd m n) p ⟩ + gcd m n ∣⟨ gcd[m,n]∣m m n ⟩ + m ∎ + gcd[gcd[m,n],p]∣n = begin + gcd (gcd m n) p ∣⟨ gcd[m,n]∣m (gcd m n) p ⟩ + gcd m n ∣⟨ gcd[m,n]∣n m n ⟩ + n ∎ + gcd[gcd[m,n],p]∣p = gcd[m,n]∣n (gcd m n) p + gcd[m,gcd[n,p]]∣m = gcd[m,n]∣m m (gcd n p) + gcd[m,gcd[n,p]]∣n = begin + gcd m (gcd n p) ∣⟨ gcd[m,n]∣n m (gcd n p) ⟩ + gcd n p ∣⟨ gcd[m,n]∣m n p ⟩ + n ∎ + gcd[m,gcd[n,p]]∣p = begin + gcd m (gcd n p) ∣⟨ gcd[m,n]∣n m (gcd n p) ⟩ + gcd n p ∣⟨ gcd[m,n]∣n n p ⟩ + p ∎ + +gcd-identityˡ : LeftIdentity 0 gcd +gcd-identityˡ zero = P.refl +gcd-identityˡ (suc _) = P.refl + +gcd-identityʳ : RightIdentity 0 gcd +gcd-identityʳ zero = P.refl +gcd-identityʳ (suc _) = P.refl + +gcd-identity : Algebra.Identity 0 gcd +gcd-identity = gcd-identityˡ , gcd-identityʳ + +gcd-zeroˡ : LeftZero 1 gcd +gcd-zeroˡ n = ∣-antisym gcd[1,n]∣1 1∣gcd[1,n] + where + gcd[1,n]∣1 = gcd[m,n]∣m 1 n + 1∣gcd[1,n] = 1∣ gcd 1 n + +gcd-zeroʳ : RightZero 1 gcd +gcd-zeroʳ n = ∣-antisym gcd[n,1]∣1 1∣gcd[n,1] + where + gcd[n,1]∣1 = gcd[m,n]∣n n 1 + 1∣gcd[n,1] = 1∣ gcd n 1 + +gcd-zero : Zero 1 gcd +gcd-zero = gcd-zeroˡ , gcd-zeroʳ + +gcd-universality : ∀ {m n g} → + (∀ {d} → d ∣ m × d ∣ n → d ∣ g) → + (∀ {d} → d ∣ g → d ∣ m × d ∣ n) → + g ≡ gcd m n +gcd-universality {m} {n} forwards backwards with back₁ , back₂ ← backwards ∣-refl + = ∣-antisym (gcd-greatest back₁ back₂) (forwards (gcd[m,n]∣m m n , gcd[m,n]∣n m n)) + +-- This could be simplified with some nice backwards/forwards reasoning +-- after the new function hierarchy is up and running. +gcd[cm,cn]/c≡gcd[m,n] : ∀ c m n .{{_ : NonZero c}} → gcd (c * m) (c * n) / c ≡ gcd m n +gcd[cm,cn]/c≡gcd[m,n] c m n = gcd-universality forwards backwards + where + forwards : ∀ {d : ℕ} → d ∣ m × d ∣ n → d ∣ gcd (c * m) (c * n) / c + forwards {d} (d∣m , d∣n) = m*n∣o⇒n∣o/m c d (gcd-greatest (*-monoʳ-∣ c d∣m) (*-monoʳ-∣ c d∣n)) + + backwards : ∀ {d : ℕ} → d ∣ gcd (c * m) (c * n) / c → d ∣ m × d ∣ n + backwards {d} d∣gcd[cm,cn]/c + with cd∣gcd[cm,n] ← m∣n/o⇒o*m∣n (gcd-greatest (m∣m*n m) (m∣m*n n)) d∣gcd[cm,cn]/c + = *-cancelˡ-∣ c (∣-trans cd∣gcd[cm,n] (gcd[m,n]∣m (c * m) _)) , + *-cancelˡ-∣ c (∣-trans cd∣gcd[cm,n] (gcd[m,n]∣n (c * m) _)) + +c*gcd[m,n]≡gcd[cm,cn] : ∀ c m n → c * gcd m n ≡ gcd (c * m) (c * n) +c*gcd[m,n]≡gcd[cm,cn] zero m n = P.sym gcd[0,0]≡0 +c*gcd[m,n]≡gcd[cm,cn] c@(suc _) m n = begin + c * gcd m n ≡⟨ cong (c *_) (P.sym (gcd[cm,cn]/c≡gcd[m,n] c m n)) ⟩ + c * (gcd (c * m) (c * n) / c) ≡⟨ m*[n/m]≡n (gcd-greatest (m∣m*n m) (m∣m*n n)) ⟩ + gcd (c * m) (c * n) ∎ + where open ≡-Reasoning + +gcd[m,n]≤n : ∀ m n .{{_ : NonZero n}} → gcd m n ≤ n +gcd[m,n]≤n m n = ∣⇒≤ (gcd[m,n]∣n m n) + +n/gcd[m,n]≢0 : ∀ m n .{{_ : NonZero n}} .{{gcd≢0 : NonZero (gcd m n)}} → + n / gcd m n ≢ 0 +n/gcd[m,n]≢0 m n = m<n⇒n≢0 (m≥n⇒m/n>0 {n} {gcd m n} (gcd[m,n]≤n m n)) + +m/gcd[m,n]≢0 : ∀ m n .{{_ : NonZero m}} .{{gcd≢0 : NonZero (gcd m n)}} → + m / gcd m n ≢ 0 +m/gcd[m,n]≢0 m n rewrite gcd-comm m n = n/gcd[m,n]≢0 n m + +------------------------------------------------------------------------ +-- A formal specification of GCD + +module GCD where + + -- Specification of the greatest common divisor (gcd) of two natural + -- numbers. + + record GCD (m n gcd : ℕ) : Set where + constructor is + field + -- The gcd is a common divisor. + commonDivisor : gcd ∣ m × gcd ∣ n + + -- All common divisors divide the gcd, i.e. the gcd is the + -- greatest common divisor according to the partial order _∣_. + greatest : ∀ {d} → d ∣ m × d ∣ n → d ∣ gcd - gcd∣m : gcd ∣ m - gcd∣m = proj₁ commonDivisor + gcd∣m : gcd ∣ m + gcd∣m = proj₁ commonDivisor - gcd∣n : gcd ∣ n - gcd∣n = proj₂ commonDivisor + gcd∣n : gcd ∣ n + gcd∣n = proj₂ commonDivisor - open GCD public + open GCD public - -- The gcd is unique. + -- The gcd is unique. - unique : ∀ {d₁ d₂ m n} → GCD m n d₁ → GCD m n d₂ → d₁ ≡ d₂ - unique d₁ d₂ = ∣-antisym (GCD.greatest d₂ (GCD.commonDivisor d₁)) - (GCD.greatest d₁ (GCD.commonDivisor d₂)) + unique : ∀ {d₁ d₂ m n} → GCD m n d₁ → GCD m n d₂ → d₁ ≡ d₂ + unique d₁ d₂ = ∣-antisym (GCD.greatest d₂ (GCD.commonDivisor d₁)) + (GCD.greatest d₁ (GCD.commonDivisor d₂)) - -- The gcd relation is "symmetric". + -- The gcd relation is "symmetric". - sym : ∀ {d m n} → GCD m n d → GCD n m d - sym g = is (swap $ GCD.commonDivisor g) (GCD.greatest g ∘ swap) + sym : ∀ {d m n} → GCD m n d → GCD n m d + sym g = is (swap $ GCD.commonDivisor g) (GCD.greatest g ∘ swap) - -- The gcd relation is "reflexive". + -- The gcd relation is "reflexive". - refl : ∀ {n} → GCD n n n - refl = is (∣-refl , ∣-refl) proj₁ + refl : ∀ {n} → GCD n n n + refl = is (∣-refl , ∣-refl) proj₁ - -- The GCD of 0 and n is n. + -- The GCD of 0 and n is n. - base : ∀ {n} → GCD 0 n n - base {n} = is (n ∣0 , ∣-refl) proj₂ + base : ∀ {n} → GCD 0 n n + base {n} = is (n ∣0 , ∣-refl) proj₂ - -- If d is the gcd of n and k, then it is also the gcd of n and - -- n + k. + -- If d is the gcd of n and k, then it is also the gcd of n and + -- n + k. - step : ∀ {n k d} → GCD n k d → GCD n (n + k) d - step g with GCD.commonDivisor g - step {n} {k} {d} g | (d₁ , d₂) = is (d₁ , ∣m∣n⇒∣m+n d₁ d₂) greatest′ - where - greatest′ : ∀ {d′} → d′ ∣ n × d′ ∣ n + k → d′ ∣ d - greatest′ (d₁ , d₂) = GCD.greatest g (d₁ , ∣m+n∣m⇒∣n d₂ d₁) + step : ∀ {n k d} → GCD n k d → GCD n (n + k) d + step {n} {k} {d} g with d₁ , d₂ ← GCD.commonDivisor g + = is (d₁ , ∣m∣n⇒∣m+n d₁ d₂) greatest′ + where + greatest′ : ∀ {d′} → d′ ∣ n × d′ ∣ n + k → d′ ∣ d + greatest′ (d₁ , d₂) = GCD.greatest g (d₁ , ∣m+n∣m⇒∣n d₂ d₁) -open GCD public using (GCD) hiding (module GCD) +open GCD public using (GCD) hiding (module GCD) --- The function gcd fulfils the conditions required of GCD +-- The function gcd fulfils the conditions required of GCD -gcd-GCD : ∀ m n → GCD m n (gcd m n) -gcd-GCD m n = record - { commonDivisor = gcd[m,n]∣m m n , gcd[m,n]∣n m n - ; greatest = uncurry′ gcd-greatest - } +gcd-GCD : ∀ m n → GCD m n (gcd m n) +gcd-GCD m n = record + { commonDivisor = gcd[m,n]∣m m n , gcd[m,n]∣n m n + ; greatest = uncurry′ gcd-greatest + } --- Calculates the gcd of the arguments. +-- Calculates the gcd of the arguments. -mkGCD : ∀ m n → ∃ λ d → GCD m n d -mkGCD m n = gcd m n , gcd-GCD m n +mkGCD : ∀ m n → ∃ λ d → GCD m n d +mkGCD m n = gcd m n , gcd-GCD m n --- gcd as a proposition is decidable +-- gcd as a proposition is decidable -gcd? : (m n d : ℕ) → Dec (GCD m n d) -gcd? m n d = - Dec.map′ (λ { P.refl → gcd-GCD m n }) (GCD.unique (gcd-GCD m n)) - (gcd m n ≟ d) +gcd? : (m n d : ℕ) → Dec (GCD m n d) +gcd? m n d = + Dec.map′ (λ { P.refl → gcd-GCD m n }) (GCD.unique (gcd-GCD m n)) + (gcd m n ≟ d) -GCD-* : ∀ {m n d c} .{{_ : NonZero c}} → GCD (m * c) (n * c) (d * c) → GCD m n d -GCD-* {c = suc _} (GCD.is (dc∣nc , dc∣mc) dc-greatest) = - GCD.is (*-cancelʳ-∣ _ dc∣nc , *-cancelʳ-∣ _ dc∣mc) - λ {_} → *-cancelʳ-∣ _ ∘ dc-greatest ∘ map (*-monoˡ-∣ _) (*-monoˡ-∣ _) +GCD-* : ∀ {m n d c} .{{_ : NonZero c}} → GCD (m * c) (n * c) (d * c) → GCD m n d +GCD-* {c = suc _} (GCD.is (dc∣nc , dc∣mc) dc-greatest) = + GCD.is (*-cancelʳ-∣ _ dc∣nc , *-cancelʳ-∣ _ dc∣mc) + λ {_} → *-cancelʳ-∣ _ ∘ dc-greatest ∘ map (*-monoˡ-∣ _) (*-monoˡ-∣ _) -GCD-/ : ∀ {m n d c} .{{_ : NonZero c}} → c ∣ m → c ∣ n → c ∣ d → - GCD m n d → GCD (m / c) (n / c) (d / c) -GCD-/ {m} {n} {d} {c} {{x}} - (divides p P.refl) (divides q P.refl) (divides r P.refl) gcd - rewrite m*n/n≡m p c {{x}} | m*n/n≡m q c {{x}} | m*n/n≡m r c {{x}} = GCD-* gcd +GCD-/ : ∀ {m n d c} .{{_ : NonZero c}} → c ∣ m → c ∣ n → c ∣ d → + GCD m n d → GCD (m / c) (n / c) (d / c) +GCD-/ {m} {n} {d} {c} {{x}} + (divides-refl p) (divides-refl q) (divides-refl r) gcd + rewrite m*n/n≡m p c {{x}} | m*n/n≡m q c {{x}} | m*n/n≡m r c {{x}} = GCD-* gcd -GCD-/gcd : ∀ m n .{{_ : NonZero (gcd m n)}} → GCD (m / gcd m n) (n / gcd m n) 1 -GCD-/gcd m n rewrite P.sym (n/n≡1 (gcd m n)) = - GCD-/ (gcd[m,n]∣m m n) (gcd[m,n]∣n m n) ∣-refl (gcd-GCD m n) +GCD-/gcd : ∀ m n .{{_ : NonZero (gcd m n)}} → GCD (m / gcd m n) (n / gcd m n) 1 +GCD-/gcd m n rewrite P.sym (n/n≡1 (gcd m n)) = + GCD-/ (gcd[m,n]∣m m n) (gcd[m,n]∣n m n) ∣-refl (gcd-GCD m n) ------------------------------------------------------------------------- --- Calculating the gcd +------------------------------------------------------------------------ +-- Calculating the gcd --- The calculation also proves Bézout's lemma. +-- The calculation also proves Bézout's lemma. -module Bézout where +module Bézout where - module Identity where + module Identity where - -- If m and n have greatest common divisor d, then one of the - -- following two equations is satisfied, for some numbers x and y. - -- The proof is "lemma" below (Bézout's lemma). - -- - -- (If this identity was stated using integers instead of natural - -- numbers, then it would not be necessary to have two equations.) + -- If m and n have greatest common divisor d, then one of the + -- following two equations is satisfied, for some numbers x and y. + -- The proof is "lemma" below (Bézout's lemma). + -- + -- (If this identity was stated using integers instead of natural + -- numbers, then it would not be necessary to have two equations.) - data Identity (d m n : ℕ) : Set where - +- : (x y : ℕ) (eq : d + y * n ≡ x * m) → Identity d m n - -+ : (x y : ℕ) (eq : d + x * m ≡ y * n) → Identity d m n + data Identity (d m n : ℕ) : Set where + +- : (x y : ℕ) (eq : d + y * n ≡ x * m) → Identity d m n + -+ : (x y : ℕ) (eq : d + x * m ≡ y * n) → Identity d m n - -- Various properties about Identity. + -- Various properties about Identity. - sym : ∀ {d} → Symmetric (Identity d) - sym (+- x y eq) = -+ y x eq - sym (-+ x y eq) = +- y x eq + sym : ∀ {d} → Symmetric (Identity d) + sym (+- x y eq) = -+ y x eq + sym (-+ x y eq) = +- y x eq - refl : ∀ {d} → Identity d d d - refl = -+ 0 1 P.refl + refl : ∀ {d} → Identity d d d + refl = -+ 0 1 P.refl - base : ∀ {d} → Identity d 0 d - base = -+ 0 1 P.refl + base : ∀ {d} → Identity d 0 d + base = -+ 0 1 P.refl - private - infixl 7 _⊕_ + private + infixl 7 _⊕_ - _⊕_ : ℕ → ℕ → ℕ - m ⊕ n = 1 + m + n + _⊕_ : ℕ → ℕ → ℕ + m ⊕ n = 1 + m + n - step : ∀ {d n k} → Identity d n k → Identity d n (n + k) - step {d} {n} (+- x y eq) with compare x y - ... | equal x = +- (2 * x) x (lem₂ d x eq) - ... | less x i = +- (2 * x ⊕ i) (x ⊕ i) (lem₃ d x eq) - ... | greater y i = +- (2 * y ⊕ i) y (lem₄ d y n eq) - step {d} {n} (-+ x y eq) with compare x y - ... | equal x = -+ (2 * x) x (lem₅ d x eq) - ... | less x i = -+ (2 * x ⊕ i) (x ⊕ i) (lem₆ d x eq) - ... | greater y i = -+ (2 * y ⊕ i) y (lem₇ d y n eq) + step : ∀ {d n k} → Identity d n k → Identity d n (n + k) + step {d} {n} (+- x y eq) with compare x y + ... | equal x = +- (2 * x) x (lem₂ d x eq) + ... | less x i = +- (2 * x ⊕ i) (x ⊕ i) (lem₃ d x eq) + ... | greater y i = +- (2 * y ⊕ i) y (lem₄ d y n eq) + step {d} {n} (-+ x y eq) with compare x y + ... | equal x = -+ (2 * x) x (lem₅ d x eq) + ... | less x i = -+ (2 * x ⊕ i) (x ⊕ i) (lem₆ d x eq) + ... | greater y i = -+ (2 * y ⊕ i) y (lem₇ d y n eq) - open Identity public using (Identity; +-; -+) hiding (module Identity) + open Identity public using (Identity; +-; -+) hiding (module Identity) - module Lemma where + module Lemma where - -- This type packs up the gcd, the proof that it is a gcd, and the - -- proof that it satisfies Bézout's identity. + -- This type packs up the gcd, the proof that it is a gcd, and the + -- proof that it satisfies Bézout's identity. - data Lemma (m n : ℕ) : Set where - result : (d : ℕ) (g : GCD m n d) (b : Identity d m n) → Lemma m n + data Lemma (m n : ℕ) : Set where + result : (d : ℕ) (g : GCD m n d) (b : Identity d m n) → Lemma m n - -- Various properties about Lemma. + -- Various properties about Lemma. - sym : Symmetric Lemma - sym (result d g b) = result d (GCD.sym g) (Identity.sym b) + sym : Symmetric Lemma + sym (result d g b) = result d (GCD.sym g) (Identity.sym b) - base : ∀ d → Lemma 0 d - base d = result d GCD.base Identity.base + base : ∀ d → Lemma 0 d + base d = result d GCD.base Identity.base - refl : ∀ d → Lemma d d - refl d = result d GCD.refl Identity.refl + refl : ∀ d → Lemma d d + refl d = result d GCD.refl Identity.refl - stepˡ : ∀ {n k} → Lemma n (suc k) → Lemma n (suc (n + k)) - stepˡ {n} {k} (result d g b) = - subst (Lemma n) (+-suc n k) $ - result d (GCD.step g) (Identity.step b) + stepˡ : ∀ {n k} → Lemma n (suc k) → Lemma n (suc (n + k)) + stepˡ {n} {k} (result d g b) = + subst (Lemma n) (+-suc n k) $ + result d (GCD.step g) (Identity.step b) - stepʳ : ∀ {n k} → Lemma (suc k) n → Lemma (suc (n + k)) n - stepʳ = sym ∘ stepˡ ∘ sym + stepʳ : ∀ {n k} → Lemma (suc k) n → Lemma (suc (n + k)) n + stepʳ = sym ∘ stepˡ ∘ sym - open Lemma public using (Lemma; result) hiding (module Lemma) + open Lemma public using (Lemma; result) hiding (module Lemma) - -- Bézout's lemma proved using some variant of the extended - -- Euclidean algorithm. + -- Bézout's lemma proved using some variant of the extended + -- Euclidean algorithm. - lemma : (m n : ℕ) → Lemma m n - lemma m n = build [ <′-recBuilder ⊗ <′-recBuilder ] P gcd″ (m , n) - where - P : ℕ × ℕ → Set - P (m , n) = Lemma m n + lemma : (m n : ℕ) → Lemma m n + lemma m n = build [ <′-recBuilder ⊗ <′-recBuilder ] P gcd″ (m , n) + where + P : ℕ × ℕ → Set + P (m , n) = Lemma m n - gcd″ : ∀ p → (<′-Rec ⊗ <′-Rec) P p → P p - gcd″ (zero , n) rec = Lemma.base n - gcd″ (suc m , zero) rec = Lemma.sym (Lemma.base (suc m)) - gcd″ (suc m , suc n) rec with compare m n - ... | equal m = Lemma.refl (suc m) - ... | less m k = Lemma.stepˡ $ proj₁ rec (suc k) (lem₁ k m) - -- "gcd (suc m) (suc k)" - ... | greater n k = Lemma.stepʳ $ proj₂ rec (suc k) (lem₁ k n) (suc n) - -- "gcd (suc k) (suc n)" + gcd″ : ∀ p → (<′-Rec ⊗ <′-Rec) P p → P p + gcd″ (zero , n) rec = Lemma.base n + gcd″ (m@(suc _) , zero) rec = Lemma.sym (Lemma.base m) + gcd″ (m′@(suc m) , n′@(suc n)) rec with compare m n + ... | equal m = Lemma.refl m′ + ... | less m k = Lemma.stepˡ $ proj₁ rec (lem₁ k m) + -- "gcd (suc m) (suc k)" + ... | greater n k = Lemma.stepʳ $ proj₂ rec (lem₁ k n) n′ + -- "gcd (suc k) (suc n)" - -- Bézout's identity can be recovered from the GCD. + -- Bézout's identity can be recovered from the GCD. - identity : ∀ {m n d} → GCD m n d → Identity d m n - identity {m} {n} g with lemma m n - ... | result d g′ b with GCD.unique g g′ - ... | P.refl = b + identity : ∀ {m n d} → GCD m n d → Identity d m n + identity {m} {n} g with result d g′ b ← lemma m n rewrite GCD.unique g g′ = b \ No newline at end of file diff --git a/Data.Nat.GeneralisedArithmetic.html b/Data.Nat.GeneralisedArithmetic.html new file mode 100644 index 00000000..0c27f016 --- /dev/null +++ b/Data.Nat.GeneralisedArithmetic.html @@ -0,0 +1,106 @@ + +Data.Nat.GeneralisedArithmetic
------------------------------------------------------------------------
+-- The Agda standard library
+--
+-- A generalisation of the arithmetic operations
+------------------------------------------------------------------------
+
+{-# OPTIONS --cubical-compatible --safe #-}
+
+module Data.Nat.GeneralisedArithmetic where
+
+open import Data.Nat.Base
+open import Data.Nat.Properties
+open import Function.Base using (_∘′_; _∘_; id)
+open import Level using (Level)
+open import Relation.Binary.PropositionalEquality
+open ≡-Reasoning
+
+private
+  variable
+    a : Level
+    A : Set a
+
+fold : A → (A → A) → ℕ → A
+fold z s zero    = z
+fold z s (suc n) = s (fold z s n)
+
+iterate : (A → A) → A → ℕ → A
+iterate f x zero    = x
+iterate f x (suc n) = iterate f (f x) n
+
+add : (0# : A) (1+ : A → A) → ℕ → A → A
+add 0# 1+ n z = fold z 1+ n
+
+mul : (0# : A) (1+ : A → A) → (+ : A → A → A) → (ℕ → A → A)
+mul 0# 1+ _+_ n x = fold 0# (λ s → x + s) n
+
+-- Properties
+
+fold-+ : ∀ (z : A) (s : A → A) m {n} →
+         fold z s (m + n) ≡ fold (fold z s n) s m
+fold-+ z s zero    = refl
+fold-+ z s (suc m) = cong s (fold-+ z s m)
+
+fold-k : ∀ (z : A) (s : A → A) {k} m →
+         fold k (s ∘′_) m z ≡ fold (k z) s m
+fold-k z s zero    = refl
+fold-k z s (suc m) = cong s (fold-k z s m)
+
+fold-* : ∀ (z : A) (s : A → A) m {n} →
+         fold z s (m * n) ≡ fold z (fold id (s ∘_) n) m
+fold-* z s zero        = refl
+fold-* z s (suc m) {n} = let +n = fold id (s ∘′_) n in begin
+  fold z s (n + m * n)        ≡⟨ fold-+ z s n ⟩
+  fold (fold z s (m * n)) s n ≡⟨ cong (λ z → fold z s n) (fold-* z s m) ⟩
+  fold (fold z +n m) s n      ≡⟨ sym (fold-k _ s n) ⟩
+  fold z +n (suc m)           ∎
+
+fold-pull : ∀ (z : A) (s : A → A) (g : A → A → A) (p : A)
+            (eqz : g z p ≡ p)
+            (eqs : ∀ l → s (g l p) ≡ g (s l) p) →
+            ∀ m → fold p s m ≡ g (fold z s m) p
+fold-pull z s _ _ eqz _ zero    = sym eqz
+fold-pull z s g p eqz eqs (suc m) = begin
+  s (fold p s m)       ≡⟨ cong s (fold-pull z s g p eqz eqs m) ⟩
+  s (g (fold z s m) p) ≡⟨ eqs (fold z s m) ⟩
+  g (s (fold z s m)) p ∎
+
+iterate-is-fold : ∀ (z : A) s m → fold z s m ≡ iterate s z m
+iterate-is-fold z s zero    = refl
+iterate-is-fold z s (suc m) = begin
+  fold z s (suc m)  ≡⟨ cong (fold z s) (+-comm 1 m) ⟩
+  fold z s (m + 1)  ≡⟨ fold-+ z s m ⟩
+  fold (s z) s m    ≡⟨ iterate-is-fold (s z) s m ⟩
+  iterate s (s z) m ∎
+
+id-is-fold : ∀ m → fold zero suc m ≡ m
+id-is-fold zero    = refl
+id-is-fold (suc m) = cong suc (id-is-fold m)
+
++-is-fold : ∀ m {n} → fold n suc m ≡ m + n
++-is-fold zero    = refl
++-is-fold (suc m) = cong suc (+-is-fold m)
+
+*-is-fold : ∀ m {n} → fold zero (n +_) m ≡ m * n
+*-is-fold zero        = refl
+*-is-fold (suc m) {n} = cong (n +_) (*-is-fold m)
+
+^-is-fold : ∀ {m} n → fold 1 (m *_) n ≡ m ^ n
+^-is-fold     zero    = refl
+^-is-fold {m} (suc n) = cong (m *_) (^-is-fold n)
+
+*+-is-fold : ∀ m n {p} → fold p (n +_) m ≡ m * n + p
+*+-is-fold m n {p} = begin
+  fold p (n +_) m     ≡⟨ fold-pull _ _ _+_ p refl
+                         (λ l → sym (+-assoc n l p)) m ⟩
+  fold 0 (n +_) m + p ≡⟨ cong (_+ p) (*-is-fold m) ⟩
+  m * n + p           ∎
+
+^*-is-fold : ∀ m n {p} → fold p (m *_) n ≡ m ^ n * p
+^*-is-fold m n {p} = begin
+  fold p (m *_) n     ≡⟨ fold-pull _ _ _*_ p (*-identityˡ p)
+                         (λ l → sym (*-assoc m l p)) n ⟩
+  fold 1 (m *_) n * p ≡⟨ cong (_* p) (^-is-fold n) ⟩
+  m ^ n * p           ∎
+
\ No newline at end of file diff --git a/Data.Nat.Induction.html b/Data.Nat.Induction.html index 9c4ecfb2..0fbce0cf 100644 --- a/Data.Nat.Induction.html +++ b/Data.Nat.Induction.html @@ -10,104 +10,103 @@ module Data.Nat.Induction where open import Data.Nat.Base -open import Data.Nat.Properties using (<⇒<′) -open import Data.Product -open import Data.Unit.Polymorphic.Base -open import Function.Base -open import Induction -open import Induction.WellFounded as WF -open import Level using (Level) - -private - variable - ℓ : Level - ------------------------------------------------------------------------- --- Re-export accessability - -open WF public using (Acc; acc) - ------------------------------------------------------------------------- --- Ordinary induction - -Rec : ∀ ℓ → RecStruct ℕ ℓ ℓ -Rec ℓ P zero = ⊤ -Rec ℓ P (suc n) = P n - -recBuilder : RecursorBuilder (Rec ℓ) -recBuilder P f zero = _ -recBuilder P f (suc n) = f n (recBuilder P f n) - -rec : Recursor (Rec ℓ) -rec = build recBuilder - ------------------------------------------------------------------------- --- Complete induction - -CRec : ∀ ℓ → RecStruct ℕ ℓ ℓ -CRec ℓ P zero = ⊤ -CRec ℓ P (suc n) = P n × CRec ℓ P n - -cRecBuilder : RecursorBuilder (CRec ℓ) -cRecBuilder P f zero = _ -cRecBuilder P f (suc n) = f n ih , ih - where ih = cRecBuilder P f n - -cRec : Recursor (CRec ℓ) -cRec = build cRecBuilder - ------------------------------------------------------------------------- --- Complete induction based on _<′_ - -<′-Rec : RecStruct ℕ ℓ ℓ -<′-Rec = WfRec _<′_ - --- mutual definition - -<′-wellFounded : WellFounded _<′_ -<′-wellFounded′ : ∀ n → <′-Rec (Acc _<′_) n - -<′-wellFounded n = acc (<′-wellFounded′ n) - -<′-wellFounded′ (suc n) n <′-base = <′-wellFounded n -<′-wellFounded′ (suc n) m (<′-step m<n) = <′-wellFounded′ n m m<n - -module _ {ℓ : Level} where - open WF.All <′-wellFounded ℓ public - renaming ( wfRecBuilder to <′-recBuilder - ; wfRec to <′-rec - ) - hiding (wfRec-builder) - ------------------------------------------------------------------------- --- Complete induction based on _<_ - -<-Rec : RecStruct ℕ ℓ ℓ -<-Rec = WfRec _<_ - -<-wellFounded : WellFounded _<_ -<-wellFounded = Subrelation.wellFounded <⇒<′ <′-wellFounded - --- A version of `<-wellFounded` that cheats by skipping building --- the first billion proofs. Use this when you require the function --- using the proof of well-foundedness to evaluate fast. --- --- IMPORTANT: You have to be a little bit careful when using this to always --- make the function be strict in some other argument than the accessibility --- proof, otherwise you will have neutral terms unfolding a billion times --- before getting stuck. -<-wellFounded-fast : WellFounded _<_ -<-wellFounded-fast = <-wellFounded-skip 1000000000 - where - <-wellFounded-skip : ∀ (k : ℕ) → WellFounded _<_ - <-wellFounded-skip zero n = <-wellFounded n - <-wellFounded-skip (suc k) zero = <-wellFounded 0 - <-wellFounded-skip (suc k) (suc n) = acc (λ m _ → <-wellFounded-skip k m) - -module _ {ℓ : Level} where - open WF.All <-wellFounded ℓ public - renaming ( wfRecBuilder to <-recBuilder - ; wfRec to <-rec - ) - hiding (wfRec-builder) +open import Data.Nat.Properties using (<⇒<′) +open import Data.Product.Base using (_×_; _,_) +open import Data.Unit.Polymorphic.Base +open import Induction +open import Induction.WellFounded as WF +open import Level using (Level) + +private + variable + ℓ : Level + +------------------------------------------------------------------------ +-- Re-export accessability + +open WF public using (Acc; acc) + +------------------------------------------------------------------------ +-- Ordinary induction + +Rec : ∀ ℓ → RecStruct ℕ ℓ ℓ +Rec ℓ P zero = ⊤ +Rec ℓ P (suc n) = P n + +recBuilder : RecursorBuilder (Rec ℓ) +recBuilder P f zero = _ +recBuilder P f (suc n) = f n (recBuilder P f n) + +rec : Recursor (Rec ℓ) +rec = build recBuilder + +------------------------------------------------------------------------ +-- Complete induction + +CRec : ∀ ℓ → RecStruct ℕ ℓ ℓ +CRec ℓ P zero = ⊤ +CRec ℓ P (suc n) = P n × CRec ℓ P n + +cRecBuilder : RecursorBuilder (CRec ℓ) +cRecBuilder P f zero = _ +cRecBuilder P f (suc n) = f n ih , ih + where ih = cRecBuilder P f n + +cRec : Recursor (CRec ℓ) +cRec = build cRecBuilder + +------------------------------------------------------------------------ +-- Complete induction based on _<′_ + +<′-Rec : RecStruct ℕ ℓ ℓ +<′-Rec = WfRec _<′_ + +-- mutual definition + +<′-wellFounded : WellFounded _<′_ +<′-wellFounded′ : ∀ n → <′-Rec (Acc _<′_) n + +<′-wellFounded n = acc (<′-wellFounded′ n) + +<′-wellFounded′ (suc n) <′-base = <′-wellFounded n +<′-wellFounded′ (suc n) (<′-step m<n) = <′-wellFounded′ n m<n + +module _ {ℓ : Level} where + open WF.All <′-wellFounded ℓ public + renaming ( wfRecBuilder to <′-recBuilder + ; wfRec to <′-rec + ) + hiding (wfRec-builder) + +------------------------------------------------------------------------ +-- Complete induction based on _<_ + +<-Rec : RecStruct ℕ ℓ ℓ +<-Rec = WfRec _<_ + +<-wellFounded : WellFounded _<_ +<-wellFounded = Subrelation.wellFounded <⇒<′ <′-wellFounded + +-- A version of `<-wellFounded` that cheats by skipping building +-- the first billion proofs. Use this when you require the function +-- using the proof of well-foundedness to evaluate fast. +-- +-- IMPORTANT: You have to be a little bit careful when using this to +-- always make the function be strict in some other argument than the +-- accessibility proof, otherwise you will have neutral terms unfolding +-- a billion times before getting stuck. +<-wellFounded-fast : WellFounded _<_ +<-wellFounded-fast = <-wellFounded-skip 1000000000 + where + <-wellFounded-skip : ∀ (k : ℕ) → WellFounded _<_ + <-wellFounded-skip zero n = <-wellFounded n + <-wellFounded-skip (suc k) zero = <-wellFounded 0 + <-wellFounded-skip (suc k) (suc n) = acc λ {m} _ → <-wellFounded-skip k m + +module _ {ℓ : Level} where + open WF.All <-wellFounded ℓ public + renaming ( wfRecBuilder to <-recBuilder + ; wfRec to <-rec + ) + hiding (wfRec-builder) \ No newline at end of file diff --git a/Data.Nat.Log2.html b/Data.Nat.Log2.html index 7623236b..1e1d6d14 100644 --- a/Data.Nat.Log2.html +++ b/Data.Nat.Log2.html @@ -13,48 +13,48 @@ open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl) ⌈log₂_⌉ : ℕ → ℕ -⌈log₂_⌉ = Logarithm.⌈log₂_⌉ +⌈log₂_⌉ = Logarithm.⌈log₂_⌉ -log₂-mono : ⌈log₂_⌉ Preserves _≤_ ⟶ _≤_ -log₂-mono = Logarithm.⌈log₂⌉-mono-≤ +log₂-mono : ⌈log₂_⌉ Preserves _≤_ ⟶ _≤_ +log₂-mono = Logarithm.⌈log₂⌉-mono-≤ -⌈log₂n⌉≤n : ∀ n → ⌈log₂ n ⌉ ≤ n +⌈log₂n⌉≤n : ∀ n → ⌈log₂ n ⌉ ≤ n ⌈log₂n⌉≤n n = - let open ≤-Reasoning in - begin + let open ≤-Reasoning in + begin ⌈log₂ n ⌉ - ≤⟨ Logarithm.⌈log₂⌉-mono-≤ (n≤2^n n) ⟩ - ⌈log₂ (2 ^ n) ⌉ - ≡⟨ Logarithm.⌈log₂2^n⌉≡n n ⟩ + ≤⟨ Logarithm.⌈log₂⌉-mono-≤ (n≤2^n n) ⟩ + ⌈log₂ (2 ^ n) ⌉ + ≡⟨ Logarithm.⌈log₂2^n⌉≡n n ⟩ n - ∎ + ∎ where - n≤2^n : (n : ℕ) → n ≤ 2 ^ n - n≤2^n zero = z≤n + n≤2^n : (n : ℕ) → n ≤ 2 ^ n + n≤2^n zero = z≤n n≤2^n (suc n) = - let open ≤-Reasoning in - begin + let open ≤-Reasoning in + begin 1 + n - ≤⟨ +-mono-≤ (^-monoʳ-≤ 2 (z≤n {n})) (n≤2^n n) ⟩ - 2 ^ n + 2 ^ n - ≡˘⟨ Eq.cong ((2 ^ n) +_) (+-identityʳ (2 ^ n)) ⟩ - 2 ^ n + (2 ^ n + 0) - ≡⟨⟩ - 2 * 2 ^ n - ∎ - -log₂-suc : ∀ n {k} → ⌈log₂ n ⌉ ≤ suc k → ⌈log₂ ⌈ n /2⌉ ⌉ ≤ k + ≤⟨ +-mono-≤ (^-monoʳ-≤ 2 (z≤n {n})) (n≤2^n n) ⟩ + 2 ^ n + 2 ^ n + ≡˘⟨ Eq.cong ((2 ^ n) +_) (+-identityʳ (2 ^ n)) ⟩ + 2 ^ n + (2 ^ n + 0) + ≡⟨⟩ + 2 * 2 ^ n + ∎ + +log₂-suc : ∀ n {k} → ⌈log₂ n ⌉ ≤ suc k → ⌈log₂ ⌈ n /2⌉ ⌉ ≤ k log₂-suc n {k} h = - let open ≤-Reasoning in - begin - ⌈log₂ ⌈ n /2⌉ ⌉ - ≡⟨ Logarithm.⌈log₂⌈n/2⌉⌉≡⌈log₂n⌉∸1 n ⟩ - pred ⌈log₂ n ⌉ - ≤⟨ ∸-monoˡ-≤ 1 h ⟩ + let open ≤-Reasoning in + begin + ⌈log₂ ⌈ n /2⌉ ⌉ + ≡⟨ Logarithm.⌈log₂⌈n/2⌉⌉≡⌈log₂n⌉∸1 n ⟩ + pred ⌈log₂ n ⌉ + ≤⟨ ∸-monoˡ-≤ 1 h ⟩ k - ∎ + ∎ -⌈log₂n⌉≡0⇒n≤1 : {n : ℕ} → ⌈log₂ n ⌉ ≡ 0 → n ≤ 1 -⌈log₂n⌉≡0⇒n≤1 {zero} refl = z≤n -⌈log₂n⌉≡0⇒n≤1 {suc zero} refl = s≤s z≤n +⌈log₂n⌉≡0⇒n≤1 : {n : ℕ} → ⌈log₂ n ⌉ ≡ 0 → n ≤ 1 +⌈log₂n⌉≡0⇒n≤1 {zero} refl = z≤n +⌈log₂n⌉≡0⇒n≤1 {suc zero} refl = s≤s z≤n \ No newline at end of file diff --git a/Data.Nat.Logarithm.Core.html b/Data.Nat.Logarithm.Core.html index bcd212b1..7b89795e 100644 --- a/Data.Nat.Logarithm.Core.html +++ b/Data.Nat.Logarithm.Core.html @@ -1,124 +1,124 @@ -Data.Nat.Logarithm.Core
-----------------------------------------------------------------------
--- The Agda standard library
---
--- Logarithm base 2 core definitions and properties
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-module Data.Nat.Logarithm.Core where
-
-open import Data.Nat.Base
-open import Data.Nat.Properties
-open import Data.Nat.Induction using (<-wellFounded)
-open import Induction.WellFounded using (Acc; acc)
-open import Relation.Binary.PropositionalEquality
-open import Data.Unit
-
-------------------------------------------------------------------------
--- Logarithm base 2
-
--- Floor version
-
-⌊log2⌋ : ∀ n → Acc _<_ n → ℕ
-⌊log2⌋ 0          _        = 0
-⌊log2⌋ 1          _        = 0
-⌊log2⌋ (suc n′@(suc n)) (acc rs) = 1 + ⌊log2⌋ (suc ⌊ n /2⌋) (rs _ (⌊n/2⌋<n n′))
-
-
--- Ceil version
-
-⌈log2⌉ : ∀ n → Acc _<_ n → ℕ
-⌈log2⌉ 0                _        = 0
-⌈log2⌉ 1                _        = 0
-⌈log2⌉ (suc (suc n)) (acc rs) = 1 + ⌈log2⌉ (suc ⌈ n /2⌉) (rs _ (⌈n/2⌉<n n))
-
-------------------------------------------------------------------------
--- Properties of ⌊log2⌋
-
-⌊log2⌋-acc-irrelevant : ∀ a {acc acc'} → ⌊log2⌋ a acc ≡ ⌊log2⌋ a acc'
-⌊log2⌋-acc-irrelevant 0            {_}      {_}       = refl
-⌊log2⌋-acc-irrelevant 1            {_}      {_}       = refl
-⌊log2⌋-acc-irrelevant (suc (suc n)) {acc rs} {acc rs'} =
-  cong suc (⌊log2⌋-acc-irrelevant (suc ⌊ n /2⌋))
-
-⌊log2⌋-cong-irr : ∀ {a b} {acc acc'} → (p : a ≡ b) →
-                ⌊log2⌋ a acc ≡ ⌊log2⌋ b acc'
-⌊log2⌋-cong-irr {acc = ac} refl = ⌊log2⌋-acc-irrelevant _ {ac}
-
-⌊log2⌋-mono-≤ : ∀ {a b} {acc acc'} → a ≤ b → ⌊log2⌋ a acc ≤ ⌊log2⌋ b acc'
-⌊log2⌋-mono-≤ {_}           {_}     z≤n       = z≤n
-⌊log2⌋-mono-≤ {_}           {_}     (s≤s z≤n) = z≤n
-⌊log2⌋-mono-≤ {acc = acc _} {acc _} (s≤s (s≤s p)) =
-  s≤s (⌊log2⌋-mono-≤ (⌊n/2⌋-mono (+-monoʳ-≤ 2 p)))
-
-⌊log2⌋⌊n/2⌋≡⌊log2⌋n∸1 : ∀ n {acc} {acc'} →
-                        ⌊log2⌋ ⌊ n /2⌋ acc ≡ ⌊log2⌋ n acc' ∸ 1
-⌊log2⌋⌊n/2⌋≡⌊log2⌋n∸1 0             {_}      {_}       = refl
-⌊log2⌋⌊n/2⌋≡⌊log2⌋n∸1 1             {_}      {_}       = refl
-⌊log2⌋⌊n/2⌋≡⌊log2⌋n∸1 (suc (suc n)) {acc rs} {acc rs'} =
-  ⌊log2⌋-acc-irrelevant (suc ⌊ n /2⌋)
-
-⌊log2⌋2*b≡1+⌊log2⌋b : ∀ n {acc acc'} .{{ _ : NonZero n}} →
-                      ⌊log2⌋ (2 * n) acc ≡ 1 + ⌊log2⌋ n acc'
-⌊log2⌋2*b≡1+⌊log2⌋b (suc n) = begin
-  ⌊log2⌋ (suc (n + suc (n + zero))) _              ≡⟨ ⌊log2⌋-cong-irr (cong (λ x → suc (n + suc x)) (+-comm n zero)) ⟩
-  ⌊log2⌋ (suc (n + suc n)) (<-wellFounded _)       ≡⟨ ⌊log2⌋-cong-irr {acc' = <-wellFounded _} (cong suc (+-comm n (suc n))) ⟩
-  ⌊log2⌋ (suc (suc n + n)) (<-wellFounded _)       ≡⟨ cong suc (⌊log2⌋-cong-irr {a = suc ⌊ n + n /2⌋} refl) ⟩
-  suc (⌊log2⌋ (suc ⌊ n + n /2⌋) (<-wellFounded _)) ≡⟨ cong suc (⌊log2⌋-cong-irr (cong suc (sym (n≡⌊n+n/2⌋ n)))) ⟩
-  suc (⌊log2⌋ (suc n) _)                           ∎
-  where open ≡-Reasoning
-
-⌊log2⌋2^n≡n : ∀ n {acc} → ⌊log2⌋ (2 ^ n) acc ≡ n
-⌊log2⌋2^n≡n zero    = refl
-⌊log2⌋2^n≡n (suc n) = begin
-  ⌊log2⌋ ((2 ^ n) + ((2 ^ n) + zero)) _ ≡⟨ ⌊log2⌋2*b≡1+⌊log2⌋b (2 ^ n) {{m^n≢0 2 n}} ⟩
-  1 + ⌊log2⌋ (2 ^ n) (<-wellFounded _)  ≡⟨ cong suc (⌊log2⌋2^n≡n n) ⟩
-  suc n                                 ∎
-  where open ≡-Reasoning
-
-------------------------------------------------------------------------
--- Properties of ⌈log2⌉
-
-⌈log2⌉-acc-irrelevant : ∀ n {acc acc'} → ⌈log2⌉ n acc ≡ ⌈log2⌉ n acc'
-⌈log2⌉-acc-irrelevant zero          {acc rs} {acc rs₁} = refl
-⌈log2⌉-acc-irrelevant (suc zero)    {acc rs} {acc rs₁} = refl
-⌈log2⌉-acc-irrelevant (suc (suc n)) {acc rs} {acc rs'} =
-  cong suc (⌈log2⌉-acc-irrelevant (suc ⌊ suc n /2⌋))
-
-⌈log2⌉-cong-irr : ∀ {m n} {acc acc'} → (_ : m ≡ n) →
-                  ⌈log2⌉ m acc ≡ ⌈log2⌉ n acc'
-⌈log2⌉-cong-irr {acc = ac} refl = ⌈log2⌉-acc-irrelevant _ {ac}
-
-⌈log2⌉-mono-≤ : ∀ {m n} {acc acc'} → m ≤ n → ⌈log2⌉ m acc ≤ ⌈log2⌉ n acc'
-⌈log2⌉-mono-≤ {_}            {_}       z≤n           = z≤n
-⌈log2⌉-mono-≤ {_}            {_}       (s≤s z≤n)     = z≤n
-⌈log2⌉-mono-≤ {acc = acc rs} {acc rs'} (s≤s (s≤s p)) =
-  s≤s (⌈log2⌉-mono-≤ (⌈n/2⌉-mono (+-monoʳ-≤ 2 p)))
-
-⌈log2⌉⌈n/2⌉≡⌈log2⌉n∸1 : ∀ n {acc} {acc'} →
-                        ⌈log2⌉ ⌈ n /2⌉ acc ≡ ⌈log2⌉ n acc' ∸ 1
-⌈log2⌉⌈n/2⌉≡⌈log2⌉n∸1 zero          {_}      {_}       = refl
-⌈log2⌉⌈n/2⌉≡⌈log2⌉n∸1 (suc zero)    {_}      {_}       = refl
-⌈log2⌉⌈n/2⌉≡⌈log2⌉n∸1 (suc (suc n)) {acc rs} {acc rs'} =
-  ⌈log2⌉-acc-irrelevant (suc ⌊ suc n /2⌋)
-
-⌈log2⌉2*n≡1+⌈log2⌉n : ∀ n {acc acc'} .{{_ : NonZero n}} →
-                      ⌈log2⌉ (2 * n) acc ≡ 1 + ⌈log2⌉ n acc'
-⌈log2⌉2*n≡1+⌈log2⌉n (suc n) = begin
-  ⌈log2⌉ (suc (n + suc (n + zero))) _              ≡⟨ ⌈log2⌉-cong-irr (cong (λ x → suc (n + suc x)) (+-comm n zero)) ⟩
-  ⌈log2⌉ (suc (n + suc n)) (<-wellFounded _)       ≡⟨ ⌈log2⌉-cong-irr {acc' = <-wellFounded _} (cong suc (+-comm n (suc n))) ⟩
-  ⌈log2⌉ (suc (suc n + n)) (<-wellFounded _)       ≡⟨ cong suc (⌈log2⌉-cong-irr {m = suc ⌈ n + n /2⌉} refl) ⟩
-  suc (⌈log2⌉ (suc ⌈ n + n /2⌉) (<-wellFounded _)) ≡⟨ cong suc (⌈log2⌉-cong-irr (cong suc (sym (n≡⌈n+n/2⌉ n)))) ⟩
-  suc (⌈log2⌉ (suc n) _)                           ∎
-  where open ≡-Reasoning
-
-⌈log2⌉2^n≡n : ∀ n {acc} → ⌈log2⌉ (2 ^ n) acc ≡ n
-⌈log2⌉2^n≡n zero    = refl
-⌈log2⌉2^n≡n (suc n) = begin
-  ⌈log2⌉ ((2 ^ n) + ((2 ^ n) + zero)) _ ≡⟨ ⌈log2⌉2*n≡1+⌈log2⌉n (2 ^ n) {{m^n≢0 2 n}} ⟩
-  1 + ⌈log2⌉ (2 ^ n) (<-wellFounded _)  ≡⟨ cong suc (⌈log2⌉2^n≡n n) ⟩
-  suc n                                 ∎
-  where open ≡-Reasoning
+Data.Nat.Logarithm.Core
------------------------------------------------------------------------
+-- The Agda standard library
+--
+-- Logarithm base 2 core definitions and properties
+------------------------------------------------------------------------
+
+{-# OPTIONS --cubical-compatible --safe #-}
+
+module Data.Nat.Logarithm.Core where
+
+open import Data.Nat.Base
+open import Data.Nat.Properties
+open import Data.Nat.Induction using (<-wellFounded)
+open import Induction.WellFounded using (Acc; acc)
+open import Relation.Binary.PropositionalEquality
+open import Data.Unit
+
+------------------------------------------------------------------------
+-- Logarithm base 2
+
+-- Floor version
+
+⌊log2⌋ : ∀ n → Acc _<_ n → ℕ
+⌊log2⌋ 0          _        = 0
+⌊log2⌋ 1          _        = 0
+⌊log2⌋ (suc n′@(suc n)) (acc rs) = 1 + ⌊log2⌋ (suc ⌊ n /2⌋) (rs (⌊n/2⌋<n n′))
+
+
+-- Ceil version
+
+⌈log2⌉ : ∀ n → Acc _<_ n → ℕ
+⌈log2⌉ 0                _        = 0
+⌈log2⌉ 1                _        = 0
+⌈log2⌉ (suc (suc n)) (acc rs) = 1 + ⌈log2⌉ (suc ⌈ n /2⌉) (rs (⌈n/2⌉<n n))
+
+------------------------------------------------------------------------
+-- Properties of ⌊log2⌋
+
+⌊log2⌋-acc-irrelevant : ∀ a {acc acc'} → ⌊log2⌋ a acc ≡ ⌊log2⌋ a acc'
+⌊log2⌋-acc-irrelevant 0            {_}      {_}       = refl
+⌊log2⌋-acc-irrelevant 1            {_}      {_}       = refl
+⌊log2⌋-acc-irrelevant (suc (suc n)) {acc rs} {acc rs'} =
+  cong suc (⌊log2⌋-acc-irrelevant (suc ⌊ n /2⌋))
+
+⌊log2⌋-cong-irr : ∀ {a b} {acc acc'} → (p : a ≡ b) →
+                ⌊log2⌋ a acc ≡ ⌊log2⌋ b acc'
+⌊log2⌋-cong-irr {acc = ac} refl = ⌊log2⌋-acc-irrelevant _ {ac}
+
+⌊log2⌋-mono-≤ : ∀ {a b} {acc acc'} → a ≤ b → ⌊log2⌋ a acc ≤ ⌊log2⌋ b acc'
+⌊log2⌋-mono-≤ {_}           {_}     z≤n       = z≤n
+⌊log2⌋-mono-≤ {_}           {_}     (s≤s z≤n) = z≤n
+⌊log2⌋-mono-≤ {acc = acc _} {acc _} (s≤s (s≤s p)) =
+  s≤s (⌊log2⌋-mono-≤ (⌊n/2⌋-mono (+-monoʳ-≤ 2 p)))
+
+⌊log2⌋⌊n/2⌋≡⌊log2⌋n∸1 : ∀ n {acc} {acc'} →
+                        ⌊log2⌋ ⌊ n /2⌋ acc ≡ ⌊log2⌋ n acc' ∸ 1
+⌊log2⌋⌊n/2⌋≡⌊log2⌋n∸1 0             {_}      {_}       = refl
+⌊log2⌋⌊n/2⌋≡⌊log2⌋n∸1 1             {_}      {_}       = refl
+⌊log2⌋⌊n/2⌋≡⌊log2⌋n∸1 (suc (suc n)) {acc rs} {acc rs'} =
+  ⌊log2⌋-acc-irrelevant (suc ⌊ n /2⌋)
+
+⌊log2⌋2*b≡1+⌊log2⌋b : ∀ n {acc acc'} .{{ _ : NonZero n}} →
+                      ⌊log2⌋ (2 * n) acc ≡ 1 + ⌊log2⌋ n acc'
+⌊log2⌋2*b≡1+⌊log2⌋b (suc n) = begin
+  ⌊log2⌋ (suc (n + suc (n + zero))) _              ≡⟨ ⌊log2⌋-cong-irr (cong (λ x → suc (n + suc x)) (+-comm n zero)) ⟩
+  ⌊log2⌋ (suc (n + suc n)) (<-wellFounded _)       ≡⟨ ⌊log2⌋-cong-irr {acc' = <-wellFounded _} (cong suc (+-comm n (suc n))) ⟩
+  ⌊log2⌋ (suc (suc n + n)) (<-wellFounded _)       ≡⟨ cong suc (⌊log2⌋-cong-irr {a = suc ⌊ n + n /2⌋} refl) ⟩
+  suc (⌊log2⌋ (suc ⌊ n + n /2⌋) (<-wellFounded _)) ≡⟨ cong suc (⌊log2⌋-cong-irr (cong suc (sym (n≡⌊n+n/2⌋ n)))) ⟩
+  suc (⌊log2⌋ (suc n) _)                           ∎
+  where open ≡-Reasoning
+
+⌊log2⌋2^n≡n : ∀ n {acc} → ⌊log2⌋ (2 ^ n) acc ≡ n
+⌊log2⌋2^n≡n zero    = refl
+⌊log2⌋2^n≡n (suc n) = begin
+  ⌊log2⌋ ((2 ^ n) + ((2 ^ n) + zero)) _ ≡⟨ ⌊log2⌋2*b≡1+⌊log2⌋b (2 ^ n) {{m^n≢0 2 n}} ⟩
+  1 + ⌊log2⌋ (2 ^ n) (<-wellFounded _)  ≡⟨ cong suc (⌊log2⌋2^n≡n n) ⟩
+  suc n                                 ∎
+  where open ≡-Reasoning
+
+------------------------------------------------------------------------
+-- Properties of ⌈log2⌉
+
+⌈log2⌉-acc-irrelevant : ∀ n {acc acc'} → ⌈log2⌉ n acc ≡ ⌈log2⌉ n acc'
+⌈log2⌉-acc-irrelevant zero          {acc rs} {acc rs₁} = refl
+⌈log2⌉-acc-irrelevant (suc zero)    {acc rs} {acc rs₁} = refl
+⌈log2⌉-acc-irrelevant (suc (suc n)) {acc rs} {acc rs'} =
+  cong suc (⌈log2⌉-acc-irrelevant (suc ⌊ suc n /2⌋))
+
+⌈log2⌉-cong-irr : ∀ {m n} {acc acc'} → (_ : m ≡ n) →
+                  ⌈log2⌉ m acc ≡ ⌈log2⌉ n acc'
+⌈log2⌉-cong-irr {acc = ac} refl = ⌈log2⌉-acc-irrelevant _ {ac}
+
+⌈log2⌉-mono-≤ : ∀ {m n} {acc acc'} → m ≤ n → ⌈log2⌉ m acc ≤ ⌈log2⌉ n acc'
+⌈log2⌉-mono-≤ {_}            {_}       z≤n           = z≤n
+⌈log2⌉-mono-≤ {_}            {_}       (s≤s z≤n)     = z≤n
+⌈log2⌉-mono-≤ {acc = acc rs} {acc rs'} (s≤s (s≤s p)) =
+  s≤s (⌈log2⌉-mono-≤ (⌈n/2⌉-mono (+-monoʳ-≤ 2 p)))
+
+⌈log2⌉⌈n/2⌉≡⌈log2⌉n∸1 : ∀ n {acc} {acc'} →
+                        ⌈log2⌉ ⌈ n /2⌉ acc ≡ ⌈log2⌉ n acc' ∸ 1
+⌈log2⌉⌈n/2⌉≡⌈log2⌉n∸1 zero          {_}      {_}       = refl
+⌈log2⌉⌈n/2⌉≡⌈log2⌉n∸1 (suc zero)    {_}      {_}       = refl
+⌈log2⌉⌈n/2⌉≡⌈log2⌉n∸1 (suc (suc n)) {acc rs} {acc rs'} =
+  ⌈log2⌉-acc-irrelevant (suc ⌊ suc n /2⌋)
+
+⌈log2⌉2*n≡1+⌈log2⌉n : ∀ n {acc acc'} .{{_ : NonZero n}} →
+                      ⌈log2⌉ (2 * n) acc ≡ 1 + ⌈log2⌉ n acc'
+⌈log2⌉2*n≡1+⌈log2⌉n (suc n) = begin
+  ⌈log2⌉ (suc (n + suc (n + zero))) _              ≡⟨ ⌈log2⌉-cong-irr (cong (λ x → suc (n + suc x)) (+-comm n zero)) ⟩
+  ⌈log2⌉ (suc (n + suc n)) (<-wellFounded _)       ≡⟨ ⌈log2⌉-cong-irr {acc' = <-wellFounded _} (cong suc (+-comm n (suc n))) ⟩
+  ⌈log2⌉ (suc (suc n + n)) (<-wellFounded _)       ≡⟨ cong suc (⌈log2⌉-cong-irr {m = suc ⌈ n + n /2⌉} refl) ⟩
+  suc (⌈log2⌉ (suc ⌈ n + n /2⌉) (<-wellFounded _)) ≡⟨ cong suc (⌈log2⌉-cong-irr (cong suc (sym (n≡⌈n+n/2⌉ n)))) ⟩
+  suc (⌈log2⌉ (suc n) _)                           ∎
+  where open ≡-Reasoning
+
+⌈log2⌉2^n≡n : ∀ n {acc} → ⌈log2⌉ (2 ^ n) acc ≡ n
+⌈log2⌉2^n≡n zero    = refl
+⌈log2⌉2^n≡n (suc n) = begin
+  ⌈log2⌉ ((2 ^ n) + ((2 ^ n) + zero)) _ ≡⟨ ⌈log2⌉2*n≡1+⌈log2⌉n (2 ^ n) {{m^n≢0 2 n}} ⟩
+  1 + ⌈log2⌉ (2 ^ n) (<-wellFounded _)  ≡⟨ cong suc (⌈log2⌉2^n≡n n) ⟩
+  suc n                                 ∎
+  where open ≡-Reasoning
 

\ No newline at end of file
diff --git a/Data.Nat.Logarithm.html b/Data.Nat.Logarithm.html
index 0dc60d3d..aadefa19 100644
--- a/Data.Nat.Logarithm.html
+++ b/Data.Nat.Logarithm.html
@@ -1,59 +1,59 @@
 
-Data.Nat.Logarithm
-----------------------------------------------------------------------
--- The Agda standard library
---
--- Logarithm base 2 and respective properties
-------------------------------------------------------------------------
+Data.Nat.Logarithm
------------------------------------------------------------------------
+-- The Agda standard library
+--
+-- Logarithm base 2 and respective properties
+------------------------------------------------------------------------
 
-{-# OPTIONS --cubical-compatible --safe #-}
+{-# OPTIONS --cubical-compatible --safe #-}
 
-module Data.Nat.Logarithm where
+module Data.Nat.Logarithm where
 
-open import Data.Nat
-open import Data.Nat.Induction using (<-wellFounded)
-open import Data.Nat.Logarithm.Core
-open import Relation.Binary.PropositionalEquality using (_≡_)
+open import Data.Nat
+open import Data.Nat.Induction using (<-wellFounded)
+open import Data.Nat.Logarithm.Core
+open import Relation.Binary.PropositionalEquality.Core using (_≡_)
 
-------------------------------------------------------------------------
--- Logarithm base 2
+------------------------------------------------------------------------
+-- Logarithm base 2
 
--- Floor version
+-- Floor version
 
-⌊log₂_⌋ : ℕ → ℕ
-⌊log₂ n ⌋ = ⌊log2⌋ n (<-wellFounded n)
+⌊log₂_⌋ : ℕ → ℕ
+⌊log₂ n ⌋ = ⌊log2⌋ n (<-wellFounded n)
 
--- Ceil version
+-- Ceil version
 
-⌈log₂_⌉ : ℕ → ℕ
-⌈log₂ n ⌉ = ⌈log2⌉ n (<-wellFounded n)
+⌈log₂_⌉ : ℕ → ℕ
+⌈log₂ n ⌉ = ⌈log2⌉ n (<-wellFounded n)
 
-------------------------------------------------------------------------
--- Properties of ⌊log₂_⌋
+------------------------------------------------------------------------
+-- Properties of ⌊log₂_⌋
 
-⌊log₂⌋-mono-≤ : ∀ {m n} → m ≤ n → ⌊log₂ m ⌋ ≤ ⌊log₂ n ⌋
-⌊log₂⌋-mono-≤ p = ⌊log2⌋-mono-≤ p
+⌊log₂⌋-mono-≤ : ∀ {m n} → m ≤ n → ⌊log₂ m ⌋ ≤ ⌊log₂ n ⌋
+⌊log₂⌋-mono-≤ p = ⌊log2⌋-mono-≤ p
 
-⌊log₂⌊n/2⌋⌋≡⌊log₂n⌋∸1 : ∀ n → ⌊log₂ ⌊ n /2⌋ ⌋ ≡ ⌊log₂ n ⌋ ∸ 1
-⌊log₂⌊n/2⌋⌋≡⌊log₂n⌋∸1 n = ⌊log2⌋⌊n/2⌋≡⌊log2⌋n∸1 n
+⌊log₂⌊n/2⌋⌋≡⌊log₂n⌋∸1 : ∀ n → ⌊log₂ ⌊ n /2⌋ ⌋ ≡ ⌊log₂ n ⌋ ∸ 1
+⌊log₂⌊n/2⌋⌋≡⌊log₂n⌋∸1 n = ⌊log2⌋⌊n/2⌋≡⌊log2⌋n∸1 n
 
-⌊log₂[2*b]⌋≡1+⌊log₂b⌋ : ∀ n .{{_ : NonZero n}} → ⌊log₂ (2 * n) ⌋ ≡ 1 + ⌊log₂ n ⌋
-⌊log₂[2*b]⌋≡1+⌊log₂b⌋ n = ⌊log2⌋2*b≡1+⌊log2⌋b n
+⌊log₂[2*b]⌋≡1+⌊log₂b⌋ : ∀ n .{{_ : NonZero n}} → ⌊log₂ (2 * n) ⌋ ≡ 1 + ⌊log₂ n ⌋
+⌊log₂[2*b]⌋≡1+⌊log₂b⌋ n = ⌊log2⌋2*b≡1+⌊log2⌋b n
 
-⌊log₂[2^n]⌋≡n : ∀ n → ⌊log₂ (2 ^ n) ⌋ ≡ n
-⌊log₂[2^n]⌋≡n n = ⌊log2⌋2^n≡n n
+⌊log₂[2^n]⌋≡n : ∀ n → ⌊log₂ (2 ^ n) ⌋ ≡ n
+⌊log₂[2^n]⌋≡n n = ⌊log2⌋2^n≡n n
 
-------------------------------------------------------------------------
--- Properties of ⌈log₂_⌉
+------------------------------------------------------------------------
+-- Properties of ⌈log₂_⌉
 
-⌈log₂⌉-mono-≤ : ∀ {m n} → m ≤ n → ⌈log₂ m ⌉ ≤ ⌈log₂ n ⌉
-⌈log₂⌉-mono-≤ p = ⌈log2⌉-mono-≤ p
+⌈log₂⌉-mono-≤ : ∀ {m n} → m ≤ n → ⌈log₂ m ⌉ ≤ ⌈log₂ n ⌉
+⌈log₂⌉-mono-≤ p = ⌈log2⌉-mono-≤ p
 
-⌈log₂⌈n/2⌉⌉≡⌈log₂n⌉∸1 : ∀ n → ⌈log₂ ⌈ n /2⌉ ⌉ ≡ ⌈log₂ n ⌉ ∸ 1
-⌈log₂⌈n/2⌉⌉≡⌈log₂n⌉∸1 n = ⌈log2⌉⌈n/2⌉≡⌈log2⌉n∸1 n
+⌈log₂⌈n/2⌉⌉≡⌈log₂n⌉∸1 : ∀ n → ⌈log₂ ⌈ n /2⌉ ⌉ ≡ ⌈log₂ n ⌉ ∸ 1
+⌈log₂⌈n/2⌉⌉≡⌈log₂n⌉∸1 n = ⌈log2⌉⌈n/2⌉≡⌈log2⌉n∸1 n
 
-⌈log₂2*n⌉≡1+⌈log₂n⌉ : ∀ n .{{_ : NonZero n}} → ⌈log₂ (2 * n) ⌉ ≡ 1 + ⌈log₂ n ⌉
-⌈log₂2*n⌉≡1+⌈log₂n⌉ n = ⌈log2⌉2*n≡1+⌈log2⌉n n
+⌈log₂2*n⌉≡1+⌈log₂n⌉ : ∀ n .{{_ : NonZero n}} → ⌈log₂ (2 * n) ⌉ ≡ 1 + ⌈log₂ n ⌉
+⌈log₂2*n⌉≡1+⌈log₂n⌉ n = ⌈log2⌉2*n≡1+⌈log2⌉n n
 
-⌈log₂2^n⌉≡n : ∀ n → ⌈log₂ (2 ^ n) ⌉ ≡ n
-⌈log₂2^n⌉≡n n = ⌈log2⌉2^n≡n n
+⌈log₂2^n⌉≡n : ∀ n → ⌈log₂ (2 ^ n) ⌉ ≡ n
+⌈log₂2^n⌉≡n n = ⌈log2⌉2^n≡n n
 

\ No newline at end of file
diff --git a/Data.Nat.PredExp2.html b/Data.Nat.PredExp2.html
index fa014d56..3856478d 100644
--- a/Data.Nat.PredExp2.html
+++ b/Data.Nat.PredExp2.html
@@ -9,102 +9,102 @@
 open import Relation.Nullary
 open import Relation.Nullary.Negation
 open import Relation.Binary
-open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; _≢_; module ≡-Reasoning)
+open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; _≢_; module ≡-Reasoning)
 
 open import Data.Nat.Log2 using (⌈log₂_⌉)
 
 pred[2^_] : ℕ → ℕ
-pred[2^ n ] = pred (2 ^ n)
+pred[2^ n ] = pred (2 ^ n)
 
-lemma/2^suc : ∀ n → 2 ^ n + 2 ^ n ≡ 2 ^ suc n
+lemma/2^suc : ∀ n → 2 ^ n + 2 ^ n ≡ 2 ^ suc n
 lemma/2^suc n =
-  begin
-    2 ^ n + 2 ^ n
-  ≡˘⟨ Eq.cong ((2 ^ n) +_) (*-identityˡ (2 ^ n)) ⟩
-    2 ^ n + (2 ^ n + 0)
-  ≡⟨⟩
-    2 ^ n + (2 ^ n + 0 * (2 ^ n))
-  ≡⟨⟩
-    2 * (2 ^ n)
-  ≡⟨⟩
-    2 ^ suc n
-  ∎
-    where open ≡-Reasoning
+  begin
+    2 ^ n + 2 ^ n
+  ≡˘⟨ Eq.cong ((2 ^ n) +_) (*-identityˡ (2 ^ n)) ⟩
+    2 ^ n + (2 ^ n + 0)
+  ≡⟨⟩
+    2 ^ n + (2 ^ n + 0 * (2 ^ n))
+  ≡⟨⟩
+    2 * (2 ^ n)
+  ≡⟨⟩
+    2 ^ suc n
+  ∎
+    where open ≡-Reasoning
 
 private
-  lemma/1≤2^n : ∀ n → 1 ≤ 2 ^ n
-  lemma/1≤2^n zero    = ≤-refl {1}
+  lemma/1≤2^n : ∀ n → 1 ≤ 2 ^ n
+  lemma/1≤2^n zero    = ≤-refl {1}
   lemma/1≤2^n (suc n) =
-    begin
+    begin
       1
-    ≤⟨ s≤s z≤n ⟩
+    ≤⟨ s≤s z≤n ⟩
       1 + 1
-    ≤⟨ +-mono-≤ (lemma/1≤2^n n) (lemma/1≤2^n n) ⟩
-      2 ^ n + 2 ^ n
-    ≡⟨ lemma/2^suc n ⟩
-      2 ^ suc n
-    ∎
-      where open ≤-Reasoning
+    ≤⟨ +-mono-≤ (lemma/1≤2^n n) (lemma/1≤2^n n) ⟩
+      2 ^ n + 2 ^ n
+    ≡⟨ lemma/2^suc n ⟩
+      2 ^ suc n
+    ∎
+      where open ≤-Reasoning
 
-  lemma/2^n≢0 : ∀ n → 2 ^ n ≢ zero
-  lemma/2^n≢0 n 2^n≡0 with 2 ^ n | lemma/1≤2^n n
+  lemma/2^n≢0 : ∀ n → 2 ^ n ≢ zero
+  lemma/2^n≢0 n 2^n≡0 with 2 ^ n | lemma/1≤2^n n
   ... | zero | ()
 
-pred[2^]-mono : pred[2^_] Preserves _≤_ ⟶ _≤_
-pred[2^]-mono m≤n = pred-mono (2^-mono m≤n)
-  where
-    2^-mono : (2 ^_) Preserves _≤_ ⟶ _≤_
-    2^-mono {y = y} z≤n = lemma/1≤2^n y
-    2^-mono (s≤s m≤n) = *-monoʳ-≤ 2 (2^-mono m≤n)
+pred[2^]-mono : pred[2^_] Preserves _≤_ ⟶ _≤_
+pred[2^]-mono m≤n = pred-mono-≤ (2^-mono m≤n)
+  where
+    2^-mono : (2 ^_) Preserves _≤_ ⟶ _≤_
+    2^-mono {y = y} z≤n = lemma/1≤2^n y
+    2^-mono (s≤s m≤n) = *-monoʳ-≤ 2 (2^-mono m≤n)
 
-pred[2^suc[n]] : (n : ℕ) → suc (pred[2^ n ] + pred[2^ n ]) ≡ pred[2^ suc n ]
-pred[2^suc[n]] n =
-  begin
-    suc (pred[2^ n ] + pred[2^ n ])
-  ≡⟨⟩
-    suc (pred (2 ^ n) + pred (2 ^ n))
-  ≡˘⟨ +-suc (pred (2 ^ n)) (pred (2 ^ n)) ⟩
-    pred (2 ^ n) + suc (pred (2 ^ n))
-  ≡⟨ Eq.cong (pred (2 ^ n) +_) (suc-pred (2 ^ n) {{m^n≢0 2 n}}) ⟩
-    pred (2 ^ n) + 2 ^ n
-  ≡˘⟨ +-∸-comm (2 ^ n) (m^n>0 2 n) ⟩
-    pred (2 ^ n + 2 ^ n)
-  ≡⟨ Eq.cong pred (lemma/2^suc n) ⟩
-    pred (2 ^ suc n)
-  ≡⟨⟩
-    pred[2^ suc n ]
-  ∎
-    where
-      open ≡-Reasoning
+pred[2^suc[n]] : (n : ℕ) → suc (pred[2^ n ] + pred[2^ n ]) ≡ pred[2^ suc n ]
+pred[2^suc[n]] n =
+  begin
+    suc (pred[2^ n ] + pred[2^ n ])
+  ≡⟨⟩
+    suc (pred (2 ^ n) + pred (2 ^ n))
+  ≡˘⟨ +-suc (pred (2 ^ n)) (pred (2 ^ n)) ⟩
+    pred (2 ^ n) + suc (pred (2 ^ n))
+  ≡⟨ Eq.cong (pred (2 ^ n) +_) (suc-pred (2 ^ n) {{m^n≢0 2 n}}) ⟩
+    pred (2 ^ n) + 2 ^ n
+  ≡˘⟨ +-∸-comm (2 ^ n) (m^n>0 2 n) ⟩
+    pred (2 ^ n + 2 ^ n)
+  ≡⟨ Eq.cong pred (lemma/2^suc n) ⟩
+    pred (2 ^ suc n)
+  ≡⟨⟩
+    pred[2^ suc n ]
+  ∎
+    where
+      open ≡-Reasoning
 
-pred[2^log₂] : (n : ℕ) → pred[2^ ⌈log₂ suc ⌈ n /2⌉ ⌉ ] ≤ n
-pred[2^log₂] n = lemma
-  where
-    open import Data.Nat.Logarithm.Core
-    open import Induction.WellFounded using (Acc; acc)
+pred[2^log₂] : (n : ℕ) → pred[2^ ⌈log₂ suc ⌈ n /2⌉ ⌉ ] ≤ n
+pred[2^log₂] n = lemma
+  where
+    open import Data.Nat.Logarithm.Core
+    open import Induction.WellFounded using (Acc; acc)
 
-    lemma : ∀ {n acc} → pred[2^ ⌈log2⌉ (suc ⌈ n /2⌉) acc ] ≤ n
-    lemma {zero} = z≤n
-    lemma {suc zero} {acc _} = s≤s z≤n
-    lemma {suc (suc n)} {acc rs} =
-      begin
-        pred[2^ ⌈log2⌉ (suc ⌈ suc (suc n) /2⌉) (acc rs) ]
-      ≡⟨⟩
-        pred[2^ suc (⌈log2⌉ ⌈ suc ⌈ suc (suc n) /2⌉ /2⌉ _) ]
-      ≡˘⟨ pred[2^suc[n]] (⌈log2⌉ ⌈ suc ⌈ suc (suc n) /2⌉ /2⌉ _) ⟩
-        suc (pred[2^ (⌈log2⌉ ⌈ suc ⌈ suc (suc n) /2⌉ /2⌉ _) ] + pred[2^ (⌈log2⌉ ⌈ suc ⌈ suc (suc n) /2⌉ /2⌉ _) ])
-      ≡⟨⟩
-        suc (pred[2^ ⌈log2⌉ ⌈ suc (suc ⌈ n /2⌉) /2⌉ _ ] + pred[2^ ⌈log2⌉ ⌈ suc (suc ⌈ n /2⌉) /2⌉ _ ])
-      ≡⟨⟩
-        suc (pred[2^ ⌈log2⌉ (suc ⌈ ⌈ n /2⌉ /2⌉) _ ] + pred[2^ ⌈log2⌉ (suc ⌈ ⌈ n /2⌉ /2⌉) _ ])
-      ≤⟨ s≤s (+-mono-≤ (lemma {⌈ n /2⌉}) (lemma {⌈ n /2⌉})) ⟩
-        suc (⌈ n /2⌉ + ⌈ n /2⌉)
-      ≡⟨⟩
-        suc (⌊ suc n /2⌋ + ⌈ n /2⌉)
-      ≤⟨ s≤s (+-monoʳ-≤ ⌊ suc n /2⌋ (⌈n/2⌉-mono (n≤1+n n))) ⟩
-        suc (⌊ suc n /2⌋ + ⌈ suc n /2⌉)
-      ≡⟨ Eq.cong suc (⌊n/2⌋+⌈n/2⌉≡n (suc n)) ⟩
-        suc (suc n)
-      ∎
-        where open ≤-Reasoning
+    lemma : ∀ {n acc} → pred[2^ ⌈log2⌉ (suc ⌈ n /2⌉) acc ] ≤ n
+    lemma {zero} = z≤n
+    lemma {suc zero} {acc _} = s≤s z≤n
+    lemma {suc (suc n)} {acc rs} =
+      begin
+        pred[2^ ⌈log2⌉ (suc ⌈ suc (suc n) /2⌉) (acc rs) ]
+      ≡⟨⟩
+        pred[2^ suc (⌈log2⌉ ⌈ suc ⌈ suc (suc n) /2⌉ /2⌉ _) ]
+      ≡˘⟨ pred[2^suc[n]] (⌈log2⌉ ⌈ suc ⌈ suc (suc n) /2⌉ /2⌉ _) ⟩
+        suc (pred[2^ (⌈log2⌉ ⌈ suc ⌈ suc (suc n) /2⌉ /2⌉ _) ] + pred[2^ (⌈log2⌉ ⌈ suc ⌈ suc (suc n) /2⌉ /2⌉ _) ])
+      ≡⟨⟩
+        suc (pred[2^ ⌈log2⌉ ⌈ suc (suc ⌈ n /2⌉) /2⌉ _ ] + pred[2^ ⌈log2⌉ ⌈ suc (suc ⌈ n /2⌉) /2⌉ _ ])
+      ≡⟨⟩
+        suc (pred[2^ ⌈log2⌉ (suc ⌈ ⌈ n /2⌉ /2⌉) _ ] + pred[2^ ⌈log2⌉ (suc ⌈ ⌈ n /2⌉ /2⌉) _ ])
+      ≤⟨ s≤s (+-mono-≤ (lemma {⌈ n /2⌉}) (lemma {⌈ n /2⌉})) ⟩
+        suc (⌈ n /2⌉ + ⌈ n /2⌉)
+      ≡⟨⟩
+        suc (⌊ suc n /2⌋ + ⌈ n /2⌉)
+      ≤⟨ s≤s (+-monoʳ-≤ ⌊ suc n /2⌋ (⌈n/2⌉-mono (n≤1+n n))) ⟩
+        suc (⌊ suc n /2⌋ + ⌈ suc n /2⌉)
+      ≡⟨ Eq.cong suc (⌊n/2⌋+⌈n/2⌉≡n (suc n)) ⟩
+        suc (suc n)
+      ∎
+        where open ≤-Reasoning
 

\ No newline at end of file
diff --git a/Data.Nat.Primality.html b/Data.Nat.Primality.html
index 86a2597b..40f57ed1 100644
--- a/Data.Nat.Primality.html
+++ b/Data.Nat.Primality.html
@@ -9,137 +9,396 @@
 
 module Data.Nat.Primality where
 
-open import Data.Empty using (⊥)
-open import Data.Nat.Base
-open import Data.Nat.Divisibility
-open import Data.Nat.GCD using (module GCD; module Bézout)
-open import Data.Nat.Properties
-open import Data.Product
-open import Data.Sum.Base using (_⊎_; inj₁; inj₂)
-open import Function.Base using (flip; _∘_; _∘′_)
-open import Relation.Nullary.Decidable as Dec
-  using (yes; no; from-yes; ¬?; decidable-stable; _×-dec_; _→-dec_)
-open import Relation.Nullary.Negation using (¬_; contradiction)
-open import Relation.Unary using (Decidable)
-open import Relation.Binary.PropositionalEquality
-  using (refl; sym; cong; subst)
-
-private
-  variable
-    n : ℕ
-
-------------------------------------------------------------------------
--- Definitions
-
--- Definition of compositeness
-
-Composite : ℕ → Set
-Composite 0 = ⊥
-Composite 1 = ⊥
-Composite n = ∃ λ d → 2 ≤ d × d < n × d ∣ n
-
--- Definition of primality.
-
-Prime : ℕ → Set
-Prime 0 = ⊥
-Prime 1 = ⊥
-Prime n = ∀ {d} → 2 ≤ d → d < n → d ∤ n
-
-------------------------------------------------------------------------
--- Decidability
-
-composite? : Decidable Composite
-composite? 0               = no λ()
-composite? 1               = no λ()
-composite? n@(suc (suc _)) = Dec.map′
-  (map₂ λ { (a , b , c) → (b , a , c)})
-  (map₂ λ { (a , b , c) → (b , a , c)})
-  (anyUpTo? (λ d → 2 ≤? d ×-dec d ∣? n) n)
-
-prime? : Decidable Prime
-prime? 0               = no λ()
-prime? 1               = no λ()
-prime? n@(suc (suc _)) = Dec.map′
-  (λ f {d} → flip (f {d}))
-  (λ f {d} → flip (f {d}))
-  (allUpTo? (λ d → 2 ≤? d →-dec ¬? (d ∣? n)) n)
-
-------------------------------------------------------------------------
--- Relationships between compositeness and primality
-
-composite⇒¬prime : Composite n → ¬ Prime n
-composite⇒¬prime {n@(suc (suc _))} (d , 2≤d , d<n , d∣n) n-prime =
-  n-prime 2≤d d<n d∣n
-
-¬composite⇒prime : 2 ≤ n → ¬ Composite n → Prime n
-¬composite⇒prime (s≤s (s≤s _)) ¬n-composite {d} 2≤d d<n d∣n =
-  ¬n-composite (d , 2≤d , d<n , d∣n)
-
-prime⇒¬composite : Prime n → ¬ Composite n
-prime⇒¬composite {n@(suc (suc _))} n-prime (d , 2≤d , d<n , d∣n) =
-  n-prime 2≤d d<n d∣n
-
--- note that this has to recompute the factor!
-¬prime⇒composite : 2 ≤ n → ¬ Prime n → Composite n
-¬prime⇒composite {n} 2≤n ¬n-prime =
-  decidable-stable (composite? n) (¬n-prime ∘′ ¬composite⇒prime 2≤n)
-
-------------------------------------------------------------------------
--- Euclid's lemma
-
--- For p prime, if p ∣ m * n, then either p ∣ m or p ∣ n.
--- This demonstrates that the usual definition of prime numbers matches the
--- ring theoretic definition of a prime element of the semiring ℕ.
--- This is useful for proving many other theorems involving prime numbers.
-euclidsLemma : ∀ m n {p} → Prime p → p ∣ m * n → p ∣ m ⊎ p ∣ n
-euclidsLemma m n {p@(suc (suc _))} p-prime p∣m*n = result
-  where
-  open ∣-Reasoning
-
-  p∣rmn : ∀ r → p ∣ r * m * n
-  p∣rmn r = begin
-    p           ∣⟨ p∣m*n ⟩
-    m * n       ∣⟨ n∣m*n r ⟩
-    r * (m * n) ≡˘⟨ *-assoc r m n ⟩
-    r * m * n   ∎
-
-  result : p ∣ m ⊎ p ∣ n
-  result with Bézout.lemma m p
-  -- if the GCD of m and p is zero then p must be zero, which is impossible as p
-  -- is a prime
-  ... | Bézout.result 0 g _ = contradiction (0∣⇒≡0 (GCD.gcd∣n g)) λ()
-
-  -- if the GCD of m and p is one then m and p is coprime, and we know that for
-  -- some integers s and r, sm + rp = 1. We can use this fact to determine that p
-  -- divides n
-  ... | Bézout.result 1 _ (Bézout.+- r s 1+sp≡rm) =
-    inj₂ (flip ∣m+n∣m⇒∣n (n∣m*n*o s n) (begin
-      p             ∣⟨ p∣rmn r ⟩
-      r * m * n     ≡˘⟨ cong (_* n) 1+sp≡rm ⟩
-      n + s * p * n ≡⟨ +-comm n (s * p * n) ⟩
-      s * p * n + n ∎))
-
-  ... | Bézout.result 1 _ (Bézout.-+ r s 1+rm≡sp) =
-    inj₂ (flip ∣m+n∣m⇒∣n (p∣rmn r) (begin
-      p             ∣⟨ n∣m*n*o s n ⟩
-      s * p * n     ≡˘⟨ cong (_* n) 1+rm≡sp ⟩
-      n + r * m * n ≡⟨ +-comm n (r * m * n) ⟩
-      r * m * n + n ∎))
-
-  -- if the GCD of m and p is greater than one, then it must be p and hence p ∣ m.
-  ... | Bézout.result d@(suc (suc _)) g _ with d ≟ p
-  ...   | yes refl = inj₁ (GCD.gcd∣m g)
-  ...   | no  d≢p  = contradiction (GCD.gcd∣n g) (p-prime 2≤d d<p)
-    where 2≤d = s≤s (s≤s z≤n); d<p = flip ≤∧≢⇒< d≢p (∣⇒≤ (GCD.gcd∣n g))
-
-private
-
-  -- Example: 2 is prime.
-  2-is-prime : Prime 2
-  2-is-prime = from-yes (prime? 2)
-
-
-  -- Example: 6 is composite
-  6-is-composite : Composite 6
-  6-is-composite = from-yes (composite? 6)
+open import Data.Nat.Base
+open import Data.Nat.Divisibility
+open import Data.Nat.GCD using (module GCD; module Bézout)
+open import Data.Nat.Properties
+open import Data.Product.Base using (∃-syntax; _×_; map₂; _,_)
+open import Data.Sum.Base using (_⊎_; inj₁; inj₂; [_,_]′)
+open import Function.Base using (flip; _∘_; _∘′_)
+open import Function.Bundles using (_⇔_; mk⇔)
+open import Relation.Nullary.Decidable as Dec
+  using (yes; no; from-yes; from-no; ¬?; _×-dec_; _⊎-dec_; _→-dec_; decidable-stable)
+open import Relation.Nullary.Negation using (¬_; contradiction; contradiction₂)
+open import Relation.Unary using (Pred; Decidable)
+open import Relation.Binary.Core using (Rel)
+open import Relation.Binary.PropositionalEquality
+  using (_≡_; _≢_; refl; cong)
+
+private
+  variable
+    d m n o p : ℕ
+
+  recompute-nonTrivial : .{{NonTrivial n}} → NonTrivial n
+  recompute-nonTrivial {n} {{nontrivial}} =
+    Dec.recompute (nonTrivial? n) nontrivial
+
+------------------------------------------------------------------------
+-- Definitions
+------------------------------------------------------------------------
+
+-- The positive/existential relation `BoundedNonTrivialDivisor` is
+-- the basis for the whole development, as it captures the possible
+-- non-trivial divisors of a given number; its complement, `Rough`,
+-- therefore sets *lower* bounds on any possible such divisors.
+
+-- The predicate `Composite` is then defined as the 'diagonal' instance
+-- of `BoundedNonTrivialDivisor`, while `Prime` is essentially defined as
+-- the complement of `Composite`. Finally, `Irreducible` is the positive
+-- analogue of `Prime`.
+
+------------------------------------------------------------------------
+-- Roughness
+
+-- A number is m-rough if all its non-trivial divisors are bounded below
+-- by m.
+infix 10 _Rough_
+
+_Rough_ : ℕ → Pred ℕ _
+m Rough n = ¬ (n HasNonTrivialDivisorLessThan m)
+
+------------------------------------------------------------------------
+-- Compositeness
+
+-- A number is composite if it has a proper non-trivial divisor.
+Composite : Pred ℕ _
+Composite n = n HasNonTrivialDivisorLessThan n
+
+-- A shorter pattern synonym for the record constructor producing a
+-- witness for `Composite`.
+pattern
+  composite {d} d<n d∣n = hasNonTrivialDivisor {divisor = d} d<n d∣n
+
+------------------------------------------------------------------------
+-- Primality
+
+-- Prime as the complement of Composite (and hence the diagonal of Rough
+-- as defined above). The constructor `prime` takes a proof `notComposite`
+-- that NonTrivial p is not composite and thereby enforces that:
+-- * p is a fortiori NonZero and NonUnit
+-- * p is p-Rough, i.e. any proper divisor must be at least p, i.e. p itself
+record Prime (p : ℕ) : Set where
+  constructor prime
+  field
+    .{{nontrivial}} : NonTrivial p
+    notComposite    : ¬ Composite p
+
+------------------------------------------------------------------------
+-- Irreducibility
+
+Irreducible : Pred ℕ _
+Irreducible n = ∀ {d} → d ∣ n → d ≡ 1 ⊎ d ≡ n
+
+------------------------------------------------------------------------
+-- Properties
+------------------------------------------------------------------------
+
+------------------------------------------------------------------------
+-- Roughness
+
+-- 1 is always n-rough
+rough-1 : ∀ n → n Rough 1
+rough-1 _ (hasNonTrivialDivisor _ d∣1) =
+  contradiction (∣1⇒≡1 d∣1) nonTrivial⇒≢1
+
+-- Any number is 0-, 1- and 2-rough,
+-- because no proper divisor d can be strictly less than 0, 1, or 2
+0-rough : 0 Rough n
+0-rough (hasNonTrivialDivisor () _)
+
+1-rough : 1 Rough n
+1-rough (hasNonTrivialDivisor {{()}} z<s _)
+
+2-rough : 2 Rough n
+2-rough (hasNonTrivialDivisor {{()}} (s<s z<s) _)
+
+-- If a number n > 1 is m-rough, then m ≤ n
+rough⇒≤ : .{{NonTrivial n}} → m Rough n → m ≤ n
+rough⇒≤ rough = ≮⇒≥ n≮m
+  where n≮m = λ m>n → rough (hasNonTrivialDivisor m>n ∣-refl)
+
+-- If a number n is m-rough, and m ∤ n, then n is (suc m)-rough
+∤⇒rough-suc : m ∤ n → m Rough n → (suc m) Rough n
+∤⇒rough-suc m∤n r (hasNonTrivialDivisor d<1+m d∣n)
+  with m<1+n⇒m<n∨m≡n d<1+m
+... | inj₁ d<m      = r (hasNonTrivialDivisor d<m d∣n)
+... | inj₂ d≡m@refl = contradiction d∣n m∤n
+
+-- If a number is m-rough, then so are all of its divisors
+rough∧∣⇒rough : m Rough o → n ∣ o → m Rough n
+rough∧∣⇒rough r n∣o bntd = r (hasNonTrivialDivisor-∣ bntd n∣o)
+
+------------------------------------------------------------------------
+-- Compositeness
+
+-- Smart constructors
+
+composite-≢ : ∀ d → .{{NonTrivial d}} → .{{NonZero n}} →
+              d ≢ n → d ∣ n → Composite n
+composite-≢ d = hasNonTrivialDivisor-≢ {d}
+
+composite-∣ : .{{NonZero n}} → Composite m → m ∣ n → Composite n
+composite-∣ (composite {d} d<m d∣n) m∣n@(divides-refl q)
+  = composite (*-monoʳ-< q d<m) (*-monoʳ-∣ q d∣n)
+  where instance
+    _ = m≢0∧n>1⇒m*n>1 q d
+    _ = m*n≢0⇒m≢0 q
+
+-- Basic (counter-)examples of Composite
+
+¬composite[0] : ¬ Composite 0
+¬composite[0] = 0-rough
+
+¬composite[1] : ¬ Composite 1
+¬composite[1] = 1-rough
+
+composite[4] : Composite 4
+composite[4] = composite-≢ 2 (λ()) (divides-refl 2)
+
+composite[6] : Composite 6
+composite[6] = composite-≢ 3 (λ()) (divides-refl 2)
+
+composite⇒nonZero : Composite n → NonZero n
+composite⇒nonZero {suc _} _ = _
+
+composite⇒nonTrivial : Composite n → NonTrivial n
+composite⇒nonTrivial {1}    composite[1] =
+  contradiction composite[1] ¬composite[1]
+composite⇒nonTrivial {2+ _} _            = _
+
+composite? : Decidable Composite
+composite? n = Dec.map CompositeUpTo⇔Composite (compositeUpTo? n)
+  where
+  -- For technical reasons, in order to be able to prove decidability
+  -- via the `all?` and `any?` combinators for *bounded* predicates on
+  -- `ℕ`, we further define the bounded counterparts to predicates
+  -- `P...` as `P...UpTo` and show the equivalence of the two.
+
+  -- Equivalent bounded predicate definition
+  CompositeUpTo : Pred ℕ _
+  CompositeUpTo n = ∃[ d ] d < n × NonTrivial d × d ∣ n
+
+  -- Proof of equivalence
+  comp-upto⇒comp : CompositeUpTo n → Composite n
+  comp-upto⇒comp (_ , d<n , ntd , d∣n) = composite d<n d∣n
+    where instance _ = ntd
+
+  comp⇒comp-upto : Composite n → CompositeUpTo n
+  comp⇒comp-upto (composite d<n d∣n) = _ , d<n , recompute-nonTrivial , d∣n
+
+  CompositeUpTo⇔Composite : CompositeUpTo n ⇔ Composite n
+  CompositeUpTo⇔Composite = mk⇔ comp-upto⇒comp comp⇒comp-upto
+
+  -- Proof of decidability
+  compositeUpTo? : Decidable CompositeUpTo
+  compositeUpTo? n = anyUpTo? (λ d → nonTrivial? d ×-dec d ∣? n) n
+
+------------------------------------------------------------------------
+-- Primality
+
+-- Basic (counter-)examples
+
+¬prime[0] : ¬ Prime 0
+¬prime[0] ()
+
+¬prime[1] : ¬ Prime 1
+¬prime[1] ()
+
+prime[2] : Prime 2
+prime[2] = prime 2-rough
+
+prime⇒nonZero : Prime p → NonZero p
+prime⇒nonZero _ = nonTrivial⇒nonZero _
+
+prime⇒nonTrivial : Prime p → NonTrivial p
+prime⇒nonTrivial _ = recompute-nonTrivial
+
+prime? : Decidable Prime
+prime? 0        = no ¬prime[0]
+prime? 1        = no ¬prime[1]
+prime? n@(2+ _) = Dec.map PrimeUpTo⇔Prime (primeUpTo? n)
+  where
+  -- Equivalent bounded predicate definition
+  PrimeUpTo : Pred ℕ _
+  PrimeUpTo n = ∀ {d} → d < n → NonTrivial d → d ∤ n
+
+  -- Proof of equivalence
+  prime⇒prime-upto : Prime n → PrimeUpTo n
+  prime⇒prime-upto (prime p) {d} d<n ntd d∣n
+    = p (composite d<n d∣n) where instance _ = ntd
+
+  prime-upto⇒prime : .{{NonTrivial n}} → PrimeUpTo n → Prime n
+  prime-upto⇒prime upto = prime
+    λ (composite d<n d∣n) → upto d<n recompute-nonTrivial d∣n
+
+  PrimeUpTo⇔Prime : .{{NonTrivial n}} → PrimeUpTo n ⇔ Prime n
+  PrimeUpTo⇔Prime = mk⇔ prime-upto⇒prime prime⇒prime-upto
+
+  -- Proof of decidability
+  primeUpTo? : Decidable PrimeUpTo
+  primeUpTo? n = allUpTo? (λ d → nonTrivial? d →-dec ¬? (d ∣? n)) n
+
+-- Euclid's lemma - for p prime, if p ∣ m * n, then either p ∣ m or p ∣ n.
+--
+-- This demonstrates that the usual definition of prime numbers matches
+-- the ring theoretic definition of a prime element of the semiring ℕ.
+-- This is useful for proving many other theorems involving prime numbers.
+euclidsLemma : ∀ m n {p} → Prime p → p ∣ m * n → p ∣ m ⊎ p ∣ n
+euclidsLemma m n {p} pp@(prime pr) p∣m*n = result
+  where
+  open ∣-Reasoning
+  instance _ = prime⇒nonZero pp
+
+  p∣rmn : ∀ r → p ∣ r * m * n
+  p∣rmn r = begin
+    p           ∣⟨ p∣m*n ⟩
+    m * n       ∣⟨ n∣m*n r ⟩
+    r * (m * n) ≡⟨ *-assoc r m n ⟨
+    r * m * n   ∎
+
+  result : p ∣ m ⊎ p ∣ n
+  result with Bézout.lemma m p
+  -- if the GCD of m and p is zero then p must be zero, which is
+  -- impossible as p is a prime.
+  -- note: this should be a typechecker-rejectable case!?
+  ... | Bézout.result 0 g _ =
+    contradiction (0∣⇒≡0 (GCD.gcd∣n g)) (≢-nonZero⁻¹ _)
+
+  -- if the GCD of m and p is one then m and p are coprime, and we know
+  -- that for some integers s and r, sm + rp = 1. We can use this fact
+  -- to determine that p divides n
+  ... | Bézout.result 1 _ (Bézout.+- r s 1+sp≡rm) =
+    inj₂ (flip ∣m+n∣m⇒∣n (n∣m*n*o s n) (begin
+      p             ∣⟨ p∣rmn r ⟩
+      r * m * n     ≡⟨ cong (_* n) 1+sp≡rm ⟨
+      n + s * p * n ≡⟨ +-comm n (s * p * n) ⟩
+      s * p * n + n ∎))
+
+  ... | Bézout.result 1 _ (Bézout.-+ r s 1+rm≡sp) =
+    inj₂ (flip ∣m+n∣m⇒∣n (p∣rmn r) (begin
+      p             ∣⟨ n∣m*n*o s n ⟩
+      s * p * n     ≡⟨ cong (_* n) 1+rm≡sp ⟨
+      n + r * m * n ≡⟨ +-comm n (r * m * n) ⟩
+      r * m * n + n ∎))
+
+  -- if the GCD of m and p is greater than one, then it must be p and
+  -- hence p ∣ m.
+  ... | Bézout.result d@(2+ _) g _ with d ≟ p
+  ...   | yes d≡p@refl = inj₁ (GCD.gcd∣m g)
+  ...   | no  d≢p = contradiction (composite-≢ d d≢p (GCD.gcd∣n g)) pr
+
+-- Relationship between roughness and primality.
+prime⇒rough : Prime p → p Rough p
+prime⇒rough (prime pr) = pr
+
+-- If a number n is p-rough, and p > 1 divides n, then p must be prime
+rough∧∣⇒prime : .{{NonTrivial p}} → p Rough n → p ∣ n → Prime p
+rough∧∣⇒prime r p∣n = prime (rough∧∣⇒rough r p∣n)
+
+-- Relationship between compositeness and primality.
+composite⇒¬prime : Composite n → ¬ Prime n
+composite⇒¬prime composite[d] (prime p) = p composite[d]
+
+¬composite⇒prime : .{{NonTrivial n}} → ¬ Composite n → Prime n
+¬composite⇒prime = prime
+
+prime⇒¬composite : Prime n → ¬ Composite n
+prime⇒¬composite (prime p) = p
+
+-- Note that this has to recompute the factor!
+¬prime⇒composite : .{{NonTrivial n}} → ¬ Prime n → Composite n
+¬prime⇒composite {n} ¬prime[n] =
+  decidable-stable (composite? n) (¬prime[n] ∘′ ¬composite⇒prime)
+
+------------------------------------------------------------------------
+-- Basic (counter-)examples of Irreducible
+
+¬irreducible[0] : ¬ Irreducible 0
+¬irreducible[0] irr[0] = contradiction₂ 2≡1⊎2≡0 (λ ()) (λ ())
+  where 2≡1⊎2≡0 = irr[0] {2} (divides-refl 0)
+
+irreducible[1] : Irreducible 1
+irreducible[1] m|1 = inj₁ (∣1⇒≡1 m|1)
+
+irreducible[2] : Irreducible 2
+irreducible[2] {zero}  0∣2 with () ← 0∣⇒≡0 0∣2
+irreducible[2] {suc _} d∣2 with ∣⇒≤ d∣2
+... | z<s     = inj₁ refl
+... | s<s z<s = inj₂ refl
+
+irreducible⇒nonZero : Irreducible n → NonZero n
+irreducible⇒nonZero {zero}    = flip contradiction ¬irreducible[0]
+irreducible⇒nonZero {suc _} _ = _
+
+irreducible? : Decidable Irreducible
+irreducible? zero      = no ¬irreducible[0]
+irreducible? n@(suc _) =
+  Dec.map IrreducibleUpTo⇔Irreducible (irreducibleUpTo? n)
+  where
+  -- Equivalent bounded predicate definition
+  IrreducibleUpTo : Pred ℕ _
+  IrreducibleUpTo n = ∀ {d} → d < n → d ∣ n → d ≡ 1 ⊎ d ≡ n
+
+  -- Proof of equivalence
+  irr-upto⇒irr : .{{NonZero n}} → IrreducibleUpTo n → Irreducible n
+  irr-upto⇒irr irr-upto m∣n
+    = [ flip irr-upto m∣n , inj₂ ]′ (m≤n⇒m<n∨m≡n (∣⇒≤ m∣n))
+
+  irr⇒irr-upto : Irreducible n → IrreducibleUpTo n
+  irr⇒irr-upto irr m<n m∣n = irr m∣n
+
+  IrreducibleUpTo⇔Irreducible : .{{NonZero n}} →
+                                 IrreducibleUpTo n ⇔ Irreducible n
+  IrreducibleUpTo⇔Irreducible = mk⇔ irr-upto⇒irr irr⇒irr-upto
+
+  -- Decidability
+  irreducibleUpTo? : Decidable IrreducibleUpTo
+  irreducibleUpTo? n = allUpTo?
+    (λ m → (m ∣? n) →-dec (m ≟ 1 ⊎-dec m ≟ n)) n
+
+-- Relationship between primality and irreducibility.
+prime⇒irreducible : Prime p → Irreducible p
+prime⇒irreducible {p} pp@(prime pr) = irr
+  where
+  instance _ = prime⇒nonZero pp
+  irr : .{{NonZero p}} → Irreducible p
+  irr {0}    0∣p = contradiction (0∣⇒≡0 0∣p) (≢-nonZero⁻¹ p)
+  irr {1}    1∣p = inj₁ refl
+  irr {2+ _} d∣p = inj₂ (≤∧≮⇒≡ (∣⇒≤ d∣p) d≮p)
+    where d≮p = λ d<p → pr (composite d<p d∣p)
+
+
+irreducible⇒prime : .{{NonTrivial p}} → Irreducible p → Prime p
+irreducible⇒prime irr = prime
+  λ (composite d<p d∣p) → [ nonTrivial⇒≢1 , (<⇒≢ d<p) ]′ (irr d∣p)
+
+------------------------------------------------------------------------
+-- Using decidability
+
+-- Once we have the above decision procedures, then instead of
+-- constructing proofs of e.g. Prime-ness by hand, we call the
+-- appropriate function, and use the witness extraction functions
+-- `from-yes`, `from-no` to return the checked proofs.
+
+private
+
+  -- Example: 2 is prime, but not-composite.
+  2-is-prime : Prime 2
+  2-is-prime = from-yes (prime? 2)
+
+  2-is-not-composite : ¬ Composite 2
+  2-is-not-composite = from-no (composite? 2)
+
+  -- Example: 4 and 6 are composite, hence not-prime
+  4-is-composite : Composite 4
+  4-is-composite = from-yes (composite? 4)
+
+  4-is-not-prime : ¬ Prime 4
+  4-is-not-prime = from-no (prime? 4)
+
+  6-is-composite : Composite 6
+  6-is-composite = from-yes (composite? 6)
+
+  6-is-not-prime : ¬ Prime 6
+  6-is-not-prime = from-no (prime? 6)
\ No newline at end of file diff --git a/Data.Nat.Properties.html b/Data.Nat.Properties.html index 591d5a7e..73274e54 100644 --- a/Data.Nat.Properties.html +++ b/Data.Nat.Properties.html @@ -20,2293 +20,2351 @@ import Algebra.Construct.NaturalChoice.MinMaxOp as MinMaxOp import Algebra.Lattice.Construct.NaturalChoice.MinMaxOp as LatticeMinMaxOp import Algebra.Properties.CommutativeSemigroup as CommSemigroupProperties -open import Data.Bool.Base using (Bool; false; true; T) -open import Data.Bool.Properties using (T?) -open import Data.Empty using (⊥) -open import Data.Nat.Base -open import Data.Product using (∄; ∃; _×_; _,_) -open import Data.Sum.Base as Sum -open import Data.Unit using (tt) -open import Function.Base -open import Function.Bundles using (_↣_) -open import Function.Metric.Nat -open import Level using (0ℓ) -open import Relation.Unary as U using (Pred) -open import Relation.Binary -open import Relation.Binary.Consequences using (flip-Connex) -open import Relation.Binary.PropositionalEquality -open import Relation.Nullary hiding (Irrelevant) -open import Relation.Nullary.Decidable using (True; via-injection; map′) -open import Relation.Nullary.Negation using (contradiction; contradiction₂) -open import Relation.Nullary.Reflects using (fromEquivalence) - -open import Algebra.Definitions {A = ℕ} _≡_ - hiding (LeftCancellative; RightCancellative; Cancellative) -open import Algebra.Definitions - using (LeftCancellative; RightCancellative; Cancellative) -open import Algebra.Structures {A = ℕ} _≡_ - ------------------------------------------------------------------------- --- Properties of NonZero ------------------------------------------------------------------------- - -nonZero? : U.Decidable NonZero -nonZero? zero = no NonZero.nonZero -nonZero? (suc n) = yes _ - ------------------------------------------------------------------------- --- Properties of _≡_ ------------------------------------------------------------------------- - -suc-injective : ∀ {m n} → suc m ≡ suc n → m ≡ n -suc-injective refl = refl - -≡ᵇ⇒≡ : ∀ m n → T (m ≡ᵇ n) → m ≡ n -≡ᵇ⇒≡ zero zero _ = refl -≡ᵇ⇒≡ (suc m) (suc n) eq = cong suc (≡ᵇ⇒≡ m n eq) - -≡⇒≡ᵇ : ∀ m n → m ≡ n → T (m ≡ᵇ n) -≡⇒≡ᵇ zero zero eq = _ -≡⇒≡ᵇ (suc m) (suc n) eq = ≡⇒≡ᵇ m n (suc-injective eq) - --- NB: we use the builtin function `_≡ᵇ_` here so that the function --- quickly decides whether to return `yes` or `no`. It still takes --- a linear amount of time to generate the proof if it is inspected. --- We expect the main benefit to be visible in compiled code as the --- backend erases proofs. - -infix 4 _≟_ -_≟_ : DecidableEquality ℕ -m ≟ n = map′ (≡ᵇ⇒≡ m n) (≡⇒≡ᵇ m n) (T? (m ≡ᵇ n)) - -≡-irrelevant : Irrelevant {A = ℕ} _≡_ -≡-irrelevant = Decidable⇒UIP.≡-irrelevant _≟_ - -≟-diag : ∀ {m n} (eq : m ≡ n) → (m ≟ n) ≡ yes eq -≟-diag = ≡-≟-identity _≟_ - -≡-isDecEquivalence : IsDecEquivalence (_≡_ {A = ℕ}) -≡-isDecEquivalence = record - { isEquivalence = isEquivalence - ; _≟_ = _≟_ - } - -≡-decSetoid : DecSetoid 0ℓ 0ℓ -≡-decSetoid = record - { Carrier = ℕ - ; _≈_ = _≡_ - ; isDecEquivalence = ≡-isDecEquivalence - } - -0≢1+n : ∀ {n} → 0 ≢ suc n -0≢1+n () - -1+n≢0 : ∀ {n} → suc n ≢ 0 -1+n≢0 () - -1+n≢n : ∀ {n} → suc n ≢ n -1+n≢n {suc n} = 1+n≢n ∘ suc-injective - ------------------------------------------------------------------------- --- Properties of _<ᵇ_ ------------------------------------------------------------------------- - -<ᵇ⇒< : ∀ m n → T (m <ᵇ n) → m < n -<ᵇ⇒< zero (suc n) m<n = z<s -<ᵇ⇒< (suc m) (suc n) m<n = s<s (<ᵇ⇒< m n m<n) - -<⇒<ᵇ : ∀ {m n} → m < n → T (m <ᵇ n) -<⇒<ᵇ z<s = tt -<⇒<ᵇ (s<s m<n@(s≤s _)) = <⇒<ᵇ m<n - -<ᵇ-reflects-< : ∀ m n → Reflects (m < n) (m <ᵇ n) -<ᵇ-reflects-< m n = fromEquivalence (<ᵇ⇒< m n) <⇒<ᵇ - ------------------------------------------------------------------------- --- Properties of _≤ᵇ_ ------------------------------------------------------------------------- - -≤ᵇ⇒≤ : ∀ m n → T (m ≤ᵇ n) → m ≤ n -≤ᵇ⇒≤ zero n m≤n = z≤n -≤ᵇ⇒≤ (suc m) n m≤n = <ᵇ⇒< m n m≤n - -≤⇒≤ᵇ : ∀ {m n} → m ≤ n → T (m ≤ᵇ n) -≤⇒≤ᵇ z≤n = tt -≤⇒≤ᵇ m≤n@(s≤s _) = <⇒<ᵇ m≤n - -≤ᵇ-reflects-≤ : ∀ m n → Reflects (m ≤ n) (m ≤ᵇ n) -≤ᵇ-reflects-≤ m n = fromEquivalence (≤ᵇ⇒≤ m n) ≤⇒≤ᵇ - ------------------------------------------------------------------------- --- Properties of _≤_ ------------------------------------------------------------------------- - ------------------------------------------------------------------------- --- Relational properties of _≤_ - -≤-reflexive : _≡_ ⇒ _≤_ -≤-reflexive {zero} refl = z≤n -≤-reflexive {suc m} refl = s≤s (≤-reflexive refl) - -≤-refl : Reflexive _≤_ -≤-refl = ≤-reflexive refl - -≤-antisym : Antisymmetric _≡_ _≤_ -≤-antisym z≤n z≤n = refl -≤-antisym (s≤s m≤n) (s≤s n≤m) = cong suc (≤-antisym m≤n n≤m) - -≤-trans : Transitive _≤_ -≤-trans z≤n _ = z≤n -≤-trans (s≤s m≤n) (s≤s n≤o) = s≤s (≤-trans m≤n n≤o) - -≤-total : Total _≤_ -≤-total zero _ = inj₁ z≤n -≤-total _ zero = inj₂ z≤n -≤-total (suc m) (suc n) with ≤-total m n -... | inj₁ m≤n = inj₁ (s≤s m≤n) -... | inj₂ n≤m = inj₂ (s≤s n≤m) - -≤-irrelevant : Irrelevant _≤_ -≤-irrelevant z≤n z≤n = refl -≤-irrelevant (s≤s m≤n₁) (s≤s m≤n₂) = cong s≤s (≤-irrelevant m≤n₁ m≤n₂) - --- NB: we use the builtin function `_<ᵇ_` here so that the function --- quickly decides whether to return `yes` or `no`. It still takes --- a linear amount of time to generate the proof if it is inspected. --- We expect the main benefit to be visible in compiled code as the --- backend erases proofs. - -infix 4 _≤?_ _≥?_ - -_≤?_ : Decidable _≤_ -m ≤? n = map′ (≤ᵇ⇒≤ m n) ≤⇒≤ᵇ (T? (m ≤ᵇ n)) - -_≥?_ : Decidable _≥_ -_≥?_ = flip _≤?_ - ------------------------------------------------------------------------- --- Structures - -≤-isPreorder : IsPreorder _≡_ _≤_ -≤-isPreorder = record - { isEquivalence = isEquivalence - ; reflexive = ≤-reflexive - ; trans = ≤-trans - } +open import Data.Bool.Base using (Bool; false; true; T) +open import Data.Bool.Properties using (T?) +open import Data.Nat.Base +open import Data.Product.Base using (∃; _×_; _,_) +open import Data.Sum.Base as Sum +open import Data.Unit using (tt) +open import Function.Base +open import Function.Bundles using (_↣_) +open import Function.Metric.Nat +open import Level using (0ℓ) +open import Relation.Unary as U using (Pred) +open import Relation.Binary.Core + using (_⇒_; _Preserves_⟶_; _Preserves₂_⟶_⟶_) +open import Relation.Binary +open import Relation.Binary.Consequences using (flip-Connex) +open import Relation.Binary.PropositionalEquality +open import Relation.Nullary hiding (Irrelevant) +open import Relation.Nullary.Decidable using (True; via-injection; map′) +open import Relation.Nullary.Negation.Core using (¬_; contradiction) +open import Relation.Nullary.Reflects using (fromEquivalence) + +open import Algebra.Definitions {A = ℕ} _≡_ + hiding (LeftCancellative; RightCancellative; Cancellative) +open import Algebra.Definitions + using (LeftCancellative; RightCancellative; Cancellative) +open import Algebra.Structures {A = ℕ} _≡_ + + +private + variable + m n o k : ℕ + + +------------------------------------------------------------------------ +-- Properties of NonZero +------------------------------------------------------------------------ + +nonZero? : U.Decidable NonZero +nonZero? zero = no NonZero.nonZero +nonZero? (suc n) = yes _ + +------------------------------------------------------------------------ +-- Properties of NonTrivial +------------------------------------------------------------------------ + +nonTrivial? : U.Decidable NonTrivial +nonTrivial? 0 = no λ() +nonTrivial? 1 = no λ() +nonTrivial? (2+ n) = yes _ + +------------------------------------------------------------------------ +-- Properties of _≡_ +------------------------------------------------------------------------ + +suc-injective : suc m ≡ suc n → m ≡ n +suc-injective = cong pred + +≡ᵇ⇒≡ : ∀ m n → T (m ≡ᵇ n) → m ≡ n +≡ᵇ⇒≡ zero zero _ = refl +≡ᵇ⇒≡ (suc m) (suc n) eq = cong suc (≡ᵇ⇒≡ m n eq) + +≡⇒≡ᵇ : ∀ m n → m ≡ n → T (m ≡ᵇ n) +≡⇒≡ᵇ zero zero eq = _ +≡⇒≡ᵇ (suc m) (suc n) eq = ≡⇒≡ᵇ m n (suc-injective eq) + +-- NB: we use the builtin function `_≡ᵇ_` here so that the function +-- quickly decides whether to return `yes` or `no`. It still takes +-- a linear amount of time to generate the proof if it is inspected. +-- We expect the main benefit to be visible in compiled code as the +-- backend erases proofs. + +infix 4 _≟_ +_≟_ : DecidableEquality ℕ +m ≟ n = map′ (≡ᵇ⇒≡ m n) (≡⇒≡ᵇ m n) (T? (m ≡ᵇ n)) + +≡-irrelevant : Irrelevant {A = ℕ} _≡_ +≡-irrelevant = Decidable⇒UIP.≡-irrelevant _≟_ + +≟-diag : (eq : m ≡ n) → (m ≟ n) ≡ yes eq +≟-diag = ≡-≟-identity _≟_ + +≡-isDecEquivalence : IsDecEquivalence (_≡_ {A = ℕ}) +≡-isDecEquivalence = record + { isEquivalence = isEquivalence + ; _≟_ = _≟_ + } + +≡-decSetoid : DecSetoid 0ℓ 0ℓ +≡-decSetoid = record + { Carrier = ℕ + ; _≈_ = _≡_ + ; isDecEquivalence = ≡-isDecEquivalence + } + +0≢1+n : 0 ≢ suc n +0≢1+n () + +1+n≢0 : suc n ≢ 0 +1+n≢0 () + +1+n≢n : suc n ≢ n +1+n≢n {suc n} = 1+n≢n ∘ suc-injective + +------------------------------------------------------------------------ +-- Properties of _<ᵇ_ +------------------------------------------------------------------------ + +<ᵇ⇒< : ∀ m n → T (m <ᵇ n) → m < n +<ᵇ⇒< zero (suc n) m<n = z<s +<ᵇ⇒< (suc m) (suc n) m<n = s<s (<ᵇ⇒< m n m<n) + +<⇒<ᵇ : m < n → T (m <ᵇ n) +<⇒<ᵇ z<s = tt +<⇒<ᵇ (s<s m<n@(s≤s _)) = <⇒<ᵇ m<n + +<ᵇ-reflects-< : ∀ m n → Reflects (m < n) (m <ᵇ n) +<ᵇ-reflects-< m n = fromEquivalence (<ᵇ⇒< m n) <⇒<ᵇ + +------------------------------------------------------------------------ +-- Properties of _≤ᵇ_ +------------------------------------------------------------------------ + +≤ᵇ⇒≤ : ∀ m n → T (m ≤ᵇ n) → m ≤ n +≤ᵇ⇒≤ zero n m≤n = z≤n +≤ᵇ⇒≤ (suc m) n m≤n = <ᵇ⇒< m n m≤n -≤-isTotalPreorder : IsTotalPreorder _≡_ _≤_ -≤-isTotalPreorder = record - { isPreorder = ≤-isPreorder - ; total = ≤-total - } +≤⇒≤ᵇ : m ≤ n → T (m ≤ᵇ n) +≤⇒≤ᵇ z≤n = tt +≤⇒≤ᵇ m≤n@(s≤s _) = <⇒<ᵇ m≤n + +≤ᵇ-reflects-≤ : ∀ m n → Reflects (m ≤ n) (m ≤ᵇ n) +≤ᵇ-reflects-≤ m n = fromEquivalence (≤ᵇ⇒≤ m n) ≤⇒≤ᵇ + +------------------------------------------------------------------------ +-- Properties of _≤_ +------------------------------------------------------------------------ + +------------------------------------------------------------------------ +-- Relational properties of _≤_ + +≤-reflexive : _≡_ ⇒ _≤_ +≤-reflexive {zero} refl = z≤n +≤-reflexive {suc m} refl = s≤s (≤-reflexive refl) + +≤-refl : Reflexive _≤_ +≤-refl = ≤-reflexive refl + +≤-antisym : Antisymmetric _≡_ _≤_ +≤-antisym z≤n z≤n = refl +≤-antisym (s≤s m≤n) (s≤s n≤m) = cong suc (≤-antisym m≤n n≤m) + +≤-trans : Transitive _≤_ +≤-trans z≤n _ = z≤n +≤-trans (s≤s m≤n) (s≤s n≤o) = s≤s (≤-trans m≤n n≤o) + +≤-total : Total _≤_ +≤-total zero _ = inj₁ z≤n +≤-total _ zero = inj₂ z≤n +≤-total (suc m) (suc n) = Sum.map s≤s s≤s (≤-total m n) + +≤-irrelevant : Irrelevant _≤_ +≤-irrelevant z≤n z≤n = refl +≤-irrelevant (s≤s m≤n₁) (s≤s m≤n₂) = cong s≤s (≤-irrelevant m≤n₁ m≤n₂) + +-- NB: we use the builtin function `_<ᵇ_` here so that the function +-- quickly decides whether to return `yes` or `no`. It still takes +-- a linear amount of time to generate the proof if it is inspected. +-- We expect the main benefit to be visible in compiled code as the +-- backend erases proofs. + +infix 4 _≤?_ _≥?_ + +_≤?_ : Decidable _≤_ +m ≤? n = map′ (≤ᵇ⇒≤ m n) ≤⇒≤ᵇ (T? (m ≤ᵇ n)) -≤-isPartialOrder : IsPartialOrder _≡_ _≤_ -≤-isPartialOrder = record - { isPreorder = ≤-isPreorder - ; antisym = ≤-antisym - } +_≥?_ : Decidable _≥_ +_≥?_ = flip _≤?_ -≤-isTotalOrder : IsTotalOrder _≡_ _≤_ -≤-isTotalOrder = record - { isPartialOrder = ≤-isPartialOrder - ; total = ≤-total - } +------------------------------------------------------------------------ +-- Structures -≤-isDecTotalOrder : IsDecTotalOrder _≡_ _≤_ -≤-isDecTotalOrder = record - { isTotalOrder = ≤-isTotalOrder - ; _≟_ = _≟_ - ; _≤?_ = _≤?_ - } +≤-isPreorder : IsPreorder _≡_ _≤_ +≤-isPreorder = record + { isEquivalence = isEquivalence + ; reflexive = ≤-reflexive + ; trans = ≤-trans + } ------------------------------------------------------------------------- --- Bundles +≤-isTotalPreorder : IsTotalPreorder _≡_ _≤_ +≤-isTotalPreorder = record + { isPreorder = ≤-isPreorder + ; total = ≤-total + } -≤-preorder : Preorder 0ℓ 0ℓ 0ℓ -≤-preorder = record - { isPreorder = ≤-isPreorder - } - -≤-totalPreorder : TotalPreorder 0ℓ 0ℓ 0ℓ -≤-totalPreorder = record - { isTotalPreorder = ≤-isTotalPreorder - } +≤-isPartialOrder : IsPartialOrder _≡_ _≤_ +≤-isPartialOrder = record + { isPreorder = ≤-isPreorder + ; antisym = ≤-antisym + } -≤-poset : Poset 0ℓ 0ℓ 0ℓ -≤-poset = record - { isPartialOrder = ≤-isPartialOrder - } +≤-isTotalOrder : IsTotalOrder _≡_ _≤_ +≤-isTotalOrder = record + { isPartialOrder = ≤-isPartialOrder + ; total = ≤-total + } -≤-totalOrder : TotalOrder 0ℓ 0ℓ 0ℓ -≤-totalOrder = record - { isTotalOrder = ≤-isTotalOrder - } +≤-isDecTotalOrder : IsDecTotalOrder _≡_ _≤_ +≤-isDecTotalOrder = record + { isTotalOrder = ≤-isTotalOrder + ; _≟_ = _≟_ + ; _≤?_ = _≤?_ + } -≤-decTotalOrder : DecTotalOrder 0ℓ 0ℓ 0ℓ -≤-decTotalOrder = record - { isDecTotalOrder = ≤-isDecTotalOrder - } +------------------------------------------------------------------------ +-- Bundles ------------------------------------------------------------------------- --- Other properties of _≤_ +≤-preorder : Preorder 0ℓ 0ℓ 0ℓ +≤-preorder = record + { isPreorder = ≤-isPreorder + } -s≤s-injective : ∀ {m n} {p q : m ≤ n} → s≤s p ≡ s≤s q → p ≡ q -s≤s-injective refl = refl +≤-totalPreorder : TotalPreorder 0ℓ 0ℓ 0ℓ +≤-totalPreorder = record + { isTotalPreorder = ≤-isTotalPreorder + } -≤-pred : ∀ {m n} → suc m ≤ suc n → m ≤ n -≤-pred (s≤s m≤n) = m≤n +≤-poset : Poset 0ℓ 0ℓ 0ℓ +≤-poset = record + { isPartialOrder = ≤-isPartialOrder + } -m≤n⇒m≤1+n : ∀ {m n} → m ≤ n → m ≤ 1 + n -m≤n⇒m≤1+n z≤n = z≤n -m≤n⇒m≤1+n (s≤s m≤n) = s≤s (m≤n⇒m≤1+n m≤n) +≤-totalOrder : TotalOrder 0ℓ 0ℓ 0ℓ +≤-totalOrder = record + { isTotalOrder = ≤-isTotalOrder + } -n≤1+n : ∀ n → n ≤ 1 + n -n≤1+n _ = m≤n⇒m≤1+n ≤-refl +≤-decTotalOrder : DecTotalOrder 0ℓ 0ℓ 0ℓ +≤-decTotalOrder = record + { isDecTotalOrder = ≤-isDecTotalOrder + } -1+n≰n : ∀ {n} → 1 + n ≰ n -1+n≰n (s≤s 1+n≤n) = 1+n≰n 1+n≤n +------------------------------------------------------------------------ +-- Other properties of _≤_ -n≤0⇒n≡0 : ∀ {n} → n ≤ 0 → n ≡ 0 -n≤0⇒n≡0 z≤n = refl +s≤s-injective : {p q : m ≤ n} → s≤s p ≡ s≤s q → p ≡ q +s≤s-injective refl = refl -n≤1⇒n≡0∨n≡1 : ∀ {n : ℕ} → n ≤ 1 → n ≡ 0 ⊎ n ≡ 1 -n≤1⇒n≡0∨n≡1 z≤n = inj₁ refl -n≤1⇒n≡0∨n≡1 (s≤s z≤n) = inj₂ refl +≤-pred : suc m ≤ suc n → m ≤ n +≤-pred = s≤s⁻¹ ------------------------------------------------------------------------- --- Properties of _<_ ------------------------------------------------------------------------- +m≤n⇒m≤1+n : m ≤ n → m ≤ 1 + n +m≤n⇒m≤1+n z≤n = z≤n +m≤n⇒m≤1+n (s≤s m≤n) = s≤s (m≤n⇒m≤1+n m≤n) --- Relationships between the various relations +n≤1+n : ∀ n → n ≤ 1 + n +n≤1+n _ = m≤n⇒m≤1+n ≤-refl -<⇒≤ : _<_ ⇒ _≤_ -<⇒≤ z<s = z≤n -<⇒≤ (s<s m<n@(s≤s _)) = s≤s (<⇒≤ m<n) +1+n≰n : 1 + n ≰ n +1+n≰n (s≤s 1+n≤n) = 1+n≰n 1+n≤n -<⇒≢ : _<_ ⇒ _≢_ -<⇒≢ m<n refl = 1+n≰n m<n +n≤0⇒n≡0 : n ≤ 0 → n ≡ 0 +n≤0⇒n≡0 z≤n = refl ->⇒≢ : _>_ ⇒ _≢_ ->⇒≢ = ≢-sym ∘ <⇒≢ +n≤1⇒n≡0∨n≡1 : n ≤ 1 → n ≡ 0 ⊎ n ≡ 1 +n≤1⇒n≡0∨n≡1 z≤n = inj₁ refl +n≤1⇒n≡0∨n≡1 (s≤s z≤n) = inj₂ refl -≤⇒≯ : _≤_ ⇒ _≯_ -≤⇒≯ (s≤s m≤n) (s≤s n≤m) = ≤⇒≯ m≤n n≤m +------------------------------------------------------------------------ +-- Properties of _<_ +------------------------------------------------------------------------ -<⇒≱ : _<_ ⇒ _≱_ -<⇒≱ (s≤s m+1≤n) (s≤s n≤m) = <⇒≱ m+1≤n n≤m +-- Relationships between the various relations -<⇒≯ : _<_ ⇒ _≯_ -<⇒≯ (s≤s m<n) (s≤s n<m) = <⇒≯ m<n n<m +<⇒≤ : _<_ ⇒ _≤_ +<⇒≤ z<s = z≤n +<⇒≤ (s<s m<n@(s≤s _)) = s≤s (<⇒≤ m<n) -≰⇒≮ : _≰_ ⇒ _≮_ -≰⇒≮ m≰n 1+m≤n = m≰n (<⇒≤ 1+m≤n) +<⇒≢ : _<_ ⇒ _≢_ +<⇒≢ m<n refl = 1+n≰n m<n -≰⇒> : _≰_ ⇒ _>_ -≰⇒> {zero} z≰n = contradiction z≤n z≰n -≰⇒> {suc m} {zero} _ = z<s -≰⇒> {suc m} {suc n} m≰n = s<s (≰⇒> (m≰n ∘ s≤s)) +>⇒≢ : _>_ ⇒ _≢_ +>⇒≢ = ≢-sym ∘ <⇒≢ -≰⇒≥ : _≰_ ⇒ _≥_ -≰⇒≥ = <⇒≤ ∘ ≰⇒> +≤⇒≯ : _≤_ ⇒ _≯_ +≤⇒≯ (s≤s m≤n) (s≤s n≤m) = ≤⇒≯ m≤n n≤m -≮⇒≥ : _≮_ ⇒ _≥_ -≮⇒≥ {_} {zero} _ = z≤n -≮⇒≥ {zero} {suc j} 1≮j+1 = contradiction z<s 1≮j+1 -≮⇒≥ {suc i} {suc j} i+1≮j+1 = s≤s (≮⇒≥ (i+1≮j+1 ∘ s<s)) +<⇒≱ : _<_ ⇒ _≱_ +<⇒≱ (s≤s m+1≤n) (s≤s n≤m) = <⇒≱ m+1≤n n≤m -≤∧≢⇒< : ∀ {m n} → m ≤ n → m ≢ n → m < n -≤∧≢⇒< {_} {zero} z≤n m≢n = contradiction refl m≢n -≤∧≢⇒< {_} {suc n} z≤n m≢n = z<s -≤∧≢⇒< {_} {suc n} (s≤s m≤n) 1+m≢1+n = - s<s (≤∧≢⇒< m≤n (1+m≢1+n ∘ cong suc)) +<⇒≯ : _<_ ⇒ _≯_ +<⇒≯ (s≤s m<n) (s≤s n<m) = <⇒≯ m<n n<m -≤∧≮⇒≡ : ∀ {m n} → m ≤ n → m ≮ n → m ≡ n -≤∧≮⇒≡ m≤n m≮n = ≤-antisym m≤n (≮⇒≥ m≮n) +≰⇒≮ : _≰_ ⇒ _≮_ +≰⇒≮ m≰n 1+m≤n = m≰n (<⇒≤ 1+m≤n) -≤-<-connex : Connex _≤_ _<_ -≤-<-connex m n with m ≤? n -... | yes m≤n = inj₁ m≤n -... | no ¬m≤n = inj₂ (≰⇒> ¬m≤n) +≰⇒> : _≰_ ⇒ _>_ +≰⇒> {zero} z≰n = contradiction z≤n z≰n +≰⇒> {suc m} {zero} _ = z<s +≰⇒> {suc m} {suc n} m≰n = s<s (≰⇒> (m≰n ∘ s≤s)) -≥->-connex : Connex _≥_ _>_ -≥->-connex = flip ≤-<-connex +≰⇒≥ : _≰_ ⇒ _≥_ +≰⇒≥ = <⇒≤ ∘ ≰⇒> -<-≤-connex : Connex _<_ _≤_ -<-≤-connex = flip-Connex ≤-<-connex +≮⇒≥ : _≮_ ⇒ _≥_ +≮⇒≥ {_} {zero} _ = z≤n +≮⇒≥ {zero} {suc j} 1≮j+1 = contradiction z<s 1≮j+1 +≮⇒≥ {suc i} {suc j} i+1≮j+1 = s≤s (≮⇒≥ (i+1≮j+1 ∘ s<s)) ->-≥-connex : Connex _>_ _≥_ ->-≥-connex = flip-Connex ≥->-connex +≤∧≢⇒< : ∀ {m n} → m ≤ n → m ≢ n → m < n +≤∧≢⇒< {_} {zero} z≤n m≢n = contradiction refl m≢n +≤∧≢⇒< {_} {suc n} z≤n m≢n = z<s +≤∧≢⇒< {_} {suc n} (s≤s m≤n) 1+m≢1+n = + s<s (≤∧≢⇒< m≤n (1+m≢1+n ∘ cong suc)) ------------------------------------------------------------------------- --- Relational properties of _<_ +≤∧≮⇒≡ : ∀ {m n} → m ≤ n → m ≮ n → m ≡ n +≤∧≮⇒≡ m≤n m≮n = ≤-antisym m≤n (≮⇒≥ m≮n) -<-irrefl : Irreflexive _≡_ _<_ -<-irrefl refl (s<s n<n) = <-irrefl refl n<n +≤-<-connex : Connex _≤_ _<_ +≤-<-connex m n with m ≤? n +... | yes m≤n = inj₁ m≤n +... | no ¬m≤n = inj₂ (≰⇒> ¬m≤n) -<-asym : Asymmetric _<_ -<-asym (s<s n<m) (s<s m<n) = <-asym n<m m<n +≥->-connex : Connex _≥_ _>_ +≥->-connex = flip ≤-<-connex -<-trans : Transitive _<_ -<-trans (s≤s i≤j) (s≤s j<k) = s≤s (≤-trans i≤j (≤-trans (n≤1+n _) j<k)) +<-≤-connex : Connex _<_ _≤_ +<-≤-connex = flip-Connex ≤-<-connex -<-transʳ : Trans _≤_ _<_ _<_ -<-transʳ m≤n (s<s n≤o) = s≤s (≤-trans m≤n n≤o) +>-≥-connex : Connex _>_ _≥_ +>-≥-connex = flip-Connex ≥->-connex -<-transˡ : Trans _<_ _≤_ _<_ -<-transˡ (s<s m≤n) (s≤s n≤o) = s≤s (≤-trans m≤n n≤o) +------------------------------------------------------------------------ +-- Relational properties of _<_ --- NB: we use the builtin function `_<ᵇ_` here so that the function --- quickly decides which constructor to return. It still takes a --- linear amount of time to generate the proof if it is inspected. --- We expect the main benefit to be visible in compiled code as the --- backend erases proofs. +<-irrefl : Irreflexive _≡_ _<_ +<-irrefl refl (s<s n<n) = <-irrefl refl n<n -<-cmp : Trichotomous _≡_ _<_ -<-cmp m n with m ≟ n | T? (m <ᵇ n) -... | yes m≡n | _ = tri≈ (<-irrefl m≡n) m≡n (<-irrefl (sym m≡n)) -... | no m≢n | yes m<n = tri< (<ᵇ⇒< m n m<n) m≢n (<⇒≯ (<ᵇ⇒< m n m<n)) -... | no m≢n | no m≮n = tri> (m≮n ∘ <⇒<ᵇ) m≢n (≤∧≢⇒< (≮⇒≥ (m≮n ∘ <⇒<ᵇ)) (m≢n ∘ sym)) +<-asym : Asymmetric _<_ +<-asym (s<s n<m) (s<s m<n) = <-asym n<m m<n -infix 4 _<?_ _>?_ +<-trans : Transitive _<_ +<-trans (s≤s i≤j) (s≤s j<k) = s≤s (≤-trans i≤j (≤-trans (n≤1+n _) j<k)) -_<?_ : Decidable _<_ -m <? n = suc m ≤? n +≤-<-trans : LeftTrans _≤_ _<_ +≤-<-trans m≤n (s<s n≤o) = s≤s (≤-trans m≤n n≤o) -_>?_ : Decidable _>_ -_>?_ = flip _<?_ +<-≤-trans : RightTrans _<_ _≤_ +<-≤-trans (s<s m≤n) (s≤s n≤o) = s≤s (≤-trans m≤n n≤o) -<-irrelevant : Irrelevant _<_ -<-irrelevant = ≤-irrelevant +-- NB: we use the builtin function `_<ᵇ_` here so that the function +-- quickly decides which constructor to return. It still takes a +-- linear amount of time to generate the proof if it is inspected. +-- We expect the main benefit to be visible in compiled code as the +-- backend erases proofs. -<-resp₂-≡ : _<_ Respects₂ _≡_ -<-resp₂-≡ = subst (_ <_) , subst (_< _) +<-cmp : Trichotomous _≡_ _<_ +<-cmp m n with m ≟ n | T? (m <ᵇ n) +... | yes m≡n | _ = tri≈ (<-irrefl m≡n) m≡n (<-irrefl (sym m≡n)) +... | no m≢n | yes m<n = tri< (<ᵇ⇒< m n m<n) m≢n (<⇒≯ (<ᵇ⇒< m n m<n)) +... | no m≢n | no m≮n = tri> (m≮n ∘ <⇒<ᵇ) m≢n (≤∧≢⇒< (≮⇒≥ (m≮n ∘ <⇒<ᵇ)) (m≢n ∘ sym)) ------------------------------------------------------------------------- --- Bundles +infix 4 _<?_ _>?_ -<-isStrictPartialOrder : IsStrictPartialOrder _≡_ _<_ -<-isStrictPartialOrder = record - { isEquivalence = isEquivalence - ; irrefl = <-irrefl - ; trans = <-trans - ; <-resp-≈ = <-resp₂-≡ - } +_<?_ : Decidable _<_ +m <? n = suc m ≤? n -<-isStrictTotalOrder : IsStrictTotalOrder _≡_ _<_ -<-isStrictTotalOrder = record - { isEquivalence = isEquivalence - ; trans = <-trans - ; compare = <-cmp - } +_>?_ : Decidable _>_ +_>?_ = flip _<?_ -<-strictPartialOrder : StrictPartialOrder 0ℓ 0ℓ 0ℓ -<-strictPartialOrder = record - { isStrictPartialOrder = <-isStrictPartialOrder - } +<-irrelevant : Irrelevant _<_ +<-irrelevant = ≤-irrelevant -<-strictTotalOrder : StrictTotalOrder 0ℓ 0ℓ 0ℓ -<-strictTotalOrder = record - { isStrictTotalOrder = <-isStrictTotalOrder - } +<-resp₂-≡ : _<_ Respects₂ _≡_ +<-resp₂-≡ = subst (_ <_) , subst (_< _) ------------------------------------------------------------------------- --- Other properties of _<_ +------------------------------------------------------------------------ +-- Bundles -s<s-injective : ∀ {m n} {p q : m < n} → s<s p ≡ s<s q → p ≡ q -s<s-injective refl = refl +<-isStrictPartialOrder : IsStrictPartialOrder _≡_ _<_ +<-isStrictPartialOrder = record + { isEquivalence = isEquivalence + ; irrefl = <-irrefl + ; trans = <-trans + ; <-resp-≈ = <-resp₂-≡ + } -<-pred : ∀ {m n} → suc m < suc n → m < n -<-pred (s<s m<n) = m<n +<-isStrictTotalOrder : IsStrictTotalOrder _≡_ _<_ +<-isStrictTotalOrder = isStrictTotalOrderᶜ record + { isEquivalence = isEquivalence + ; trans = <-trans + ; compare = <-cmp + } -m<n⇒m<1+n : ∀ {m n} → m < n → m < 1 + n -m<n⇒m<1+n z<s = z<s -m<n⇒m<1+n (s<s m<n@(s≤s _)) = s<s (m<n⇒m<1+n m<n) +<-strictPartialOrder : StrictPartialOrder 0ℓ 0ℓ 0ℓ +<-strictPartialOrder = record + { isStrictPartialOrder = <-isStrictPartialOrder + } -n≮0 : ∀ {n} → n ≮ 0 -n≮0 () +<-strictTotalOrder : StrictTotalOrder 0ℓ 0ℓ 0ℓ +<-strictTotalOrder = record + { isStrictTotalOrder = <-isStrictTotalOrder + } -n≮n : ∀ n → n ≮ n -n≮n n = <-irrefl (refl {x = n}) +------------------------------------------------------------------------ +-- Other properties of _<_ -0<1+n : ∀ {n} → 0 < suc n -0<1+n = z<s +s<s-injective : {p q : m < n} → s<s p ≡ s<s q → p ≡ q +s<s-injective refl = refl -n<1+n : ∀ n → n < suc n -n<1+n n = ≤-refl +<-pred : suc m < suc n → m < n +<-pred = s<s⁻¹ -n<1⇒n≡0 : ∀ {n} → n < 1 → n ≡ 0 -n<1⇒n≡0 (s≤s n≤0) = n≤0⇒n≡0 n≤0 +m<n⇒m<1+n : m < n → m < 1 + n +m<n⇒m<1+n z<s = z<s +m<n⇒m<1+n (s<s m<n@(s≤s _)) = s<s (m<n⇒m<1+n m<n) -n>0⇒n≢0 : ∀ {n} → n > 0 → n ≢ 0 -n>0⇒n≢0 {suc n} _ () +n≮0 : n ≮ 0 +n≮0 () -n≢0⇒n>0 : ∀ {n} → n ≢ 0 → n > 0 -n≢0⇒n>0 {zero} 0≢0 = contradiction refl 0≢0 -n≢0⇒n>0 {suc n} _ = 0<1+n - -m<n⇒0<n : ∀ {m n} → m < n → 0 < n -m<n⇒0<n = ≤-trans 0<1+n - -m<n⇒n≢0 : ∀ {m n} → m < n → n ≢ 0 -m<n⇒n≢0 (s≤s m≤n) () - -m<n⇒m≤1+n : ∀ {m n} → m < n → m ≤ suc n -m<n⇒m≤1+n = m≤n⇒m≤1+n ∘ <⇒≤ - -m<1+n⇒m<n∨m≡n : ∀ {m n} → m < suc n → m < n ⊎ m ≡ n -m<1+n⇒m<n∨m≡n {0} {0} _ = inj₂ refl -m<1+n⇒m<n∨m≡n {0} {suc n} _ = inj₁ 0<1+n -m<1+n⇒m<n∨m≡n {suc m} {suc n} (s<s m<1+n) with m<1+n⇒m<n∨m≡n m<1+n -... | inj₂ m≡n = inj₂ (cong suc m≡n) -... | inj₁ m<n = inj₁ (s<s m<n) - -m≤n⇒m<n∨m≡n : ∀ {m n} → m ≤ n → m < n ⊎ m ≡ n -m≤n⇒m<n∨m≡n m≤n = m<1+n⇒m<n∨m≡n (s≤s m≤n) - -m<1+n⇒m≤n : ∀ {m n} → m < suc n → m ≤ n -m<1+n⇒m≤n (s≤s m≤n) = m≤n - -∀[m≤n⇒m≢o]⇒n<o : ∀ n o → (∀ {m} → m ≤ n → m ≢ o) → n < o -∀[m≤n⇒m≢o]⇒n<o _ zero m≤n⇒n≢0 = contradiction refl (m≤n⇒n≢0 z≤n) -∀[m≤n⇒m≢o]⇒n<o zero (suc o) _ = 0<1+n -∀[m≤n⇒m≢o]⇒n<o (suc n) (suc o) m≤n⇒n≢o = s≤s (∀[m≤n⇒m≢o]⇒n<o n o rec) - where - rec : ∀ {m} → m ≤ n → m ≢ o - rec m≤n refl = m≤n⇒n≢o (s≤s m≤n) refl - -∀[m<n⇒m≢o]⇒n≤o : ∀ n o → (∀ {m} → m < n → m ≢ o) → n ≤ o -∀[m<n⇒m≢o]⇒n≤o zero n _ = z≤n -∀[m<n⇒m≢o]⇒n≤o (suc n) zero m<n⇒m≢0 = contradiction refl (m<n⇒m≢0 0<1+n) -∀[m<n⇒m≢o]⇒n≤o (suc n) (suc o) m<n⇒m≢o = s≤s (∀[m<n⇒m≢o]⇒n≤o n o rec) - where - rec : ∀ {m} → m < n → m ≢ o - rec x<m refl = m<n⇒m≢o (s≤s x<m) refl - ------------------------------------------------------------------------- --- A module for reasoning about the _≤_ and _<_ relations ------------------------------------------------------------------------- - -module ≤-Reasoning where - open import Relation.Binary.Reasoning.Base.Triple - ≤-isPreorder - <-trans - (resp₂ _<_) - <⇒≤ - <-transˡ - <-transʳ - public - hiding (step-≈; step-≈˘) - -open ≤-Reasoning - ------------------------------------------------------------------------- --- Properties of _+_ ------------------------------------------------------------------------- - -+-suc : ∀ m n → m + suc n ≡ suc (m + n) -+-suc zero n = refl -+-suc (suc m) n = cong suc (+-suc m n) - ------------------------------------------------------------------------- --- Algebraic properties of _+_ - -+-assoc : Associative _+_ -+-assoc zero _ _ = refl -+-assoc (suc m) n o = cong suc (+-assoc m n o) - -+-identityˡ : LeftIdentity 0 _+_ -+-identityˡ _ = refl - -+-identityʳ : RightIdentity 0 _+_ -+-identityʳ zero = refl -+-identityʳ (suc n) = cong suc (+-identityʳ n) - -+-identity : Identity 0 _+_ -+-identity = +-identityˡ , +-identityʳ - -+-comm : Commutative _+_ -+-comm zero n = sym (+-identityʳ n) -+-comm (suc m) n = begin-equality - suc m + n ≡⟨⟩ - suc (m + n) ≡⟨ cong suc (+-comm m n) ⟩ - suc (n + m) ≡⟨ sym (+-suc n m) ⟩ - n + suc m ∎ - -+-cancelˡ-≡ : LeftCancellative _≡_ _+_ -+-cancelˡ-≡ zero _ _ eq = eq -+-cancelˡ-≡ (suc m) _ _ eq = +-cancelˡ-≡ m _ _ (cong pred eq) - -+-cancelʳ-≡ : RightCancellative _≡_ _+_ -+-cancelʳ-≡ = comm+cancelˡ⇒cancelʳ +-comm +-cancelˡ-≡ - -+-cancel-≡ : Cancellative _≡_ _+_ -+-cancel-≡ = +-cancelˡ-≡ , +-cancelʳ-≡ - ------------------------------------------------------------------------- --- Structures - -+-isMagma : IsMagma _+_ -+-isMagma = record - { isEquivalence = isEquivalence - ; ∙-cong = cong₂ _+_ - } - -+-isSemigroup : IsSemigroup _+_ -+-isSemigroup = record - { isMagma = +-isMagma - ; assoc = +-assoc - } - -+-isCommutativeSemigroup : IsCommutativeSemigroup _+_ -+-isCommutativeSemigroup = record - { isSemigroup = +-isSemigroup - ; comm = +-comm - } - -+-0-isMonoid : IsMonoid _+_ 0 -+-0-isMonoid = record - { isSemigroup = +-isSemigroup - ; identity = +-identity - } - -+-0-isCommutativeMonoid : IsCommutativeMonoid _+_ 0 -+-0-isCommutativeMonoid = record - { isMonoid = +-0-isMonoid - ; comm = +-comm - } - ------------------------------------------------------------------------- --- Bundles +n≮n : ∀ n → n ≮ n -- implicit? +n≮n n = <-irrefl (refl {x = n}) -+-magma : Magma 0ℓ 0ℓ -+-magma = record - { isMagma = +-isMagma - } +0<1+n : 0 < suc n +0<1+n = z<s -+-semigroup : Semigroup 0ℓ 0ℓ -+-semigroup = record - { isSemigroup = +-isSemigroup - } +n<1+n : ∀ n → n < suc n +n<1+n n = ≤-refl -+-commutativeSemigroup : CommutativeSemigroup 0ℓ 0ℓ -+-commutativeSemigroup = record - { isCommutativeSemigroup = +-isCommutativeSemigroup - } +n<1⇒n≡0 : n < 1 → n ≡ 0 +n<1⇒n≡0 (s≤s n≤0) = n≤0⇒n≡0 n≤0 -+-0-monoid : Monoid 0ℓ 0ℓ -+-0-monoid = record - { isMonoid = +-0-isMonoid - } +n>0⇒n≢0 : n > 0 → n ≢ 0 +n>0⇒n≢0 {suc n} _ () -+-0-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ -+-0-commutativeMonoid = record - { isCommutativeMonoid = +-0-isCommutativeMonoid - } +n≢0⇒n>0 : n ≢ 0 → n > 0 +n≢0⇒n>0 {zero} 0≢0 = contradiction refl 0≢0 +n≢0⇒n>0 {suc n} _ = 0<1+n -∸-magma : Magma 0ℓ 0ℓ -∸-magma = magma _∸_ +m<n⇒0<n : m < n → 0 < n +m<n⇒0<n = ≤-trans 0<1+n + +m<n⇒n≢0 : m < n → n ≢ 0 +m<n⇒n≢0 (s≤s m≤n) () + +m<n⇒m≤1+n : m < n → m ≤ suc n +m<n⇒m≤1+n = m≤n⇒m≤1+n ∘ <⇒≤ + +m<1+n⇒m<n∨m≡n : ∀ {m n} → m < suc n → m < n ⊎ m ≡ n +m<1+n⇒m<n∨m≡n {0} {0} _ = inj₂ refl +m<1+n⇒m<n∨m≡n {0} {suc n} _ = inj₁ 0<1+n +m<1+n⇒m<n∨m≡n {suc m} {suc n} (s<s m<1+n) = Sum.map s<s (cong suc) (m<1+n⇒m<n∨m≡n m<1+n) + +m≤n⇒m<n∨m≡n : m ≤ n → m < n ⊎ m ≡ n +m≤n⇒m<n∨m≡n m≤n = m<1+n⇒m<n∨m≡n (s≤s m≤n) + +m<1+n⇒m≤n : m < suc n → m ≤ n +m<1+n⇒m≤n (s≤s m≤n) = m≤n + +∀[m≤n⇒m≢o]⇒n<o : ∀ n o → (∀ {m} → m ≤ n → m ≢ o) → n < o +∀[m≤n⇒m≢o]⇒n<o _ zero m≤n⇒n≢0 = contradiction refl (m≤n⇒n≢0 z≤n) +∀[m≤n⇒m≢o]⇒n<o zero (suc o) _ = 0<1+n +∀[m≤n⇒m≢o]⇒n<o (suc n) (suc o) m≤n⇒n≢o = s≤s (∀[m≤n⇒m≢o]⇒n<o n o rec) + where + rec : ∀ {m} → m ≤ n → m ≢ o + rec m≤n refl = m≤n⇒n≢o (s≤s m≤n) refl + +∀[m<n⇒m≢o]⇒n≤o : ∀ n o → (∀ {m} → m < n → m ≢ o) → n ≤ o +∀[m<n⇒m≢o]⇒n≤o zero n _ = z≤n +∀[m<n⇒m≢o]⇒n≤o (suc n) zero m<n⇒m≢0 = contradiction refl (m<n⇒m≢0 0<1+n) +∀[m<n⇒m≢o]⇒n≤o (suc n) (suc o) m<n⇒m≢o = s≤s (∀[m<n⇒m≢o]⇒n≤o n o rec) + where + rec : ∀ {m} → m < n → m ≢ o + rec o<n refl = m<n⇒m≢o (s<s o<n) refl + +------------------------------------------------------------------------ +-- A module for reasoning about the _≤_ and _<_ relations +------------------------------------------------------------------------ + +module ≤-Reasoning where + open import Relation.Binary.Reasoning.Base.Triple + ≤-isPreorder + <-asym + <-trans + (resp₂ _<_) + <⇒≤ + <-≤-trans + ≤-<-trans + public + hiding (step-≈; step-≈˘; step-≈-⟩; step-≈-⟨) + +open ≤-Reasoning + +------------------------------------------------------------------------ +-- Properties of _+_ +------------------------------------------------------------------------ + ++-suc : ∀ m n → m + suc n ≡ suc (m + n) ++-suc zero n = refl ++-suc (suc m) n = cong suc (+-suc m n) + +------------------------------------------------------------------------ +-- Algebraic properties of _+_ + ++-assoc : Associative _+_ ++-assoc zero _ _ = refl ++-assoc (suc m) n o = cong suc (+-assoc m n o) + ++-identityˡ : LeftIdentity 0 _+_ ++-identityˡ _ = refl + ++-identityʳ : RightIdentity 0 _+_ ++-identityʳ zero = refl ++-identityʳ (suc n) = cong suc (+-identityʳ n) + ++-identity : Identity 0 _+_ ++-identity = +-identityˡ , +-identityʳ + ++-comm : Commutative _+_ ++-comm zero n = sym (+-identityʳ n) ++-comm (suc m) n = begin-equality + suc m + n ≡⟨⟩ + suc (m + n) ≡⟨ cong suc (+-comm m n) ⟩ + suc (n + m) ≡⟨ sym (+-suc n m) ⟩ + n + suc m ∎ + ++-cancelˡ-≡ : LeftCancellative _≡_ _+_ ++-cancelˡ-≡ zero _ _ eq = eq ++-cancelˡ-≡ (suc m) _ _ eq = +-cancelˡ-≡ m _ _ (cong pred eq) + ++-cancelʳ-≡ : RightCancellative _≡_ _+_ ++-cancelʳ-≡ = comm+cancelˡ⇒cancelʳ +-comm +-cancelˡ-≡ + ++-cancel-≡ : Cancellative _≡_ _+_ ++-cancel-≡ = +-cancelˡ-≡ , +-cancelʳ-≡ + +------------------------------------------------------------------------ +-- Structures + ++-isMagma : IsMagma _+_ ++-isMagma = record + { isEquivalence = isEquivalence + ; ∙-cong = cong₂ _+_ + } + ++-isSemigroup : IsSemigroup _+_ ++-isSemigroup = record + { isMagma = +-isMagma + ; assoc = +-assoc + } + ++-isCommutativeSemigroup : IsCommutativeSemigroup _+_ ++-isCommutativeSemigroup = record + { isSemigroup = +-isSemigroup + ; comm = +-comm + } + ++-0-isMonoid : IsMonoid _+_ 0 ++-0-isMonoid = record + { isSemigroup = +-isSemigroup + ; identity = +-identity + } + ++-0-isCommutativeMonoid : IsCommutativeMonoid _+_ 0 ++-0-isCommutativeMonoid = record + { isMonoid = +-0-isMonoid + ; comm = +-comm + } + +------------------------------------------------------------------------ +-- Bundles ++-magma : Magma 0ℓ 0ℓ ++-magma = record + { isMagma = +-isMagma + } ------------------------------------------------------------------------- --- Other properties of _+_ and _≡_ ++-semigroup : Semigroup 0ℓ 0ℓ ++-semigroup = record + { isSemigroup = +-isSemigroup + } -m≢1+m+n : ∀ m {n} → m ≢ suc (m + n) -m≢1+m+n (suc m) eq = m≢1+m+n m (cong pred eq) ++-commutativeSemigroup : CommutativeSemigroup 0ℓ 0ℓ ++-commutativeSemigroup = record + { isCommutativeSemigroup = +-isCommutativeSemigroup + } -m≢1+n+m : ∀ m {n} → m ≢ suc (n + m) -m≢1+n+m m m≡1+n+m = m≢1+m+n m (trans m≡1+n+m (cong suc (+-comm _ m))) ++-0-monoid : Monoid 0ℓ 0ℓ ++-0-monoid = record + { isMonoid = +-0-isMonoid + } -m+1+n≢m : ∀ m {n} → m + suc n ≢ m -m+1+n≢m (suc m) = (m+1+n≢m m) ∘ suc-injective ++-0-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ ++-0-commutativeMonoid = record + { isCommutativeMonoid = +-0-isCommutativeMonoid + } -m+1+n≢n : ∀ m {n} → m + suc n ≢ n -m+1+n≢n m {n} rewrite +-suc m n = ≢-sym (m≢1+n+m n) +∸-magma : Magma 0ℓ 0ℓ +∸-magma = magma _∸_ -m+1+n≢0 : ∀ m {n} → m + suc n ≢ 0 -m+1+n≢0 m {n} rewrite +-suc m n = λ() -m+n≡0⇒m≡0 : ∀ m {n} → m + n ≡ 0 → m ≡ 0 -m+n≡0⇒m≡0 zero eq = refl +------------------------------------------------------------------------ +-- Other properties of _+_ and _≡_ -m+n≡0⇒n≡0 : ∀ m {n} → m + n ≡ 0 → n ≡ 0 -m+n≡0⇒n≡0 m {n} m+n≡0 = m+n≡0⇒m≡0 n (trans (+-comm n m) (m+n≡0)) +m≢1+m+n : ∀ m {n} → m ≢ suc (m + n) +m≢1+m+n (suc m) eq = m≢1+m+n m (cong pred eq) ------------------------------------------------------------------------- --- Properties of _+_ and _≤_/_<_ +m≢1+n+m : ∀ m {n} → m ≢ suc (n + m) +m≢1+n+m m m≡1+n+m = m≢1+m+n m (trans m≡1+n+m (cong suc (+-comm _ m))) -+-cancelˡ-≤ : LeftCancellative _≤_ _+_ -+-cancelˡ-≤ zero _ _ le = le -+-cancelˡ-≤ (suc m) _ _ (s≤s le) = +-cancelˡ-≤ m _ _ le +m+1+n≢m : ∀ m {n} → m + suc n ≢ m +m+1+n≢m (suc m) = (m+1+n≢m m) ∘ suc-injective -+-cancelʳ-≤ : RightCancellative _≤_ _+_ -+-cancelʳ-≤ m n o le = - +-cancelˡ-≤ m _ _ (subst₂ _≤_ (+-comm n m) (+-comm o m) le) +m+1+n≢n : ∀ m {n} → m + suc n ≢ n +m+1+n≢n m {n} rewrite +-suc m n = ≢-sym (m≢1+n+m n) -+-cancel-≤ : Cancellative _≤_ _+_ -+-cancel-≤ = +-cancelˡ-≤ , +-cancelʳ-≤ +m+1+n≢0 : ∀ m {n} → m + suc n ≢ 0 +m+1+n≢0 m {n} rewrite +-suc m n = λ() -+-cancelˡ-< : LeftCancellative _<_ _+_ -+-cancelˡ-< m n o = +-cancelˡ-≤ m (suc n) o ∘ subst (_≤ m + o) (sym (+-suc m n)) +m+n≡0⇒m≡0 : ∀ m {n} → m + n ≡ 0 → m ≡ 0 +m+n≡0⇒m≡0 zero eq = refl -+-cancelʳ-< : RightCancellative _<_ _+_ -+-cancelʳ-< m n o n+m<o+m = +-cancelʳ-≤ m (suc n) o n+m<o+m +m+n≡0⇒n≡0 : ∀ m {n} → m + n ≡ 0 → n ≡ 0 +m+n≡0⇒n≡0 m {n} m+n≡0 = m+n≡0⇒m≡0 n (trans (+-comm n m) (m+n≡0)) -+-cancel-< : Cancellative _<_ _+_ -+-cancel-< = +-cancelˡ-< , +-cancelʳ-< +------------------------------------------------------------------------ +-- Properties of _+_ and _≤_/_<_ -m≤n⇒m≤o+n : ∀ {m n} o → m ≤ n → m ≤ o + n -m≤n⇒m≤o+n zero m≤n = m≤n -m≤n⇒m≤o+n (suc o) m≤n = m≤n⇒m≤1+n (m≤n⇒m≤o+n o m≤n) ++-cancelˡ-≤ : LeftCancellative _≤_ _+_ ++-cancelˡ-≤ zero _ _ le = le ++-cancelˡ-≤ (suc m) _ _ (s≤s le) = +-cancelˡ-≤ m _ _ le -m≤n⇒m≤n+o : ∀ {m n} o → m ≤ n → m ≤ n + o -m≤n⇒m≤n+o {m} o m≤n = subst (m ≤_) (+-comm o _) (m≤n⇒m≤o+n o m≤n) ++-cancelʳ-≤ : RightCancellative _≤_ _+_ ++-cancelʳ-≤ m n o le = + +-cancelˡ-≤ m _ _ (subst₂ _≤_ (+-comm n m) (+-comm o m) le) -m≤m+n : ∀ m n → m ≤ m + n -m≤m+n zero n = z≤n -m≤m+n (suc m) n = s≤s (m≤m+n m n) ++-cancel-≤ : Cancellative _≤_ _+_ ++-cancel-≤ = +-cancelˡ-≤ , +-cancelʳ-≤ -m≤n+m : ∀ m n → m ≤ n + m -m≤n+m m n = subst (m ≤_) (+-comm m n) (m≤m+n m n) ++-cancelˡ-< : LeftCancellative _<_ _+_ ++-cancelˡ-< m n o = +-cancelˡ-≤ m (suc n) o ∘ subst (_≤ m + o) (sym (+-suc m n)) -m+n≤o⇒m≤o : ∀ m {n o} → m + n ≤ o → m ≤ o -m+n≤o⇒m≤o zero m+n≤o = z≤n -m+n≤o⇒m≤o (suc m) (s≤s m+n≤o) = s≤s (m+n≤o⇒m≤o m m+n≤o) ++-cancelʳ-< : RightCancellative _<_ _+_ ++-cancelʳ-< m n o n+m<o+m = +-cancelʳ-≤ m (suc n) o n+m<o+m -m+n≤o⇒n≤o : ∀ m {n o} → m + n ≤ o → n ≤ o -m+n≤o⇒n≤o zero n≤o = n≤o -m+n≤o⇒n≤o (suc m) m+n<o = m+n≤o⇒n≤o m (<⇒≤ m+n<o) ++-cancel-< : Cancellative _<_ _+_ ++-cancel-< = +-cancelˡ-< , +-cancelʳ-< -+-mono-≤ : _+_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ -+-mono-≤ {_} {m} z≤n o≤p = ≤-trans o≤p (m≤n+m _ m) -+-mono-≤ {_} {_} (s≤s m≤n) o≤p = s≤s (+-mono-≤ m≤n o≤p) +m≤n⇒m≤o+n : ∀ o → m ≤ n → m ≤ o + n +m≤n⇒m≤o+n zero m≤n = m≤n +m≤n⇒m≤o+n (suc o) m≤n = m≤n⇒m≤1+n (m≤n⇒m≤o+n o m≤n) -+-monoˡ-≤ : ∀ n → (_+ n) Preserves _≤_ ⟶ _≤_ -+-monoˡ-≤ n m≤o = +-mono-≤ m≤o (≤-refl {n}) +m≤n⇒m≤n+o : ∀ o → m ≤ n → m ≤ n + o +m≤n⇒m≤n+o {m} o m≤n = subst (m ≤_) (+-comm o _) (m≤n⇒m≤o+n o m≤n) -+-monoʳ-≤ : ∀ n → (n +_) Preserves _≤_ ⟶ _≤_ -+-monoʳ-≤ n m≤o = +-mono-≤ (≤-refl {n}) m≤o +m≤m+n : ∀ m n → m ≤ m + n +m≤m+n zero n = z≤n +m≤m+n (suc m) n = s≤s (m≤m+n m n) -+-mono-<-≤ : _+_ Preserves₂ _<_ ⟶ _≤_ ⟶ _<_ -+-mono-<-≤ {_} {suc n} z<s o≤p = s≤s (m≤n⇒m≤o+n n o≤p) -+-mono-<-≤ {_} {_} (s<s m<n@(s≤s _)) o≤p = s≤s (+-mono-<-≤ m<n o≤p) +m≤n+m : ∀ m n → m ≤ n + m +m≤n+m m n = subst (m ≤_) (+-comm m n) (m≤m+n m n) -+-mono-≤-< : _+_ Preserves₂ _≤_ ⟶ _<_ ⟶ _<_ -+-mono-≤-< {_} {n} z≤n o<p = ≤-trans o<p (m≤n+m _ n) -+-mono-≤-< {_} {_} (s≤s m≤n) o<p = s≤s (+-mono-≤-< m≤n o<p) +m+n≤o⇒m≤o : ∀ m {n o} → m + n ≤ o → m ≤ o +m+n≤o⇒m≤o zero m+n≤o = z≤n +m+n≤o⇒m≤o (suc m) (s≤s m+n≤o) = s≤s (m+n≤o⇒m≤o m m+n≤o) -+-mono-< : _+_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_ -+-mono-< m≤n = +-mono-≤-< (<⇒≤ m≤n) +m+n≤o⇒n≤o : ∀ m {n o} → m + n ≤ o → n ≤ o +m+n≤o⇒n≤o zero n≤o = n≤o +m+n≤o⇒n≤o (suc m) m+n<o = m+n≤o⇒n≤o m (<⇒≤ m+n<o) -+-monoˡ-< : ∀ n → (_+ n) Preserves _<_ ⟶ _<_ -+-monoˡ-< n = +-monoˡ-≤ n ++-mono-≤ : _+_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ ++-mono-≤ {_} {m} z≤n o≤p = ≤-trans o≤p (m≤n+m _ m) ++-mono-≤ {_} {_} (s≤s m≤n) o≤p = s≤s (+-mono-≤ m≤n o≤p) -+-monoʳ-< : ∀ n → (n +_) Preserves _<_ ⟶ _<_ -+-monoʳ-< zero m≤o = m≤o -+-monoʳ-< (suc n) m≤o = s≤s (+-monoʳ-< n m≤o) ++-monoˡ-≤ : ∀ n → (_+ n) Preserves _≤_ ⟶ _≤_ ++-monoˡ-≤ n m≤o = +-mono-≤ m≤o (≤-refl {n}) -m+1+n≰m : ∀ m {n} → m + suc n ≰ m -m+1+n≰m (suc m) (s≤s m+1+n≤m) = m+1+n≰m m m+1+n≤m ++-monoʳ-≤ : ∀ n → (n +_) Preserves _≤_ ⟶ _≤_ ++-monoʳ-≤ n m≤o = +-mono-≤ (≤-refl {n}) m≤o -m<m+n : ∀ m {n} → n > 0 → m < m + n -m<m+n zero n>0 = n>0 -m<m+n (suc m) n>0 = s<s (m<m+n m n>0) ++-mono-<-≤ : _+_ Preserves₂ _<_ ⟶ _≤_ ⟶ _<_ ++-mono-<-≤ {_} {suc n} z<s o≤p = s≤s (m≤n⇒m≤o+n n o≤p) ++-mono-<-≤ {_} {_} (s<s m<n@(s≤s _)) o≤p = s≤s (+-mono-<-≤ m<n o≤p) -m<n+m : ∀ m {n} → n > 0 → m < n + m -m<n+m m {n} n>0 rewrite +-comm n m = m<m+n m n>0 ++-mono-≤-< : _+_ Preserves₂ _≤_ ⟶ _<_ ⟶ _<_ ++-mono-≤-< {_} {n} z≤n o<p = ≤-trans o<p (m≤n+m _ n) ++-mono-≤-< {_} {_} (s≤s m≤n) o<p = s≤s (+-mono-≤-< m≤n o<p) -m+n≮n : ∀ m n → m + n ≮ n -m+n≮n zero n = n≮n n -m+n≮n (suc m) (suc n) (s<s m+n<n) = m+n≮n m (suc n) (m<n⇒m<1+n m+n<n) - -m+n≮m : ∀ m n → m + n ≮ m -m+n≮m m n = subst (_≮ m) (+-comm n m) (m+n≮n n m) - ------------------------------------------------------------------------- --- Properties of _*_ ------------------------------------------------------------------------- - -*-suc : ∀ m n → m * suc n ≡ m + m * n -*-suc zero n = refl -*-suc (suc m) n = begin-equality - suc m * suc n ≡⟨⟩ - suc n + m * suc n ≡⟨ cong (suc n +_) (*-suc m n) ⟩ - suc n + (m + m * n) ≡⟨⟩ - suc (n + (m + m * n)) ≡⟨ cong suc (sym (+-assoc n m (m * n))) ⟩ - suc (n + m + m * n) ≡⟨ cong (λ x → suc (x + m * n)) (+-comm n m) ⟩ - suc (m + n + m * n) ≡⟨ cong suc (+-assoc m n (m * n)) ⟩ - suc (m + (n + m * n)) ≡⟨⟩ - suc m + suc m * n ∎ - ------------------------------------------------------------------------- --- Algebraic properties of _*_ - -*-identityˡ : LeftIdentity 1 _*_ -*-identityˡ n = +-identityʳ n - -*-identityʳ : RightIdentity 1 _*_ -*-identityʳ zero = refl -*-identityʳ (suc n) = cong suc (*-identityʳ n) - -*-identity : Identity 1 _*_ -*-identity = *-identityˡ , *-identityʳ - -*-zeroˡ : LeftZero 0 _*_ -*-zeroˡ _ = refl - -*-zeroʳ : RightZero 0 _*_ -*-zeroʳ zero = refl -*-zeroʳ (suc n) = *-zeroʳ n - -*-zero : Zero 0 _*_ -*-zero = *-zeroˡ , *-zeroʳ - -*-comm : Commutative _*_ -*-comm zero n = sym (*-zeroʳ n) -*-comm (suc m) n = begin-equality - suc m * n ≡⟨⟩ - n + m * n ≡⟨ cong (n +_) (*-comm m n) ⟩ - n + n * m ≡⟨ sym (*-suc n m) ⟩ - n * suc m ∎ - -*-distribʳ-+ : _*_ DistributesOverʳ _+_ -*-distribʳ-+ m zero o = refl -*-distribʳ-+ m (suc n) o = begin-equality - (suc n + o) * m ≡⟨⟩ - m + (n + o) * m ≡⟨ cong (m +_) (*-distribʳ-+ m n o) ⟩ - m + (n * m + o * m) ≡⟨ sym (+-assoc m (n * m) (o * m)) ⟩ - m + n * m + o * m ≡⟨⟩ - suc n * m + o * m ∎ - -*-distribˡ-+ : _*_ DistributesOverˡ _+_ -*-distribˡ-+ = comm+distrʳ⇒distrˡ *-comm *-distribʳ-+ - -*-distrib-+ : _*_ DistributesOver _+_ -*-distrib-+ = *-distribˡ-+ , *-distribʳ-+ - -*-assoc : Associative _*_ -*-assoc zero n o = refl -*-assoc (suc m) n o = begin-equality - (suc m * n) * o ≡⟨⟩ - (n + m * n) * o ≡⟨ *-distribʳ-+ o n (m * n) ⟩ - n * o + (m * n) * o ≡⟨ cong (n * o +_) (*-assoc m n o) ⟩ - n * o + m * (n * o) ≡⟨⟩ - suc m * (n * o) ∎ - ------------------------------------------------------------------------- --- Structures - -*-isMagma : IsMagma _*_ -*-isMagma = record - { isEquivalence = isEquivalence - ; ∙-cong = cong₂ _*_ - } - -*-isSemigroup : IsSemigroup _*_ -*-isSemigroup = record - { isMagma = *-isMagma - ; assoc = *-assoc - } - -*-isCommutativeSemigroup : IsCommutativeSemigroup _*_ -*-isCommutativeSemigroup = record - { isSemigroup = *-isSemigroup - ; comm = *-comm - } - -*-1-isMonoid : IsMonoid _*_ 1 -*-1-isMonoid = record - { isSemigroup = *-isSemigroup - ; identity = *-identity - } - -*-1-isCommutativeMonoid : IsCommutativeMonoid _*_ 1 -*-1-isCommutativeMonoid = record - { isMonoid = *-1-isMonoid - ; comm = *-comm - } - -+-*-isSemiring : IsSemiring _+_ _*_ 0 1 -+-*-isSemiring = record - { isSemiringWithoutAnnihilatingZero = record - { +-isCommutativeMonoid = +-0-isCommutativeMonoid - ; *-cong = cong₂ _*_ - ; *-assoc = *-assoc - ; *-identity = *-identity - ; distrib = *-distrib-+ - } - ; zero = *-zero - } - -+-*-isCommutativeSemiring : IsCommutativeSemiring _+_ _*_ 0 1 -+-*-isCommutativeSemiring = record - { isSemiring = +-*-isSemiring - ; *-comm = *-comm - } - ------------------------------------------------------------------------- --- Bundles - -*-magma : Magma 0ℓ 0ℓ -*-magma = record - { isMagma = *-isMagma - } - -*-semigroup : Semigroup 0ℓ 0ℓ -*-semigroup = record - { isSemigroup = *-isSemigroup - } - -*-commutativeSemigroup : CommutativeSemigroup 0ℓ 0ℓ -*-commutativeSemigroup = record - { isCommutativeSemigroup = *-isCommutativeSemigroup - } - -*-1-monoid : Monoid 0ℓ 0ℓ -*-1-monoid = record - { isMonoid = *-1-isMonoid - } - -*-1-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ -*-1-commutativeMonoid = record - { isCommutativeMonoid = *-1-isCommutativeMonoid - } - -+-*-semiring : Semiring 0ℓ 0ℓ -+-*-semiring = record - { isSemiring = +-*-isSemiring - } - -+-*-commutativeSemiring : CommutativeSemiring 0ℓ 0ℓ -+-*-commutativeSemiring = record - { isCommutativeSemiring = +-*-isCommutativeSemiring - } - ------------------------------------------------------------------------- --- Other properties of _*_ and _≡_ - -*-cancelʳ-≡ : ∀ m n o .{{_ : NonZero o}} → m * o ≡ n * o → m ≡ n -*-cancelʳ-≡ zero zero (suc o) eq = refl -*-cancelʳ-≡ (suc m) (suc n) (suc o) eq = - cong suc (*-cancelʳ-≡ m n (suc o) (+-cancelˡ-≡ (suc o) (m * suc o) (n * suc o) eq)) - -*-cancelˡ-≡ : ∀ m n o .{{_ : NonZero o}} → o * m ≡ o * n → m ≡ n -*-cancelˡ-≡ m n o rewrite *-comm o m | *-comm o n = *-cancelʳ-≡ m n o - -m*n≡0⇒m≡0∨n≡0 : ∀ m {n} → m * n ≡ 0 → m ≡ 0 ⊎ n ≡ 0 -m*n≡0⇒m≡0∨n≡0 zero {n} eq = inj₁ refl -m*n≡0⇒m≡0∨n≡0 (suc m) {zero} eq = inj₂ refl - -m*n≢0 : ∀ m n → .{{_ : NonZero m}} .{{_ : NonZero n}} → NonZero (m * n) -m*n≢0 (suc m) (suc n) = _ - -m*n≡0⇒m≡0 : ∀ m n .{{_ : NonZero n}} → m * n ≡ 0 → m ≡ 0 -m*n≡0⇒m≡0 zero (suc _) eq = refl - -m*n≡1⇒m≡1 : ∀ m n → m * n ≡ 1 → m ≡ 1 -m*n≡1⇒m≡1 (suc zero) n _ = refl -m*n≡1⇒m≡1 (suc (suc m)) (suc zero) () -m*n≡1⇒m≡1 (suc (suc m)) zero eq = - contradiction (trans (sym $ *-zeroʳ m) eq) λ() - -m*n≡1⇒n≡1 : ∀ m n → m * n ≡ 1 → n ≡ 1 -m*n≡1⇒n≡1 m n eq = m*n≡1⇒m≡1 n m (trans (*-comm n m) eq) - -[m*n]*[o*p]≡[m*o]*[n*p] : ∀ m n o p → (m * n) * (o * p) ≡ (m * o) * (n * p) -[m*n]*[o*p]≡[m*o]*[n*p] m n o p = begin-equality - (m * n) * (o * p) ≡⟨ *-assoc m n (o * p) ⟩ - m * (n * (o * p)) ≡⟨ cong (m *_) (x∙yz≈y∙xz n o p) ⟩ - m * (o * (n * p)) ≡˘⟨ *-assoc m o (n * p) ⟩ - (m * o) * (n * p) ∎ - where open CommSemigroupProperties *-commutativeSemigroup - ------------------------------------------------------------------------- --- Other properties of _*_ and _≤_/_<_ - -*-cancelʳ-≤ : ∀ m n o .{{_ : NonZero o}} → m * o ≤ n * o → m ≤ n -*-cancelʳ-≤ zero _ (suc o) _ = z≤n -*-cancelʳ-≤ (suc m) (suc n) (suc o) le = - s≤s (*-cancelʳ-≤ m n (suc o) (+-cancelˡ-≤ _ _ _ le)) - -*-cancelˡ-≤ : ∀ {m n} o .{{_ : NonZero o}} → o * m ≤ o * n → m ≤ n -*-cancelˡ-≤ {m} {n} o rewrite *-comm o m | *-comm o n = *-cancelʳ-≤ m n o - -*-mono-≤ : _*_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ -*-mono-≤ z≤n _ = z≤n -*-mono-≤ (s≤s m≤n) u≤v = +-mono-≤ u≤v (*-mono-≤ m≤n u≤v) - -*-monoˡ-≤ : ∀ n → (_* n) Preserves _≤_ ⟶ _≤_ -*-monoˡ-≤ n m≤o = *-mono-≤ m≤o (≤-refl {n}) - -*-monoʳ-≤ : ∀ n → (n *_) Preserves _≤_ ⟶ _≤_ -*-monoʳ-≤ n m≤o = *-mono-≤ (≤-refl {n}) m≤o - -*-mono-< : _*_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_ -*-mono-< z<s u<v@(s≤s _) = 0<1+n -*-mono-< (s<s m<n@(s≤s _)) u<v@(s≤s _) = +-mono-< u<v (*-mono-< m<n u<v) - -*-monoˡ-< : ∀ n .{{_ : NonZero n}} → (_* n) Preserves _<_ ⟶ _<_ -*-monoˡ-< (suc n) z<s = 0<1+n -*-monoˡ-< (suc n) (s<s m<o@(s≤s _)) = - +-mono-≤-< (≤-refl {suc n}) (*-monoˡ-< (suc n) m<o) - -*-monoʳ-< : ∀ n .{{_ : NonZero n}} → (n *_) Preserves _<_ ⟶ _<_ -*-monoʳ-< (suc zero) m<o@(s≤s _) = +-mono-≤ m<o z≤n -*-monoʳ-< (suc n@(suc _)) m<o@(s≤s _) = - +-mono-≤ m<o (<⇒≤ (*-monoʳ-< n m<o)) - -m≤m*n : ∀ m n .{{_ : NonZero n}} → m ≤ m * n -m≤m*n m n@(suc _) = begin - m ≡⟨ sym (*-identityʳ m) ⟩ - m * 1 ≤⟨ *-monoʳ-≤ m 0<1+n ⟩ - m * n ∎ - -m≤n*m : ∀ m n .{{_ : NonZero n}} → m ≤ n * m -m≤n*m m n@(suc _) = begin - m ≤⟨ m≤m*n m n ⟩ - m * n ≡⟨ *-comm m n ⟩ - n * m ∎ - -m<m*n : ∀ m n .{{_ : NonZero m}} → 1 < n → m < m * n -m<m*n m@(suc m-1) n@(suc (suc n-2)) (s≤s (s≤s _)) = begin-strict - m <⟨ s≤s (s≤s (m≤n+m m-1 n-2)) ⟩ - n + m-1 ≤⟨ +-monoʳ-≤ n (m≤m*n m-1 n) ⟩ - n + m-1 * n ≡⟨⟩ - m * n ∎ - -m<n⇒m<n*o : ∀ {m n} o .{{_ : NonZero o}} → m < n → m < n * o -m<n⇒m<n*o {m} {n} o m<n = <-transˡ m<n (m≤m*n n o) - -m<n⇒m<o*n : ∀ {m n} o .{{_ : NonZero o}} → m < n → m < o * n -m<n⇒m<o*n {m} {n} o m<n = begin-strict - m <⟨ m<n⇒m<n*o o m<n ⟩ - n * o ≡⟨ *-comm n o ⟩ - o * n ∎ - -*-cancelʳ-< : RightCancellative _<_ _*_ -*-cancelʳ-< zero zero (suc o) _ = 0<1+n -*-cancelʳ-< (suc m) zero (suc o) _ = 0<1+n -*-cancelʳ-< m (suc n) (suc o) nm<om = - s≤s (*-cancelʳ-< m n o (+-cancelˡ-< m _ _ nm<om)) - -*-cancelˡ-< : LeftCancellative _<_ _*_ -*-cancelˡ-< x y z rewrite *-comm x y | *-comm x z = *-cancelʳ-< x y z - -*-cancel-< : Cancellative _<_ _*_ -*-cancel-< = *-cancelˡ-< , *-cancelʳ-< - ------------------------------------------------------------------------- --- Properties of _^_ ------------------------------------------------------------------------- - -^-identityʳ : RightIdentity 1 _^_ -^-identityʳ zero = refl -^-identityʳ (suc n) = cong suc (^-identityʳ n) - -^-zeroˡ : LeftZero 1 _^_ -^-zeroˡ zero = refl -^-zeroˡ (suc n) = begin-equality - 1 ^ suc n ≡⟨⟩ - 1 * (1 ^ n) ≡⟨ *-identityˡ (1 ^ n) ⟩ - 1 ^ n ≡⟨ ^-zeroˡ n ⟩ - 1 ∎ - -^-distribˡ-+-* : ∀ m n o → m ^ (n + o) ≡ m ^ n * m ^ o -^-distribˡ-+-* m zero o = sym (+-identityʳ (m ^ o)) -^-distribˡ-+-* m (suc n) o = begin-equality - m * (m ^ (n + o)) ≡⟨ cong (m *_) (^-distribˡ-+-* m n o) ⟩ - m * ((m ^ n) * (m ^ o)) ≡⟨ sym (*-assoc m _ _) ⟩ - (m * (m ^ n)) * (m ^ o) ∎ - -^-semigroup-morphism : ∀ {n} → (n ^_) Is +-semigroup -Semigroup⟶ *-semigroup -^-semigroup-morphism = record - { ⟦⟧-cong = cong (_ ^_) - ; ∙-homo = ^-distribˡ-+-* _ - } - -^-monoid-morphism : ∀ {n} → (n ^_) Is +-0-monoid -Monoid⟶ *-1-monoid -^-monoid-morphism = record - { sm-homo = ^-semigroup-morphism - ; ε-homo = refl - } - -^-*-assoc : ∀ m n o → (m ^ n) ^ o ≡ m ^ (n * o) -^-*-assoc m n zero = cong (m ^_) (sym $ *-zeroʳ n) -^-*-assoc m n (suc o) = begin-equality - (m ^ n) * ((m ^ n) ^ o) ≡⟨ cong ((m ^ n) *_) (^-*-assoc m n o) ⟩ - (m ^ n) * (m ^ (n * o)) ≡⟨ sym (^-distribˡ-+-* m n (n * o)) ⟩ - m ^ (n + n * o) ≡⟨ cong (m ^_) (sym (*-suc n o)) ⟩ - m ^ (n * (suc o)) ∎ - -m^n≡0⇒m≡0 : ∀ m n → m ^ n ≡ 0 → m ≡ 0 -m^n≡0⇒m≡0 m (suc n) eq = [ id , m^n≡0⇒m≡0 m n ]′ (m*n≡0⇒m≡0∨n≡0 m eq) - -m^n≡1⇒n≡0∨m≡1 : ∀ m n → m ^ n ≡ 1 → n ≡ 0 ⊎ m ≡ 1 -m^n≡1⇒n≡0∨m≡1 m zero _ = inj₁ refl -m^n≡1⇒n≡0∨m≡1 m (suc n) eq = inj₂ (m*n≡1⇒m≡1 m (m ^ n) eq) - -m^n≢0 : ∀ m n .{{_ : NonZero m}} → NonZero (m ^ n) -m^n≢0 m n = ≢-nonZero (≢-nonZero⁻¹ m ∘′ m^n≡0⇒m≡0 m n) - -m^n>0 : ∀ m .{{_ : NonZero m}} n → m ^ n > 0 -m^n>0 m n = >-nonZero⁻¹ (m ^ n) {{m^n≢0 m n}} - -^-monoˡ-≤ : ∀ n → (_^ n) Preserves _≤_ ⟶ _≤_ -^-monoˡ-≤ zero m≤o = s≤s z≤n -^-monoˡ-≤ (suc n) m≤o = *-mono-≤ m≤o (^-monoˡ-≤ n m≤o) - -^-monoʳ-≤ : ∀ m .{{_ : NonZero m}} → (m ^_) Preserves _≤_ ⟶ _≤_ -^-monoʳ-≤ m {_} {o} z≤n = n≢0⇒n>0 (≢-nonZero⁻¹ (m ^ o) {{m^n≢0 m o}}) -^-monoʳ-≤ m (s≤s n≤o) = *-monoʳ-≤ m (^-monoʳ-≤ m n≤o) - -^-monoˡ-< : ∀ n .{{_ : NonZero n}} → (_^ n) Preserves _<_ ⟶ _<_ -^-monoˡ-< (suc zero) m<o = *-monoˡ-< 1 m<o -^-monoˡ-< (suc n@(suc _)) m<o = *-mono-< m<o (^-monoˡ-< n m<o) - -^-monoʳ-< : ∀ m → 1 < m → (m ^_) Preserves _<_ ⟶ _<_ -^-monoʳ-< m@(suc _) 1<m {zero} {suc o} z<s = *-mono-≤ 1<m (m^n>0 m o) -^-monoʳ-< m@(suc _) 1<m {suc n} {suc o} (s<s n<o) = *-monoʳ-< m (^-monoʳ-< m 1<m n<o) - ------------------------------------------------------------------------- --- Properties of _⊓_ and _⊔_ ------------------------------------------------------------------------- --- Basic specification in terms of _≤_ - -m≤n⇒m⊔n≡n : ∀ {m n} → m ≤ n → m ⊔ n ≡ n -m≤n⇒m⊔n≡n {zero} _ = refl -m≤n⇒m⊔n≡n {suc m} (s≤s m≤n) = cong suc (m≤n⇒m⊔n≡n m≤n) - -m≥n⇒m⊔n≡m : ∀ {m n} → m ≥ n → m ⊔ n ≡ m -m≥n⇒m⊔n≡m {zero} {zero} z≤n = refl -m≥n⇒m⊔n≡m {suc m} {zero} z≤n = refl -m≥n⇒m⊔n≡m {suc m} {suc n} (s≤s m≥n) = cong suc (m≥n⇒m⊔n≡m m≥n) - -m≤n⇒m⊓n≡m : ∀ {m n} → m ≤ n → m ⊓ n ≡ m -m≤n⇒m⊓n≡m {zero} z≤n = refl -m≤n⇒m⊓n≡m {suc m} (s≤s m≤n) = cong suc (m≤n⇒m⊓n≡m m≤n) - -m≥n⇒m⊓n≡n : ∀ {m n} → m ≥ n → m ⊓ n ≡ n -m≥n⇒m⊓n≡n {zero} {zero} z≤n = refl -m≥n⇒m⊓n≡n {suc m} {zero} z≤n = refl -m≥n⇒m⊓n≡n {suc m} {suc n} (s≤s m≤n) = cong suc (m≥n⇒m⊓n≡n m≤n) - -⊓-operator : MinOperator ≤-totalPreorder -⊓-operator = record - { x≤y⇒x⊓y≈x = m≤n⇒m⊓n≡m - ; x≥y⇒x⊓y≈y = m≥n⇒m⊓n≡n - } - -⊔-operator : MaxOperator ≤-totalPreorder -⊔-operator = record - { x≤y⇒x⊔y≈y = m≤n⇒m⊔n≡n - ; x≥y⇒x⊔y≈x = m≥n⇒m⊔n≡m - } - ------------------------------------------------------------------------- --- Equality to their counterparts defined in terms of primitive operations - -⊔≡⊔′ : ∀ m n → m ⊔ n ≡ m ⊔′ n -⊔≡⊔′ m n with m <ᵇ n in eq -... | false = m≥n⇒m⊔n≡m (≮⇒≥ (λ m<n → subst T eq (<⇒<ᵇ m<n))) -... | true = m≤n⇒m⊔n≡n (<⇒≤ (<ᵇ⇒< m n (subst T (sym eq) _))) - -⊓≡⊓′ : ∀ m n → m ⊓ n ≡ m ⊓′ n -⊓≡⊓′ m n with m <ᵇ n in eq -... | false = m≥n⇒m⊓n≡n (≮⇒≥ (λ m<n → subst T eq (<⇒<ᵇ m<n))) -... | true = m≤n⇒m⊓n≡m (<⇒≤ (<ᵇ⇒< m n (subst T (sym eq) _))) - ------------------------------------------------------------------------- --- Derived properties of _⊓_ and _⊔_ - -private - module ⊓-⊔-properties = MinMaxOp ⊓-operator ⊔-operator - module ⊓-⊔-latticeProperties = LatticeMinMaxOp ⊓-operator ⊔-operator - -open ⊓-⊔-properties public - using - ( ⊓-idem -- : Idempotent _⊓_ - ; ⊓-sel -- : Selective _⊓_ - ; ⊓-assoc -- : Associative _⊓_ - ; ⊓-comm -- : Commutative _⊓_ - - ; ⊔-idem -- : Idempotent _⊔_ - ; ⊔-sel -- : Selective _⊔_ - ; ⊔-assoc -- : Associative _⊔_ - ; ⊔-comm -- : Commutative _⊔_ - - ; ⊓-distribˡ-⊔ -- : _⊓_ DistributesOverˡ _⊔_ - ; ⊓-distribʳ-⊔ -- : _⊓_ DistributesOverʳ _⊔_ - ; ⊓-distrib-⊔ -- : _⊓_ DistributesOver _⊔_ - ; ⊔-distribˡ-⊓ -- : _⊔_ DistributesOverˡ _⊓_ - ; ⊔-distribʳ-⊓ -- : _⊔_ DistributesOverʳ _⊓_ - ; ⊔-distrib-⊓ -- : _⊔_ DistributesOver _⊓_ - ; ⊓-absorbs-⊔ -- : _⊓_ Absorbs _⊔_ - ; ⊔-absorbs-⊓ -- : _⊔_ Absorbs _⊓_ - ; ⊔-⊓-absorptive -- : Absorptive _⊔_ _⊓_ - ; ⊓-⊔-absorptive -- : Absorptive _⊓_ _⊔_ - - ; ⊓-isMagma -- : IsMagma _⊓_ - ; ⊓-isSemigroup -- : IsSemigroup _⊓_ - ; ⊓-isCommutativeSemigroup -- : IsCommutativeSemigroup _⊓_ - ; ⊓-isBand -- : IsBand _⊓_ - ; ⊓-isSelectiveMagma -- : IsSelectiveMagma _⊓_ - - ; ⊔-isMagma -- : IsMagma _⊔_ - ; ⊔-isSemigroup -- : IsSemigroup _⊔_ - ; ⊔-isCommutativeSemigroup -- : IsCommutativeSemigroup _⊔_ - ; ⊔-isBand -- : IsBand _⊔_ - ; ⊔-isSelectiveMagma -- : IsSelectiveMagma _⊔_ - - ; ⊓-magma -- : Magma _ _ - ; ⊓-semigroup -- : Semigroup _ _ - ; ⊓-band -- : Band _ _ - ; ⊓-commutativeSemigroup -- : CommutativeSemigroup _ _ - ; ⊓-selectiveMagma -- : SelectiveMagma _ _ - - ; ⊔-magma -- : Magma _ _ - ; ⊔-semigroup -- : Semigroup _ _ - ; ⊔-band -- : Band _ _ - ; ⊔-commutativeSemigroup -- : CommutativeSemigroup _ _ - ; ⊔-selectiveMagma -- : SelectiveMagma _ _ - - ; ⊓-glb -- : ∀ {m n o} → m ≥ o → n ≥ o → m ⊓ n ≥ o - ; ⊓-triangulate -- : ∀ m n o → m ⊓ n ⊓ o ≡ (m ⊓ n) ⊓ (n ⊓ o) - ; ⊓-mono-≤ -- : _⊓_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ - ; ⊓-monoˡ-≤ -- : ∀ n → (_⊓ n) Preserves _≤_ ⟶ _≤_ - ; ⊓-monoʳ-≤ -- : ∀ n → (n ⊓_) Preserves _≤_ ⟶ _≤_ - - ; ⊔-lub -- : ∀ {m n o} → m ≤ o → n ≤ o → m ⊔ n ≤ o - ; ⊔-triangulate -- : ∀ m n o → m ⊔ n ⊔ o ≡ (m ⊔ n) ⊔ (n ⊔ o) - ; ⊔-mono-≤ -- : _⊔_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ - ; ⊔-monoˡ-≤ -- : ∀ n → (_⊔ n) Preserves _≤_ ⟶ _≤_ - ; ⊔-monoʳ-≤ -- : ∀ n → (n ⊔_) Preserves _≤_ ⟶ _≤_ - ) - renaming - ( x⊓y≈y⇒y≤x to m⊓n≡n⇒n≤m -- : ∀ {m n} → m ⊓ n ≡ n → n ≤ m - ; x⊓y≈x⇒x≤y to m⊓n≡m⇒m≤n -- : ∀ {m n} → m ⊓ n ≡ m → m ≤ n - ; x⊓y≤x to m⊓n≤m -- : ∀ m n → m ⊓ n ≤ m - ; x⊓y≤y to m⊓n≤n -- : ∀ m n → m ⊓ n ≤ n - ; x≤y⇒x⊓z≤y to m≤n⇒m⊓o≤n -- : ∀ {m n} o → m ≤ n → m ⊓ o ≤ n - ; x≤y⇒z⊓x≤y to m≤n⇒o⊓m≤n -- : ∀ {m n} o → m ≤ n → o ⊓ m ≤ n - ; x≤y⊓z⇒x≤y to m≤n⊓o⇒m≤n -- : ∀ {m} n o → m ≤ n ⊓ o → m ≤ n - ; x≤y⊓z⇒x≤z to m≤n⊓o⇒m≤o -- : ∀ {m} n o → m ≤ n ⊓ o → m ≤ o - - ; x⊔y≈y⇒x≤y to m⊔n≡n⇒m≤n -- : ∀ {m n} → m ⊔ n ≡ n → m ≤ n - ; x⊔y≈x⇒y≤x to m⊔n≡m⇒n≤m -- : ∀ {m n} → m ⊔ n ≡ m → n ≤ m - ; x≤x⊔y to m≤m⊔n -- : ∀ m n → m ≤ m ⊔ n - ; x≤y⊔x to m≤n⊔m -- : ∀ m n → m ≤ n ⊔ m - ; x≤y⇒x≤y⊔z to m≤n⇒m≤n⊔o -- : ∀ {m n} o → m ≤ n → m ≤ n ⊔ o - ; x≤y⇒x≤z⊔y to m≤n⇒m≤o⊔n -- : ∀ {m n} o → m ≤ n → m ≤ o ⊔ n - ; x⊔y≤z⇒x≤z to m⊔n≤o⇒m≤o -- : ∀ m n {o} → m ⊔ n ≤ o → m ≤ o - ; x⊔y≤z⇒y≤z to m⊔n≤o⇒n≤o -- : ∀ m n {o} → m ⊔ n ≤ o → n ≤ o - - ; x⊓y≤x⊔y to m⊓n≤m⊔n -- : ∀ m n → m ⊓ n ≤ m ⊔ n - ) - -open ⊓-⊔-latticeProperties public - using - ( ⊓-isSemilattice -- : IsSemilattice _⊓_ - ; ⊔-isSemilattice -- : IsSemilattice _⊔_ - ; ⊔-⊓-isLattice -- : IsLattice _⊔_ _⊓_ - ; ⊓-⊔-isLattice -- : IsLattice _⊓_ _⊔_ - ; ⊔-⊓-isDistributiveLattice -- : IsDistributiveLattice _⊔_ _⊓_ - ; ⊓-⊔-isDistributiveLattice -- : IsDistributiveLattice _⊓_ _⊔_ - - ; ⊓-semilattice -- : Semilattice _ _ - ; ⊔-semilattice -- : Semilattice _ _ - ; ⊔-⊓-lattice -- : Lattice _ _ - ; ⊓-⊔-lattice -- : Lattice _ _ - ; ⊔-⊓-distributiveLattice -- : DistributiveLattice _ _ - ; ⊓-⊔-distributiveLattice -- : DistributiveLattice _ _ - ) - ------------------------------------------------------------------------- --- Automatically derived properties of _⊓_ and _⊔_ - -⊔-identityˡ : LeftIdentity 0 _⊔_ -⊔-identityˡ _ = refl - -⊔-identityʳ : RightIdentity 0 _⊔_ -⊔-identityʳ zero = refl -⊔-identityʳ (suc n) = refl - -⊔-identity : Identity 0 _⊔_ -⊔-identity = ⊔-identityˡ , ⊔-identityʳ - ------------------------------------------------------------------------- --- Structures - -⊔-0-isMonoid : IsMonoid _⊔_ 0 -⊔-0-isMonoid = record - { isSemigroup = ⊔-isSemigroup - ; identity = ⊔-identity - } - -⊔-0-isCommutativeMonoid : IsCommutativeMonoid _⊔_ 0 -⊔-0-isCommutativeMonoid = record - { isMonoid = ⊔-0-isMonoid - ; comm = ⊔-comm - } - ------------------------------------------------------------------------- --- Bundles - -⊔-0-monoid : Monoid 0ℓ 0ℓ -⊔-0-monoid = record - { isMonoid = ⊔-0-isMonoid - } - -⊔-0-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ -⊔-0-commutativeMonoid = record - { isCommutativeMonoid = ⊔-0-isCommutativeMonoid - } - ------------------------------------------------------------------------- --- Other properties of _⊔_ and _≤_/_<_ - -mono-≤-distrib-⊔ : ∀ {f} → f Preserves _≤_ ⟶ _≤_ → - ∀ m n → f (m ⊔ n) ≡ f m ⊔ f n -mono-≤-distrib-⊔ {f} = ⊓-⊔-properties.mono-≤-distrib-⊔ (cong f) - -mono-≤-distrib-⊓ : ∀ {f} → f Preserves _≤_ ⟶ _≤_ → - ∀ m n → f (m ⊓ n) ≡ f m ⊓ f n -mono-≤-distrib-⊓ {f} = ⊓-⊔-properties.mono-≤-distrib-⊓ (cong f) - -antimono-≤-distrib-⊓ : ∀ {f} → f Preserves _≤_ ⟶ _≥_ → - ∀ m n → f (m ⊓ n) ≡ f m ⊔ f n -antimono-≤-distrib-⊓ {f} = ⊓-⊔-properties.antimono-≤-distrib-⊓ (cong f) - -antimono-≤-distrib-⊔ : ∀ {f} → f Preserves _≤_ ⟶ _≥_ → - ∀ m n → f (m ⊔ n) ≡ f m ⊓ f n -antimono-≤-distrib-⊔ {f} = ⊓-⊔-properties.antimono-≤-distrib-⊔ (cong f) - -m<n⇒m<n⊔o : ∀ {m n} o → m < n → m < n ⊔ o -m<n⇒m<n⊔o = m≤n⇒m≤n⊔o - -m<n⇒m<o⊔n : ∀ {m n} o → m < n → m < o ⊔ n -m<n⇒m<o⊔n = m≤n⇒m≤o⊔n - -m⊔n<o⇒m<o : ∀ m n {o} → m ⊔ n < o → m < o -m⊔n<o⇒m<o m n m⊔n<o = <-transʳ (m≤m⊔n m n) m⊔n<o - -m⊔n<o⇒n<o : ∀ m n {o} → m ⊔ n < o → n < o -m⊔n<o⇒n<o m n m⊔n<o = <-transʳ (m≤n⊔m m n) m⊔n<o - -⊔-mono-< : _⊔_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_ -⊔-mono-< = ⊔-mono-≤ - -⊔-pres-<m : ∀ {m n o} → n < m → o < m → n ⊔ o < m -⊔-pres-<m {m} n<m o<m = subst (_ <_) (⊔-idem m) (⊔-mono-< n<m o<m) - ------------------------------------------------------------------------- --- Other properties of _⊔_ and _+_ - -+-distribˡ-⊔ : _+_ DistributesOverˡ _⊔_ -+-distribˡ-⊔ zero n o = refl -+-distribˡ-⊔ (suc m) n o = cong suc (+-distribˡ-⊔ m n o) - -+-distribʳ-⊔ : _+_ DistributesOverʳ _⊔_ -+-distribʳ-⊔ = comm+distrˡ⇒distrʳ +-comm +-distribˡ-⊔ - -+-distrib-⊔ : _+_ DistributesOver _⊔_ -+-distrib-⊔ = +-distribˡ-⊔ , +-distribʳ-⊔ ++-mono-< : _+_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_ ++-mono-< m≤n = +-mono-≤-< (<⇒≤ m≤n) -m⊔n≤m+n : ∀ m n → m ⊔ n ≤ m + n -m⊔n≤m+n m n with ⊔-sel m n -... | inj₁ m⊔n≡m rewrite m⊔n≡m = m≤m+n m n -... | inj₂ m⊔n≡n rewrite m⊔n≡n = m≤n+m n m ++-monoˡ-< : ∀ n → (_+ n) Preserves _<_ ⟶ _<_ ++-monoˡ-< n = +-monoˡ-≤ n ------------------------------------------------------------------------- --- Other properties of _⊔_ and _*_ ++-monoʳ-< : ∀ n → (n +_) Preserves _<_ ⟶ _<_ ++-monoʳ-< zero m≤o = m≤o ++-monoʳ-< (suc n) m≤o = s≤s (+-monoʳ-< n m≤o) -*-distribˡ-⊔ : _*_ DistributesOverˡ _⊔_ -*-distribˡ-⊔ m zero o = sym (cong (_⊔ m * o) (*-zeroʳ m)) -*-distribˡ-⊔ m (suc n) zero = begin-equality - m * (suc n ⊔ zero) ≡⟨⟩ - m * suc n ≡˘⟨ ⊔-identityʳ (m * suc n) ⟩ - m * suc n ⊔ zero ≡˘⟨ cong (m * suc n ⊔_) (*-zeroʳ m) ⟩ - m * suc n ⊔ m * zero ∎ -*-distribˡ-⊔ m (suc n) (suc o) = begin-equality - m * (suc n ⊔ suc o) ≡⟨⟩ - m * suc (n ⊔ o) ≡⟨ *-suc m (n ⊔ o) ⟩ - m + m * (n ⊔ o) ≡⟨ cong (m +_) (*-distribˡ-⊔ m n o) ⟩ - m + (m * n ⊔ m * o) ≡⟨ +-distribˡ-⊔ m (m * n) (m * o) ⟩ - (m + m * n) ⊔ (m + m * o) ≡˘⟨ cong₂ _⊔_ (*-suc m n) (*-suc m o) ⟩ - (m * suc n) ⊔ (m * suc o) ∎ - -*-distribʳ-⊔ : _*_ DistributesOverʳ _⊔_ -*-distribʳ-⊔ = comm+distrˡ⇒distrʳ *-comm *-distribˡ-⊔ - -*-distrib-⊔ : _*_ DistributesOver _⊔_ -*-distrib-⊔ = *-distribˡ-⊔ , *-distribʳ-⊔ - ------------------------------------------------------------------------- --- Properties of _⊓_ ------------------------------------------------------------------------- - ------------------------------------------------------------------------- --- Algebraic properties - -⊓-zeroˡ : LeftZero 0 _⊓_ -⊓-zeroˡ _ = refl - -⊓-zeroʳ : RightZero 0 _⊓_ -⊓-zeroʳ zero = refl -⊓-zeroʳ (suc n) = refl - -⊓-zero : Zero 0 _⊓_ -⊓-zero = ⊓-zeroˡ , ⊓-zeroʳ - ------------------------------------------------------------------------- --- Structures - -⊔-⊓-isSemiringWithoutOne : IsSemiringWithoutOne _⊔_ _⊓_ 0 -⊔-⊓-isSemiringWithoutOne = record - { +-isCommutativeMonoid = ⊔-0-isCommutativeMonoid - ; *-cong = cong₂ _⊓_ - ; *-assoc = ⊓-assoc - ; distrib = ⊓-distrib-⊔ - ; zero = ⊓-zero - } - -⊔-⊓-isCommutativeSemiringWithoutOne - : IsCommutativeSemiringWithoutOne _⊔_ _⊓_ 0 -⊔-⊓-isCommutativeSemiringWithoutOne = record - { isSemiringWithoutOne = ⊔-⊓-isSemiringWithoutOne - ; *-comm = ⊓-comm - } - ------------------------------------------------------------------------- --- Bundles - -⊔-⊓-commutativeSemiringWithoutOne : CommutativeSemiringWithoutOne 0ℓ 0ℓ -⊔-⊓-commutativeSemiringWithoutOne = record - { isCommutativeSemiringWithoutOne = - ⊔-⊓-isCommutativeSemiringWithoutOne - } - ------------------------------------------------------------------------- --- Other properties of _⊓_ and _≤_/_<_ - -m<n⇒m⊓o<n : ∀ {m n} o → m < n → m ⊓ o < n -m<n⇒m⊓o<n o m<n = <-transʳ (m⊓n≤m _ o) m<n - -m<n⇒o⊓m<n : ∀ {m n} o → m < n → o ⊓ m < n -m<n⇒o⊓m<n o m<n = <-transʳ (m⊓n≤n o _) m<n - -m<n⊓o⇒m<n : ∀ {m} n o → m < n ⊓ o → m < n -m<n⊓o⇒m<n = m≤n⊓o⇒m≤n - -m<n⊓o⇒m<o : ∀ {m} n o → m < n ⊓ o → m < o -m<n⊓o⇒m<o = m≤n⊓o⇒m≤o - -⊓-mono-< : _⊓_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_ -⊓-mono-< = ⊓-mono-≤ - -⊓-pres-m< : ∀ {m n o} → m < n → m < o → m < n ⊓ o -⊓-pres-m< {m} m<n m<o = subst (_< _) (⊓-idem m) (⊓-mono-< m<n m<o) - ------------------------------------------------------------------------- --- Other properties of _⊓_ and _+_ - -+-distribˡ-⊓ : _+_ DistributesOverˡ _⊓_ -+-distribˡ-⊓ zero n o = refl -+-distribˡ-⊓ (suc m) n o = cong suc (+-distribˡ-⊓ m n o) - -+-distribʳ-⊓ : _+_ DistributesOverʳ _⊓_ -+-distribʳ-⊓ = comm+distrˡ⇒distrʳ +-comm +-distribˡ-⊓ - -+-distrib-⊓ : _+_ DistributesOver _⊓_ -+-distrib-⊓ = +-distribˡ-⊓ , +-distribʳ-⊓ - -m⊓n≤m+n : ∀ m n → m ⊓ n ≤ m + n -m⊓n≤m+n m n with ⊓-sel m n -... | inj₁ m⊓n≡m rewrite m⊓n≡m = m≤m+n m n -... | inj₂ m⊓n≡n rewrite m⊓n≡n = m≤n+m n m - ------------------------------------------------------------------------- --- Other properties of _⊓_ and _*_ - -*-distribˡ-⊓ : _*_ DistributesOverˡ _⊓_ -*-distribˡ-⊓ m 0 o = begin-equality - m * (0 ⊓ o) ≡⟨⟩ - m * 0 ≡⟨ *-zeroʳ m ⟩ - 0 ≡⟨⟩ - 0 ⊓ (m * o) ≡˘⟨ cong (_⊓ (m * o)) (*-zeroʳ m) ⟩ - (m * 0) ⊓ (m * o) ∎ -*-distribˡ-⊓ m (suc n) 0 = begin-equality - m * (suc n ⊓ 0) ≡⟨⟩ - m * 0 ≡⟨ *-zeroʳ m ⟩ - 0 ≡˘⟨ ⊓-zeroʳ (m * suc n) ⟩ - (m * suc n) ⊓ 0 ≡˘⟨ cong (m * suc n ⊓_) (*-zeroʳ m) ⟩ - (m * suc n) ⊓ (m * 0) ∎ -*-distribˡ-⊓ m (suc n) (suc o) = begin-equality - m * (suc n ⊓ suc o) ≡⟨⟩ - m * suc (n ⊓ o) ≡⟨ *-suc m (n ⊓ o) ⟩ - m + m * (n ⊓ o) ≡⟨ cong (m +_) (*-distribˡ-⊓ m n o) ⟩ - m + (m * n) ⊓ (m * o) ≡⟨ +-distribˡ-⊓ m (m * n) (m * o) ⟩ - (m + m * n) ⊓ (m + m * o) ≡˘⟨ cong₂ _⊓_ (*-suc m n) (*-suc m o) ⟩ - (m * suc n) ⊓ (m * suc o) ∎ - -*-distribʳ-⊓ : _*_ DistributesOverʳ _⊓_ -*-distribʳ-⊓ = comm+distrˡ⇒distrʳ *-comm *-distribˡ-⊓ - -*-distrib-⊓ : _*_ DistributesOver _⊓_ -*-distrib-⊓ = *-distribˡ-⊓ , *-distribʳ-⊓ - ------------------------------------------------------------------------- --- Properties of _∸_ ------------------------------------------------------------------------- - -0∸n≡0 : LeftZero zero _∸_ -0∸n≡0 zero = refl -0∸n≡0 (suc _) = refl - -n∸n≡0 : ∀ n → n ∸ n ≡ 0 -n∸n≡0 zero = refl -n∸n≡0 (suc n) = n∸n≡0 n - ------------------------------------------------------------------------- --- Properties of _∸_ and pred - -pred[m∸n]≡m∸[1+n] : ∀ m n → pred (m ∸ n) ≡ m ∸ suc n -pred[m∸n]≡m∸[1+n] zero zero = refl -pred[m∸n]≡m∸[1+n] (suc m) zero = refl -pred[m∸n]≡m∸[1+n] zero (suc n) = refl -pred[m∸n]≡m∸[1+n] (suc m) (suc n) = pred[m∸n]≡m∸[1+n] m n - ------------------------------------------------------------------------- --- Properties of _∸_ and _≤_/_<_ - -m∸n≤m : ∀ m n → m ∸ n ≤ m -m∸n≤m n zero = ≤-refl -m∸n≤m zero (suc n) = ≤-refl -m∸n≤m (suc m) (suc n) = ≤-trans (m∸n≤m m n) (n≤1+n m) - -m≮m∸n : ∀ m n → m ≮ m ∸ n -m≮m∸n m zero = n≮n m -m≮m∸n (suc m) (suc n) = m≮m∸n m n ∘ ≤-trans (n≤1+n (suc m)) - -1+m≢m∸n : ∀ {m} n → suc m ≢ m ∸ n -1+m≢m∸n {m} n eq = m≮m∸n m n (≤-reflexive eq) - -∸-mono : _∸_ Preserves₂ _≤_ ⟶ _≥_ ⟶ _≤_ -∸-mono z≤n (s≤s n₁≥n₂) = z≤n -∸-mono (s≤s m₁≤m₂) (s≤s n₁≥n₂) = ∸-mono m₁≤m₂ n₁≥n₂ -∸-mono m₁≤m₂ (z≤n {n = n₁}) = ≤-trans (m∸n≤m _ n₁) m₁≤m₂ - -∸-monoˡ-≤ : ∀ {m n} o → m ≤ n → m ∸ o ≤ n ∸ o -∸-monoˡ-≤ o m≤n = ∸-mono {u = o} m≤n ≤-refl - -∸-monoʳ-≤ : ∀ {m n} o → m ≤ n → o ∸ m ≥ o ∸ n -∸-monoʳ-≤ _ m≤n = ∸-mono ≤-refl m≤n - -∸-monoˡ-< : ∀ {m n o} → m < o → n ≤ m → m ∸ n < o ∸ n -∸-monoˡ-< {m} {zero} {o} m<o n≤m = m<o -∸-monoˡ-< {suc m} {suc n} {suc o} (s≤s m<o) (s≤s n≤m) = ∸-monoˡ-< m<o n≤m - -∸-monoʳ-< : ∀ {m n o} → o < n → n ≤ m → m ∸ n < m ∸ o -∸-monoʳ-< {n = suc n} {zero} (s≤s o<n) (s≤s n<m) = s≤s (m∸n≤m _ n) -∸-monoʳ-< {n = suc n} {suc o} (s≤s o<n) (s≤s n<m) = ∸-monoʳ-< o<n n<m - -∸-cancelʳ-≤ : ∀ {m n o} → m ≤ o → o ∸ n ≤ o ∸ m → m ≤ n -∸-cancelʳ-≤ {_} {_} z≤n _ = z≤n -∸-cancelʳ-≤ {suc m} {zero} (s≤s _) o<o∸m = contradiction o<o∸m (m≮m∸n _ m) -∸-cancelʳ-≤ {suc m} {suc n} (s≤s m≤o) o∸n<o∸m = s≤s (∸-cancelʳ-≤ m≤o o∸n<o∸m) - -∸-cancelʳ-< : ∀ {m n o} → o ∸ m < o ∸ n → n < m -∸-cancelʳ-< {zero} {n} {o} o<o∸n = contradiction o<o∸n (m≮m∸n o n) -∸-cancelʳ-< {suc m} {zero} {_} o∸n<o∸m = 0<1+n -∸-cancelʳ-< {suc m} {suc n} {suc o} o∸n<o∸m = s≤s (∸-cancelʳ-< o∸n<o∸m) - -∸-cancelˡ-≡ : ∀ {m n o} → n ≤ m → o ≤ m → m ∸ n ≡ m ∸ o → n ≡ o -∸-cancelˡ-≡ {_} z≤n z≤n _ = refl -∸-cancelˡ-≡ {o = suc o} z≤n (s≤s _) eq = contradiction eq (1+m≢m∸n o) -∸-cancelˡ-≡ {n = suc n} (s≤s _) z≤n eq = contradiction (sym eq) (1+m≢m∸n n) -∸-cancelˡ-≡ {_} (s≤s n≤m) (s≤s o≤m) eq = cong suc (∸-cancelˡ-≡ n≤m o≤m eq) - -∸-cancelʳ-≡ : ∀ {m n o} → o ≤ m → o ≤ n → m ∸ o ≡ n ∸ o → m ≡ n -∸-cancelʳ-≡ z≤n z≤n eq = eq -∸-cancelʳ-≡ (s≤s o≤m) (s≤s o≤n) eq = cong suc (∸-cancelʳ-≡ o≤m o≤n eq) - -m∸n≡0⇒m≤n : ∀ {m n} → m ∸ n ≡ 0 → m ≤ n -m∸n≡0⇒m≤n {zero} {_} _ = z≤n -m∸n≡0⇒m≤n {suc m} {suc n} eq = s≤s (m∸n≡0⇒m≤n eq) - -m≤n⇒m∸n≡0 : ∀ {m n} → m ≤ n → m ∸ n ≡ 0 -m≤n⇒m∸n≡0 {n = n} z≤n = 0∸n≡0 n -m≤n⇒m∸n≡0 {_} (s≤s m≤n) = m≤n⇒m∸n≡0 m≤n - -m<n⇒0<n∸m : ∀ {m n} → m < n → 0 < n ∸ m -m<n⇒0<n∸m {zero} {suc n} _ = 0<1+n -m<n⇒0<n∸m {suc m} {suc n} (s≤s m<n) = m<n⇒0<n∸m m<n - -m∸n≢0⇒n<m : ∀ {m n} → m ∸ n ≢ 0 → n < m -m∸n≢0⇒n<m {m} {n} m∸n≢0 with n <? m -... | yes n<m = n<m -... | no n≮m = contradiction (m≤n⇒m∸n≡0 (≮⇒≥ n≮m)) m∸n≢0 - -m>n⇒m∸n≢0 : ∀ {m n} → m > n → m ∸ n ≢ 0 -m>n⇒m∸n≢0 {n = suc n} (s≤s m>n) = m>n⇒m∸n≢0 m>n - -m≤n⇒n∸m≤n : ∀ {m n} → m ≤ n → n ∸ m ≤ n -m≤n⇒n∸m≤n z≤n = ≤-refl -m≤n⇒n∸m≤n (s≤s m≤n) = m≤n⇒m≤1+n (m≤n⇒n∸m≤n m≤n) - ---------------------------------------------------------------- --- Properties of _∸_ and _+_ - -+-∸-comm : ∀ {m} n {o} → o ≤ m → (m + n) ∸ o ≡ (m ∸ o) + n -+-∸-comm {zero} _ {zero} _ = refl -+-∸-comm {suc m} _ {zero} _ = refl -+-∸-comm {suc m} n {suc o} (s≤s o≤m) = +-∸-comm n o≤m - -∸-+-assoc : ∀ m n o → (m ∸ n) ∸ o ≡ m ∸ (n + o) -∸-+-assoc zero zero o = refl -∸-+-assoc zero (suc n) o = 0∸n≡0 o -∸-+-assoc (suc m) zero o = refl -∸-+-assoc (suc m) (suc n) o = ∸-+-assoc m n o - -+-∸-assoc : ∀ m {n o} → o ≤ n → (m + n) ∸ o ≡ m + (n ∸ o) -+-∸-assoc m (z≤n {n = n}) = begin-equality m + n ∎ -+-∸-assoc m (s≤s {m = o} {n = n} o≤n) = begin-equality - (m + suc n) ∸ suc o ≡⟨ cong (_∸ suc o) (+-suc m n) ⟩ - suc (m + n) ∸ suc o ≡⟨⟩ - (m + n) ∸ o ≡⟨ +-∸-assoc m o≤n ⟩ - m + (n ∸ o) ∎ - -m≤n+m∸n : ∀ m n → m ≤ n + (m ∸ n) -m≤n+m∸n zero n = z≤n -m≤n+m∸n (suc m) zero = ≤-refl -m≤n+m∸n (suc m) (suc n) = s≤s (m≤n+m∸n m n) - -m+n∸n≡m : ∀ m n → m + n ∸ n ≡ m -m+n∸n≡m m n = begin-equality - (m + n) ∸ n ≡⟨ +-∸-assoc m (≤-refl {x = n}) ⟩ - m + (n ∸ n) ≡⟨ cong (m +_) (n∸n≡0 n) ⟩ - m + 0 ≡⟨ +-identityʳ m ⟩ - m ∎ - -m+n∸m≡n : ∀ m n → m + n ∸ m ≡ n -m+n∸m≡n m n = trans (cong (_∸ m) (+-comm m n)) (m+n∸n≡m n m) - -m+[n∸m]≡n : ∀ {m n} → m ≤ n → m + (n ∸ m) ≡ n -m+[n∸m]≡n {m} {n} m≤n = begin-equality - m + (n ∸ m) ≡⟨ sym $ +-∸-assoc m m≤n ⟩ - (m + n) ∸ m ≡⟨ cong (_∸ m) (+-comm m n) ⟩ - (n + m) ∸ m ≡⟨ m+n∸n≡m n m ⟩ - n ∎ - -m∸n+n≡m : ∀ {m n} → n ≤ m → (m ∸ n) + n ≡ m -m∸n+n≡m {m} {n} n≤m = begin-equality - (m ∸ n) + n ≡⟨ sym (+-∸-comm n n≤m) ⟩ - (m + n) ∸ n ≡⟨ m+n∸n≡m m n ⟩ - m ∎ - -m∸[m∸n]≡n : ∀ {m n} → n ≤ m → m ∸ (m ∸ n) ≡ n -m∸[m∸n]≡n {m} {_} z≤n = n∸n≡0 m -m∸[m∸n]≡n {suc m} {suc n} (s≤s n≤m) = begin-equality - suc m ∸ (m ∸ n) ≡⟨ +-∸-assoc 1 (m∸n≤m m n) ⟩ - suc (m ∸ (m ∸ n)) ≡⟨ cong suc (m∸[m∸n]≡n n≤m) ⟩ - suc n ∎ - -[m+n]∸[m+o]≡n∸o : ∀ m n o → (m + n) ∸ (m + o) ≡ n ∸ o -[m+n]∸[m+o]≡n∸o zero n o = refl -[m+n]∸[m+o]≡n∸o (suc m) n o = [m+n]∸[m+o]≡n∸o m n o - ------------------------------------------------------------------------- --- Properties of _∸_ and _*_ - -*-distribʳ-∸ : _*_ DistributesOverʳ _∸_ -*-distribʳ-∸ m zero zero = refl -*-distribʳ-∸ zero zero (suc o) = sym (0∸n≡0 (o * zero)) -*-distribʳ-∸ (suc m) zero (suc o) = refl -*-distribʳ-∸ m (suc n) zero = refl -*-distribʳ-∸ m (suc n) (suc o) = begin-equality - (n ∸ o) * m ≡⟨ *-distribʳ-∸ m n o ⟩ - n * m ∸ o * m ≡⟨ sym $ [m+n]∸[m+o]≡n∸o m _ _ ⟩ - m + n * m ∸ (m + o * m) ∎ - -*-distribˡ-∸ : _*_ DistributesOverˡ _∸_ -*-distribˡ-∸ = comm+distrʳ⇒distrˡ *-comm *-distribʳ-∸ - -*-distrib-∸ : _*_ DistributesOver _∸_ -*-distrib-∸ = *-distribˡ-∸ , *-distribʳ-∸ - -even≢odd : ∀ m n → 2 * m ≢ suc (2 * n) -even≢odd (suc m) zero eq = contradiction (suc-injective eq) (m+1+n≢0 m) -even≢odd (suc m) (suc n) eq = even≢odd m n (suc-injective (begin-equality - suc (2 * m) ≡⟨ sym (+-suc m _) ⟩ - m + suc (m + 0) ≡⟨ suc-injective eq ⟩ - suc n + suc (n + 0) ≡⟨ cong suc (+-suc n _) ⟩ - suc (suc (2 * n)) ∎)) - ------------------------------------------------------------------------- --- Properties of _∸_ and _⊓_ and _⊔_ - -m⊓n+n∸m≡n : ∀ m n → (m ⊓ n) + (n ∸ m) ≡ n -m⊓n+n∸m≡n zero n = refl -m⊓n+n∸m≡n (suc m) zero = refl -m⊓n+n∸m≡n (suc m) (suc n) = cong suc $ m⊓n+n∸m≡n m n - -[m∸n]⊓[n∸m]≡0 : ∀ m n → (m ∸ n) ⊓ (n ∸ m) ≡ 0 -[m∸n]⊓[n∸m]≡0 zero zero = refl -[m∸n]⊓[n∸m]≡0 zero (suc n) = refl -[m∸n]⊓[n∸m]≡0 (suc m) zero = refl -[m∸n]⊓[n∸m]≡0 (suc m) (suc n) = [m∸n]⊓[n∸m]≡0 m n - -∸-distribˡ-⊓-⊔ : ∀ m n o → m ∸ (n ⊓ o) ≡ (m ∸ n) ⊔ (m ∸ o) -∸-distribˡ-⊓-⊔ m n o = antimono-≤-distrib-⊓ (∸-monoʳ-≤ m) n o - -∸-distribʳ-⊓ : _∸_ DistributesOverʳ _⊓_ -∸-distribʳ-⊓ m n o = mono-≤-distrib-⊓ (∸-monoˡ-≤ m) n o - -∸-distribˡ-⊔-⊓ : ∀ m n o → m ∸ (n ⊔ o) ≡ (m ∸ n) ⊓ (m ∸ o) -∸-distribˡ-⊔-⊓ m n o = antimono-≤-distrib-⊔ (∸-monoʳ-≤ m) n o - -∸-distribʳ-⊔ : _∸_ DistributesOverʳ _⊔_ -∸-distribʳ-⊔ m n o = mono-≤-distrib-⊔ (∸-monoˡ-≤ m) n o - ------------------------------------------------------------------------- --- Properties of pred ------------------------------------------------------------------------- - -pred-mono : pred Preserves _≤_ ⟶ _≤_ -pred-mono m≤n = ∸-mono m≤n (≤-refl {1}) - -pred[n]≤n : ∀ {n} → pred n ≤ n -pred[n]≤n {zero} = z≤n -pred[n]≤n {suc n} = n≤1+n n - -≤pred⇒≤ : ∀ {m n} → m ≤ pred n → m ≤ n -≤pred⇒≤ {m} {zero} le = le -≤pred⇒≤ {m} {suc n} le = m≤n⇒m≤1+n le - -≤⇒pred≤ : ∀ {m n} → m ≤ n → pred m ≤ n -≤⇒pred≤ {zero} le = le -≤⇒pred≤ {suc m} le = ≤-trans (n≤1+n m) le - -<⇒≤pred : ∀ {m n} → m < n → m ≤ pred n -<⇒≤pred (s≤s le) = le - -suc-pred : ∀ n .{{_ : NonZero n}} → suc (pred n) ≡ n -suc-pred (suc n) = refl - ------------------------------------------------------------------------- --- Properties of ∣_-_∣ ------------------------------------------------------------------------- - ------------------------------------------------------------------------- --- Basic - -m≡n⇒∣m-n∣≡0 : ∀ {m n} → m ≡ n → ∣ m - n ∣ ≡ 0 -m≡n⇒∣m-n∣≡0 {zero} refl = refl -m≡n⇒∣m-n∣≡0 {suc m} refl = m≡n⇒∣m-n∣≡0 {m} refl - -∣m-n∣≡0⇒m≡n : ∀ {m n} → ∣ m - n ∣ ≡ 0 → m ≡ n -∣m-n∣≡0⇒m≡n {zero} {zero} eq = refl -∣m-n∣≡0⇒m≡n {suc m} {suc n} eq = cong suc (∣m-n∣≡0⇒m≡n eq) - -m≤n⇒∣n-m∣≡n∸m : ∀ {m n} → m ≤ n → ∣ n - m ∣ ≡ n ∸ m -m≤n⇒∣n-m∣≡n∸m {_} {zero} z≤n = refl -m≤n⇒∣n-m∣≡n∸m {_} {suc m} z≤n = refl -m≤n⇒∣n-m∣≡n∸m {_} {_} (s≤s m≤n) = m≤n⇒∣n-m∣≡n∸m m≤n - -m≤n⇒∣m-n∣≡n∸m : ∀ {m n} → m ≤ n → ∣ m - n ∣ ≡ n ∸ m -m≤n⇒∣m-n∣≡n∸m {_} {zero} z≤n = refl -m≤n⇒∣m-n∣≡n∸m {_} {suc n} z≤n = refl -m≤n⇒∣m-n∣≡n∸m {_} {_} (s≤s m≤n) = m≤n⇒∣m-n∣≡n∸m m≤n - -∣m-n∣≡m∸n⇒n≤m : ∀ {m n} → ∣ m - n ∣ ≡ m ∸ n → n ≤ m -∣m-n∣≡m∸n⇒n≤m {zero} {zero} eq = z≤n -∣m-n∣≡m∸n⇒n≤m {suc m} {zero} eq = z≤n -∣m-n∣≡m∸n⇒n≤m {suc m} {suc n} eq = s≤s (∣m-n∣≡m∸n⇒n≤m eq) - -∣n-n∣≡0 : ∀ n → ∣ n - n ∣ ≡ 0 -∣n-n∣≡0 n = m≡n⇒∣m-n∣≡0 {n} refl - -∣m-m+n∣≡n : ∀ m n → ∣ m - m + n ∣ ≡ n -∣m-m+n∣≡n zero n = refl -∣m-m+n∣≡n (suc m) n = ∣m-m+n∣≡n m n - -∣m+n-m+o∣≡∣n-o∣ : ∀ m n o → ∣ m + n - m + o ∣ ≡ ∣ n - o ∣ -∣m+n-m+o∣≡∣n-o∣ zero n o = refl -∣m+n-m+o∣≡∣n-o∣ (suc m) n o = ∣m+n-m+o∣≡∣n-o∣ m n o - -m∸n≤∣m-n∣ : ∀ m n → m ∸ n ≤ ∣ m - n ∣ -m∸n≤∣m-n∣ m n with ≤-total m n -... | inj₁ m≤n = subst (_≤ ∣ m - n ∣) (sym (m≤n⇒m∸n≡0 m≤n)) z≤n -... | inj₂ n≤m = subst (m ∸ n ≤_) (sym (m≤n⇒∣n-m∣≡n∸m n≤m)) ≤-refl - -∣m-n∣≤m⊔n : ∀ m n → ∣ m - n ∣ ≤ m ⊔ n -∣m-n∣≤m⊔n zero m = ≤-refl -∣m-n∣≤m⊔n (suc m) zero = ≤-refl -∣m-n∣≤m⊔n (suc m) (suc n) = m≤n⇒m≤1+n (∣m-n∣≤m⊔n m n) - -∣-∣-identityˡ : LeftIdentity 0 ∣_-_∣ -∣-∣-identityˡ x = refl - -∣-∣-identityʳ : RightIdentity 0 ∣_-_∣ -∣-∣-identityʳ zero = refl -∣-∣-identityʳ (suc x) = refl - -∣-∣-identity : Identity 0 ∣_-_∣ -∣-∣-identity = ∣-∣-identityˡ , ∣-∣-identityʳ - -∣-∣-comm : Commutative ∣_-_∣ -∣-∣-comm zero zero = refl -∣-∣-comm zero (suc n) = refl -∣-∣-comm (suc m) zero = refl -∣-∣-comm (suc m) (suc n) = ∣-∣-comm m n - -∣m-n∣≡[m∸n]∨[n∸m] : ∀ m n → (∣ m - n ∣ ≡ m ∸ n) ⊎ (∣ m - n ∣ ≡ n ∸ m) -∣m-n∣≡[m∸n]∨[n∸m] m n with ≤-total m n -... | inj₂ n≤m = inj₁ $ m≤n⇒∣n-m∣≡n∸m n≤m -... | inj₁ m≤n = inj₂ $ begin-equality - ∣ m - n ∣ ≡⟨ ∣-∣-comm m n ⟩ - ∣ n - m ∣ ≡⟨ m≤n⇒∣n-m∣≡n∸m m≤n ⟩ - n ∸ m ∎ - -private - - *-distribˡ-∣-∣-aux : ∀ a m n → m ≤ n → a * ∣ n - m ∣ ≡ ∣ a * n - a * m ∣ - *-distribˡ-∣-∣-aux a m n m≤n = begin-equality - a * ∣ n - m ∣ ≡⟨ cong (a *_) (m≤n⇒∣n-m∣≡n∸m m≤n) ⟩ - a * (n ∸ m) ≡⟨ *-distribˡ-∸ a n m ⟩ - a * n ∸ a * m ≡⟨ sym $′ m≤n⇒∣n-m∣≡n∸m (*-monoʳ-≤ a m≤n) ⟩ - ∣ a * n - a * m ∣ ∎ - -*-distribˡ-∣-∣ : _*_ DistributesOverˡ ∣_-_∣ -*-distribˡ-∣-∣ a m n with ≤-total m n -... | inj₂ n≤m = *-distribˡ-∣-∣-aux a n m n≤m -... | inj₁ m≤n = begin-equality - a * ∣ m - n ∣ ≡⟨ cong (a *_) (∣-∣-comm m n) ⟩ - a * ∣ n - m ∣ ≡⟨ *-distribˡ-∣-∣-aux a m n m≤n ⟩ - ∣ a * n - a * m ∣ ≡⟨ ∣-∣-comm (a * n) (a * m) ⟩ - ∣ a * m - a * n ∣ ∎ - -*-distribʳ-∣-∣ : _*_ DistributesOverʳ ∣_-_∣ -*-distribʳ-∣-∣ = comm+distrˡ⇒distrʳ *-comm *-distribˡ-∣-∣ - -*-distrib-∣-∣ : _*_ DistributesOver ∣_-_∣ -*-distrib-∣-∣ = *-distribˡ-∣-∣ , *-distribʳ-∣-∣ - -m≤n+∣n-m∣ : ∀ m n → m ≤ n + ∣ n - m ∣ -m≤n+∣n-m∣ zero n = z≤n -m≤n+∣n-m∣ (suc m) zero = ≤-refl -m≤n+∣n-m∣ (suc m) (suc n) = s≤s (m≤n+∣n-m∣ m n) - -m≤n+∣m-n∣ : ∀ m n → m ≤ n + ∣ m - n ∣ -m≤n+∣m-n∣ m n = subst (m ≤_) (cong (n +_) (∣-∣-comm n m)) (m≤n+∣n-m∣ m n) - -m≤∣m-n∣+n : ∀ m n → m ≤ ∣ m - n ∣ + n -m≤∣m-n∣+n m n = subst (m ≤_) (+-comm n _) (m≤n+∣m-n∣ m n) - -∣-∣-triangle : TriangleInequality ∣_-_∣ -∣-∣-triangle zero y z = m≤n+∣n-m∣ z y -∣-∣-triangle x zero z = begin - ∣ x - z ∣ ≤⟨ ∣m-n∣≤m⊔n x z ⟩ - x ⊔ z ≤⟨ m⊔n≤m+n x z ⟩ - x + z ≡⟨ cong₂ _+_ (sym (∣-∣-identityʳ x)) refl ⟩ - ∣ x - 0 ∣ + z ∎ - where open ≤-Reasoning -∣-∣-triangle x y zero = begin - ∣ x - 0 ∣ ≡⟨ ∣-∣-identityʳ x ⟩ - x ≤⟨ m≤∣m-n∣+n x y ⟩ - ∣ x - y ∣ + y ≡⟨ cong₂ _+_ refl (sym (∣-∣-identityʳ y)) ⟩ - ∣ x - y ∣ + ∣ y - 0 ∣ ∎ - where open ≤-Reasoning -∣-∣-triangle (suc x) (suc y) (suc z) = ∣-∣-triangle x y z - -∣-∣≡∣-∣′ : ∀ m n → ∣ m - n ∣ ≡ ∣ m - n ∣′ -∣-∣≡∣-∣′ m n with m <ᵇ n in eq -... | false = m≤n⇒∣n-m∣≡n∸m {n} {m} (≮⇒≥ (λ m<n → subst T eq (<⇒<ᵇ m<n))) -... | true = m≤n⇒∣m-n∣≡n∸m {m} {n} (<⇒≤ (<ᵇ⇒< m n (subst T (sym eq) _))) - ------------------------------------------------------------------------- --- Metric structures - -∣-∣-isProtoMetric : IsProtoMetric _≡_ ∣_-_∣ -∣-∣-isProtoMetric = record - { isPartialOrder = ≤-isPartialOrder - ; ≈-isEquivalence = isEquivalence - ; cong = cong₂ ∣_-_∣ - ; nonNegative = z≤n - } - -∣-∣-isPreMetric : IsPreMetric _≡_ ∣_-_∣ -∣-∣-isPreMetric = record - { isProtoMetric = ∣-∣-isProtoMetric - ; ≈⇒0 = m≡n⇒∣m-n∣≡0 - } - -∣-∣-isQuasiSemiMetric : IsQuasiSemiMetric _≡_ ∣_-_∣ -∣-∣-isQuasiSemiMetric = record - { isPreMetric = ∣-∣-isPreMetric - ; 0⇒≈ = ∣m-n∣≡0⇒m≡n - } - -∣-∣-isSemiMetric : IsSemiMetric _≡_ ∣_-_∣ -∣-∣-isSemiMetric = record - { isQuasiSemiMetric = ∣-∣-isQuasiSemiMetric - ; sym = ∣-∣-comm - } - -∣-∣-isMetric : IsMetric _≡_ ∣_-_∣ -∣-∣-isMetric = record - { isSemiMetric = ∣-∣-isSemiMetric - ; triangle = ∣-∣-triangle - } - ------------------------------------------------------------------------- --- Metric bundles - -∣-∣-quasiSemiMetric : QuasiSemiMetric 0ℓ 0ℓ -∣-∣-quasiSemiMetric = record - { isQuasiSemiMetric = ∣-∣-isQuasiSemiMetric - } - -∣-∣-semiMetric : SemiMetric 0ℓ 0ℓ -∣-∣-semiMetric = record - { isSemiMetric = ∣-∣-isSemiMetric - } - -∣-∣-preMetric : PreMetric 0ℓ 0ℓ -∣-∣-preMetric = record - { isPreMetric = ∣-∣-isPreMetric - } - -∣-∣-metric : Metric 0ℓ 0ℓ -∣-∣-metric = record - { isMetric = ∣-∣-isMetric - } - ------------------------------------------------------------------------- --- Properties of ⌊_/2⌋ and ⌈_/2⌉ ------------------------------------------------------------------------- - -⌊n/2⌋-mono : ⌊_/2⌋ Preserves _≤_ ⟶ _≤_ -⌊n/2⌋-mono z≤n = z≤n -⌊n/2⌋-mono (s≤s z≤n) = z≤n -⌊n/2⌋-mono (s≤s (s≤s m≤n)) = s≤s (⌊n/2⌋-mono m≤n) - -⌈n/2⌉-mono : ⌈_/2⌉ Preserves _≤_ ⟶ _≤_ -⌈n/2⌉-mono m≤n = ⌊n/2⌋-mono (s≤s m≤n) - -⌊n/2⌋≤⌈n/2⌉ : ∀ n → ⌊ n /2⌋ ≤ ⌈ n /2⌉ -⌊n/2⌋≤⌈n/2⌉ zero = z≤n -⌊n/2⌋≤⌈n/2⌉ (suc zero) = z≤n -⌊n/2⌋≤⌈n/2⌉ (suc (suc n)) = s≤s (⌊n/2⌋≤⌈n/2⌉ n) - -⌊n/2⌋+⌈n/2⌉≡n : ∀ n → ⌊ n /2⌋ + ⌈ n /2⌉ ≡ n -⌊n/2⌋+⌈n/2⌉≡n zero = refl -⌊n/2⌋+⌈n/2⌉≡n (suc n) = begin-equality - ⌊ suc n /2⌋ + suc ⌊ n /2⌋ ≡⟨ +-comm ⌊ suc n /2⌋ (suc ⌊ n /2⌋) ⟩ - suc ⌊ n /2⌋ + ⌊ suc n /2⌋ ≡⟨⟩ - suc (⌊ n /2⌋ + ⌊ suc n /2⌋) ≡⟨ cong suc (⌊n/2⌋+⌈n/2⌉≡n n) ⟩ - suc n ∎ - -⌊n/2⌋≤n : ∀ n → ⌊ n /2⌋ ≤ n -⌊n/2⌋≤n zero = z≤n -⌊n/2⌋≤n (suc zero) = z≤n -⌊n/2⌋≤n (suc (suc n)) = s≤s (m≤n⇒m≤1+n (⌊n/2⌋≤n n)) - -⌊n/2⌋<n : ∀ n → ⌊ suc n /2⌋ < suc n -⌊n/2⌋<n zero = z<s -⌊n/2⌋<n (suc n) = s<s (s≤s (⌊n/2⌋≤n n)) - -n≡⌊n+n/2⌋ : ∀ n → n ≡ ⌊ n + n /2⌋ -n≡⌊n+n/2⌋ zero = refl -n≡⌊n+n/2⌋ (suc zero) = refl -n≡⌊n+n/2⌋ (suc n′@(suc n)) = - cong suc (trans (n≡⌊n+n/2⌋ _) (cong ⌊_/2⌋ (sym (+-suc n n′)))) - -⌈n/2⌉≤n : ∀ n → ⌈ n /2⌉ ≤ n -⌈n/2⌉≤n zero = z≤n -⌈n/2⌉≤n (suc n) = s≤s (⌊n/2⌋≤n n) - -⌈n/2⌉<n : ∀ n → ⌈ suc (suc n) /2⌉ < suc (suc n) -⌈n/2⌉<n n = s<s (⌊n/2⌋<n n) - -n≡⌈n+n/2⌉ : ∀ n → n ≡ ⌈ n + n /2⌉ -n≡⌈n+n/2⌉ zero = refl -n≡⌈n+n/2⌉ (suc zero) = refl -n≡⌈n+n/2⌉ (suc n′@(suc n)) = - cong suc (trans (n≡⌈n+n/2⌉ _) (cong ⌈_/2⌉ (sym (+-suc n n′)))) - ------------------------------------------------------------------------- --- Properties of !_ - -1≤n! : ∀ n → 1 ≤ n ! -1≤n! zero = ≤-refl -1≤n! (suc n) = *-mono-≤ (m≤m+n 1 n) (1≤n! n) - -_!≢0 : ∀ n → NonZero (n !) -n !≢0 = >-nonZero (1≤n! n) - -_!*_!≢0 : ∀ m n → NonZero (m ! * n !) -m !* n !≢0 = m*n≢0 _ _ {{m !≢0}} {{n !≢0}} - ------------------------------------------------------------------------- --- Properties of _≤′_ and _<′_ +m+1+n≰m : ∀ m {n} → m + suc n ≰ m +m+1+n≰m (suc m) m+1+n≤m = m+1+n≰m m (s≤s⁻¹ m+1+n≤m) -≤′-trans : Transitive _≤′_ -≤′-trans m≤n ≤′-refl = m≤n -≤′-trans m≤n (≤′-step n≤o) = ≤′-step (≤′-trans m≤n n≤o) +m<m+n : ∀ m {n} → n > 0 → m < m + n +m<m+n zero n>0 = n>0 +m<m+n (suc m) n>0 = s<s (m<m+n m n>0) -z≤′n : ∀ {n} → zero ≤′ n -z≤′n {zero} = ≤′-refl -z≤′n {suc n} = ≤′-step z≤′n +m<n+m : ∀ m {n} → n > 0 → m < n + m +m<n+m m {n} n>0 rewrite +-comm n m = m<m+n m n>0 -s≤′s : ∀ {m n} → m ≤′ n → suc m ≤′ suc n -s≤′s ≤′-refl = ≤′-refl -s≤′s (≤′-step m≤′n) = ≤′-step (s≤′s m≤′n) +m+n≮n : ∀ m n → m + n ≮ n +m+n≮n zero n = n≮n n +m+n≮n (suc m) n@(suc _) sm+n<n = m+n≮n m n (m<n⇒m<1+n (s<s⁻¹ sm+n<n)) + +m+n≮m : ∀ m n → m + n ≮ m +m+n≮m m n = subst (_≮ m) (+-comm n m) (m+n≮n n m) + +------------------------------------------------------------------------ +-- Properties of _*_ +------------------------------------------------------------------------ + +*-suc : ∀ m n → m * suc n ≡ m + m * n +*-suc zero n = refl +*-suc (suc m) n = begin-equality + suc m * suc n ≡⟨⟩ + suc n + m * suc n ≡⟨ cong (suc n +_) (*-suc m n) ⟩ + suc n + (m + m * n) ≡⟨⟩ + suc (n + (m + m * n)) ≡⟨ cong suc (sym (+-assoc n m (m * n))) ⟩ + suc (n + m + m * n) ≡⟨ cong (λ x → suc (x + m * n)) (+-comm n m) ⟩ + suc (m + n + m * n) ≡⟨ cong suc (+-assoc m n (m * n)) ⟩ + suc (m + (n + m * n)) ≡⟨⟩ + suc m + suc m * n ∎ + +------------------------------------------------------------------------ +-- Algebraic properties of _*_ + +*-identityˡ : LeftIdentity 1 _*_ +*-identityˡ n = +-identityʳ n + +*-identityʳ : RightIdentity 1 _*_ +*-identityʳ zero = refl +*-identityʳ (suc n) = cong suc (*-identityʳ n) + +*-identity : Identity 1 _*_ +*-identity = *-identityˡ , *-identityʳ + +*-zeroˡ : LeftZero 0 _*_ +*-zeroˡ _ = refl + +*-zeroʳ : RightZero 0 _*_ +*-zeroʳ zero = refl +*-zeroʳ (suc n) = *-zeroʳ n + +*-zero : Zero 0 _*_ +*-zero = *-zeroˡ , *-zeroʳ + +*-comm : Commutative _*_ +*-comm zero n = sym (*-zeroʳ n) +*-comm (suc m) n = begin-equality + suc m * n ≡⟨⟩ + n + m * n ≡⟨ cong (n +_) (*-comm m n) ⟩ + n + n * m ≡⟨ sym (*-suc n m) ⟩ + n * suc m ∎ + +*-distribʳ-+ : _*_ DistributesOverʳ _+_ +*-distribʳ-+ m zero o = refl +*-distribʳ-+ m (suc n) o = begin-equality + (suc n + o) * m ≡⟨⟩ + m + (n + o) * m ≡⟨ cong (m +_) (*-distribʳ-+ m n o) ⟩ + m + (n * m + o * m) ≡⟨ sym (+-assoc m (n * m) (o * m)) ⟩ + m + n * m + o * m ≡⟨⟩ + suc n * m + o * m ∎ + +*-distribˡ-+ : _*_ DistributesOverˡ _+_ +*-distribˡ-+ = comm∧distrʳ⇒distrˡ *-comm *-distribʳ-+ + +*-distrib-+ : _*_ DistributesOver _+_ +*-distrib-+ = *-distribˡ-+ , *-distribʳ-+ + +*-assoc : Associative _*_ +*-assoc zero n o = refl +*-assoc (suc m) n o = begin-equality + (suc m * n) * o ≡⟨⟩ + (n + m * n) * o ≡⟨ *-distribʳ-+ o n (m * n) ⟩ + n * o + (m * n) * o ≡⟨ cong (n * o +_) (*-assoc m n o) ⟩ + n * o + m * (n * o) ≡⟨⟩ + suc m * (n * o) ∎ + +------------------------------------------------------------------------ +-- Structures + +*-isMagma : IsMagma _*_ +*-isMagma = record + { isEquivalence = isEquivalence + ; ∙-cong = cong₂ _*_ + } + +*-isSemigroup : IsSemigroup _*_ +*-isSemigroup = record + { isMagma = *-isMagma + ; assoc = *-assoc + } + +*-isCommutativeSemigroup : IsCommutativeSemigroup _*_ +*-isCommutativeSemigroup = record + { isSemigroup = *-isSemigroup + ; comm = *-comm + } + +*-1-isMonoid : IsMonoid _*_ 1 +*-1-isMonoid = record + { isSemigroup = *-isSemigroup + ; identity = *-identity + } + +*-1-isCommutativeMonoid : IsCommutativeMonoid _*_ 1 +*-1-isCommutativeMonoid = record + { isMonoid = *-1-isMonoid + ; comm = *-comm + } + ++-*-isSemiring : IsSemiring _+_ _*_ 0 1 ++-*-isSemiring = record + { isSemiringWithoutAnnihilatingZero = record + { +-isCommutativeMonoid = +-0-isCommutativeMonoid + ; *-cong = cong₂ _*_ + ; *-assoc = *-assoc + ; *-identity = *-identity + ; distrib = *-distrib-+ + } + ; zero = *-zero + } + ++-*-isCommutativeSemiring : IsCommutativeSemiring _+_ _*_ 0 1 ++-*-isCommutativeSemiring = record + { isSemiring = +-*-isSemiring + ; *-comm = *-comm + } + +------------------------------------------------------------------------ +-- Bundles + +*-magma : Magma 0ℓ 0ℓ +*-magma = record + { isMagma = *-isMagma + } + +*-semigroup : Semigroup 0ℓ 0ℓ +*-semigroup = record + { isSemigroup = *-isSemigroup + } + +*-commutativeSemigroup : CommutativeSemigroup 0ℓ 0ℓ +*-commutativeSemigroup = record + { isCommutativeSemigroup = *-isCommutativeSemigroup + } + +*-1-monoid : Monoid 0ℓ 0ℓ +*-1-monoid = record + { isMonoid = *-1-isMonoid + } + +*-1-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ +*-1-commutativeMonoid = record + { isCommutativeMonoid = *-1-isCommutativeMonoid + } + ++-*-semiring : Semiring 0ℓ 0ℓ ++-*-semiring = record + { isSemiring = +-*-isSemiring + } + ++-*-commutativeSemiring : CommutativeSemiring 0ℓ 0ℓ ++-*-commutativeSemiring = record + { isCommutativeSemiring = +-*-isCommutativeSemiring + } + +------------------------------------------------------------------------ +-- Other properties of _*_ and _≡_ + +*-cancelʳ-≡ : ∀ m n o .{{_ : NonZero o}} → m * o ≡ n * o → m ≡ n +*-cancelʳ-≡ zero zero (suc o) eq = refl +*-cancelʳ-≡ (suc m) (suc n) (suc o) eq = + cong suc (*-cancelʳ-≡ m n (suc o) (+-cancelˡ-≡ (suc o) (m * suc o) (n * suc o) eq)) + +*-cancelˡ-≡ : ∀ m n o .{{_ : NonZero o}} → o * m ≡ o * n → m ≡ n +*-cancelˡ-≡ m n o rewrite *-comm o m | *-comm o n = *-cancelʳ-≡ m n o + +m*n≡0⇒m≡0∨n≡0 : ∀ m {n} → m * n ≡ 0 → m ≡ 0 ⊎ n ≡ 0 +m*n≡0⇒m≡0∨n≡0 zero {n} eq = inj₁ refl +m*n≡0⇒m≡0∨n≡0 (suc m) {zero} eq = inj₂ refl + +m*n≢0 : ∀ m n → .{{_ : NonZero m}} .{{_ : NonZero n}} → NonZero (m * n) +m*n≢0 (suc m) (suc n) = _ + +m*n≢0⇒m≢0 : ∀ m {n} → .{{NonZero (m * n)}} → NonZero m +m*n≢0⇒m≢0 (suc _) = _ + +m*n≢0⇒n≢0 : ∀ m {n} → .{{NonZero (m * n)}} → NonZero n +m*n≢0⇒n≢0 m {n} rewrite *-comm m n = m*n≢0⇒m≢0 n {m} + +m*n≡0⇒m≡0 : ∀ m n .{{_ : NonZero n}} → m * n ≡ 0 → m ≡ 0 +m*n≡0⇒m≡0 zero (suc _) eq = refl + +m*n≡1⇒m≡1 : ∀ m n → m * n ≡ 1 → m ≡ 1 +m*n≡1⇒m≡1 (suc zero) n _ = refl +m*n≡1⇒m≡1 (suc (suc m)) (suc zero) () +m*n≡1⇒m≡1 (suc (suc m)) zero eq = + contradiction (trans (sym $ *-zeroʳ m) eq) λ() + +m*n≡1⇒n≡1 : ∀ m n → m * n ≡ 1 → n ≡ 1 +m*n≡1⇒n≡1 m n eq = m*n≡1⇒m≡1 n m (trans (*-comm n m) eq) + +[m*n]*[o*p]≡[m*o]*[n*p] : ∀ m n o p → (m * n) * (o * p) ≡ (m * o) * (n * p) +[m*n]*[o*p]≡[m*o]*[n*p] m n o p = begin-equality + (m * n) * (o * p) ≡⟨ *-assoc m n (o * p) ⟩ + m * (n * (o * p)) ≡⟨ cong (m *_) (x∙yz≈y∙xz n o p) ⟩ + m * (o * (n * p)) ≡⟨ *-assoc m o (n * p) ⟨ + (m * o) * (n * p) ∎ + where open CommSemigroupProperties *-commutativeSemigroup + +m≢0∧n>1⇒m*n>1 : ∀ m n .{{_ : NonZero m}} .{{_ : NonTrivial n}} → NonTrivial (m * n) +m≢0∧n>1⇒m*n>1 (suc m) (2+ n) = _ + +n≢0∧m>1⇒m*n>1 : ∀ m n .{{_ : NonZero n}} .{{_ : NonTrivial m}} → NonTrivial (m * n) +n≢0∧m>1⇒m*n>1 m n rewrite *-comm m n = m≢0∧n>1⇒m*n>1 n m + +------------------------------------------------------------------------ +-- Other properties of _*_ and _≤_/_<_ + +*-cancelʳ-≤ : ∀ m n o .{{_ : NonZero o}} → m * o ≤ n * o → m ≤ n +*-cancelʳ-≤ zero _ (suc o) _ = z≤n +*-cancelʳ-≤ (suc m) (suc n) (suc o) le = + s≤s (*-cancelʳ-≤ m n (suc o) (+-cancelˡ-≤ _ _ _ le)) + +*-cancelˡ-≤ : ∀ o .{{_ : NonZero o}} → o * m ≤ o * n → m ≤ n +*-cancelˡ-≤ {m} {n} o rewrite *-comm o m | *-comm o n = *-cancelʳ-≤ m n o + +*-mono-≤ : _*_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ +*-mono-≤ z≤n _ = z≤n +*-mono-≤ (s≤s m≤n) u≤v = +-mono-≤ u≤v (*-mono-≤ m≤n u≤v) + +*-monoˡ-≤ : ∀ n → (_* n) Preserves _≤_ ⟶ _≤_ +*-monoˡ-≤ n m≤o = *-mono-≤ m≤o (≤-refl {n}) + +*-monoʳ-≤ : ∀ n → (n *_) Preserves _≤_ ⟶ _≤_ +*-monoʳ-≤ n m≤o = *-mono-≤ (≤-refl {n}) m≤o + +*-mono-< : _*_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_ +*-mono-< z<s u<v@(s≤s _) = 0<1+n +*-mono-< (s<s m<n@(s≤s _)) u<v@(s≤s _) = +-mono-< u<v (*-mono-< m<n u<v) + +*-monoˡ-< : ∀ n .{{_ : NonZero n}} → (_* n) Preserves _<_ ⟶ _<_ +*-monoˡ-< (suc n) z<s = 0<1+n +*-monoˡ-< (suc n) (s<s m<o@(s≤s _)) = + +-mono-≤-< (≤-refl {suc n}) (*-monoˡ-< (suc n) m<o) + +*-monoʳ-< : ∀ n .{{_ : NonZero n}} → (n *_) Preserves _<_ ⟶ _<_ +*-monoʳ-< (suc zero) m<o@(s≤s _) = +-mono-≤ m<o z≤n +*-monoʳ-< (suc n@(suc _)) m<o@(s≤s _) = + +-mono-≤ m<o (<⇒≤ (*-monoʳ-< n m<o)) + +m≤m*n : ∀ m n .{{_ : NonZero n}} → m ≤ m * n +m≤m*n m n@(suc _) = begin + m ≡⟨ sym (*-identityʳ m) ⟩ + m * 1 ≤⟨ *-monoʳ-≤ m 0<1+n ⟩ + m * n ∎ + +m≤n*m : ∀ m n .{{_ : NonZero n}} → m ≤ n * m +m≤n*m m n@(suc _) = begin + m ≤⟨ m≤m*n m n ⟩ + m * n ≡⟨ *-comm m n ⟩ + n * m ∎ + +m<m*n : ∀ m n .{{_ : NonZero m}} → 1 < n → m < m * n +m<m*n m@(suc m-1) n@(suc (suc n-2)) (s≤s (s≤s _)) = begin-strict + m <⟨ s≤s (s≤s (m≤n+m m-1 n-2)) ⟩ + n + m-1 ≤⟨ +-monoʳ-≤ n (m≤m*n m-1 n) ⟩ + n + m-1 * n ≡⟨⟩ + m * n ∎ + +m<n⇒m<n*o : ∀ o .{{_ : NonZero o}} → m < n → m < n * o +m<n⇒m<n*o {n = n} o m<n = <-≤-trans m<n (m≤m*n n o) + +m<n⇒m<o*n : ∀ {m n} o .{{_ : NonZero o}} → m < n → m < o * n +m<n⇒m<o*n {m} {n} o m<n = begin-strict + m <⟨ m<n⇒m<n*o o m<n ⟩ + n * o ≡⟨ *-comm n o ⟩ + o * n ∎ + +*-cancelʳ-< : RightCancellative _<_ _*_ +*-cancelʳ-< zero zero (suc o) _ = 0<1+n +*-cancelʳ-< (suc m) zero (suc o) _ = 0<1+n +*-cancelʳ-< m (suc n) (suc o) nm<om = + s≤s (*-cancelʳ-< m n o (+-cancelˡ-< m _ _ nm<om)) + +*-cancelˡ-< : LeftCancellative _<_ _*_ +*-cancelˡ-< x y z rewrite *-comm x y | *-comm x z = *-cancelʳ-< x y z + +*-cancel-< : Cancellative _<_ _*_ +*-cancel-< = *-cancelˡ-< , *-cancelʳ-< + +------------------------------------------------------------------------ +-- Properties of _^_ +------------------------------------------------------------------------ + +^-identityʳ : RightIdentity 1 _^_ +^-identityʳ zero = refl +^-identityʳ (suc n) = cong suc (^-identityʳ n) + +^-zeroˡ : LeftZero 1 _^_ +^-zeroˡ zero = refl +^-zeroˡ (suc n) = begin-equality + 1 ^ suc n ≡⟨⟩ + 1 * (1 ^ n) ≡⟨ *-identityˡ (1 ^ n) ⟩ + 1 ^ n ≡⟨ ^-zeroˡ n ⟩ + 1 ∎ + +^-distribˡ-+-* : ∀ m n o → m ^ (n + o) ≡ m ^ n * m ^ o +^-distribˡ-+-* m zero o = sym (+-identityʳ (m ^ o)) +^-distribˡ-+-* m (suc n) o = begin-equality + m * (m ^ (n + o)) ≡⟨ cong (m *_) (^-distribˡ-+-* m n o) ⟩ + m * ((m ^ n) * (m ^ o)) ≡⟨ sym (*-assoc m _ _) ⟩ + (m * (m ^ n)) * (m ^ o) ∎ + +^-semigroup-morphism : ∀ {n} → (n ^_) Is +-semigroup -Semigroup⟶ *-semigroup +^-semigroup-morphism = record + { ⟦⟧-cong = cong (_ ^_) + ; ∙-homo = ^-distribˡ-+-* _ + } + +^-monoid-morphism : ∀ {n} → (n ^_) Is +-0-monoid -Monoid⟶ *-1-monoid +^-monoid-morphism = record + { sm-homo = ^-semigroup-morphism + ; ε-homo = refl + } + +^-*-assoc : ∀ m n o → (m ^ n) ^ o ≡ m ^ (n * o) +^-*-assoc m n zero = cong (m ^_) (sym $ *-zeroʳ n) +^-*-assoc m n (suc o) = begin-equality + (m ^ n) * ((m ^ n) ^ o) ≡⟨ cong ((m ^ n) *_) (^-*-assoc m n o) ⟩ + (m ^ n) * (m ^ (n * o)) ≡⟨ sym (^-distribˡ-+-* m n (n * o)) ⟩ + m ^ (n + n * o) ≡⟨ cong (m ^_) (sym (*-suc n o)) ⟩ + m ^ (n * (suc o)) ∎ + +m^n≡0⇒m≡0 : ∀ m n → m ^ n ≡ 0 → m ≡ 0 +m^n≡0⇒m≡0 m (suc n) eq = [ id , m^n≡0⇒m≡0 m n ]′ (m*n≡0⇒m≡0∨n≡0 m eq) + +m^n≡1⇒n≡0∨m≡1 : ∀ m n → m ^ n ≡ 1 → n ≡ 0 ⊎ m ≡ 1 +m^n≡1⇒n≡0∨m≡1 m zero _ = inj₁ refl +m^n≡1⇒n≡0∨m≡1 m (suc n) eq = inj₂ (m*n≡1⇒m≡1 m (m ^ n) eq) + +m^n≢0 : ∀ m n .{{_ : NonZero m}} → NonZero (m ^ n) +m^n≢0 m n = ≢-nonZero (≢-nonZero⁻¹ m ∘′ m^n≡0⇒m≡0 m n) + +m^n>0 : ∀ m .{{_ : NonZero m}} n → m ^ n > 0 +m^n>0 m n = >-nonZero⁻¹ (m ^ n) {{m^n≢0 m n}} + +^-monoˡ-≤ : ∀ n → (_^ n) Preserves _≤_ ⟶ _≤_ +^-monoˡ-≤ zero m≤o = s≤s z≤n +^-monoˡ-≤ (suc n) m≤o = *-mono-≤ m≤o (^-monoˡ-≤ n m≤o) + +^-monoʳ-≤ : ∀ m .{{_ : NonZero m}} → (m ^_) Preserves _≤_ ⟶ _≤_ +^-monoʳ-≤ m {_} {o} z≤n = n≢0⇒n>0 (≢-nonZero⁻¹ (m ^ o) {{m^n≢0 m o}}) +^-monoʳ-≤ m (s≤s n≤o) = *-monoʳ-≤ m (^-monoʳ-≤ m n≤o) + +^-monoˡ-< : ∀ n .{{_ : NonZero n}} → (_^ n) Preserves _<_ ⟶ _<_ +^-monoˡ-< (suc zero) m<o = *-monoˡ-< 1 m<o +^-monoˡ-< (suc n@(suc _)) m<o = *-mono-< m<o (^-monoˡ-< n m<o) + +^-monoʳ-< : ∀ m → 1 < m → (m ^_) Preserves _<_ ⟶ _<_ +^-monoʳ-< m@(suc _) 1<m {zero} {suc o} z<s = *-mono-≤ 1<m (m^n>0 m o) +^-monoʳ-< m@(suc _) 1<m {suc n} {suc o} (s<s n<o) = *-monoʳ-< m (^-monoʳ-< m 1<m n<o) + +------------------------------------------------------------------------ +-- Properties of _⊓_ and _⊔_ +------------------------------------------------------------------------ +-- Basic specification in terms of _≤_ + +m≤n⇒m⊔n≡n : m ≤ n → m ⊔ n ≡ n +m≤n⇒m⊔n≡n {zero} _ = refl +m≤n⇒m⊔n≡n {suc m} (s≤s m≤n) = cong suc (m≤n⇒m⊔n≡n m≤n) + +m≥n⇒m⊔n≡m : m ≥ n → m ⊔ n ≡ m +m≥n⇒m⊔n≡m {zero} {zero} z≤n = refl +m≥n⇒m⊔n≡m {suc m} {zero} z≤n = refl +m≥n⇒m⊔n≡m {suc m} {suc n} (s≤s m≥n) = cong suc (m≥n⇒m⊔n≡m m≥n) + +m≤n⇒m⊓n≡m : m ≤ n → m ⊓ n ≡ m +m≤n⇒m⊓n≡m {zero} z≤n = refl +m≤n⇒m⊓n≡m {suc m} (s≤s m≤n) = cong suc (m≤n⇒m⊓n≡m m≤n) + +m≥n⇒m⊓n≡n : m ≥ n → m ⊓ n ≡ n +m≥n⇒m⊓n≡n {zero} {zero} z≤n = refl +m≥n⇒m⊓n≡n {suc m} {zero} z≤n = refl +m≥n⇒m⊓n≡n {suc m} {suc n} (s≤s m≤n) = cong suc (m≥n⇒m⊓n≡n m≤n) + +⊓-operator : MinOperator ≤-totalPreorder +⊓-operator = record + { x≤y⇒x⊓y≈x = m≤n⇒m⊓n≡m + ; x≥y⇒x⊓y≈y = m≥n⇒m⊓n≡n + } + +⊔-operator : MaxOperator ≤-totalPreorder +⊔-operator = record + { x≤y⇒x⊔y≈y = m≤n⇒m⊔n≡n + ; x≥y⇒x⊔y≈x = m≥n⇒m⊔n≡m + } + +------------------------------------------------------------------------ +-- Equality to their counterparts defined in terms of primitive operations + +⊔≡⊔′ : ∀ m n → m ⊔ n ≡ m ⊔′ n +⊔≡⊔′ m n with m <ᵇ n in eq +... | false = m≥n⇒m⊔n≡m (≮⇒≥ (λ m<n → subst T eq (<⇒<ᵇ m<n))) +... | true = m≤n⇒m⊔n≡n (<⇒≤ (<ᵇ⇒< m n (subst T (sym eq) _))) + +⊓≡⊓′ : ∀ m n → m ⊓ n ≡ m ⊓′ n +⊓≡⊓′ m n with m <ᵇ n in eq +... | false = m≥n⇒m⊓n≡n (≮⇒≥ (λ m<n → subst T eq (<⇒<ᵇ m<n))) +... | true = m≤n⇒m⊓n≡m (<⇒≤ (<ᵇ⇒< m n (subst T (sym eq) _))) + +------------------------------------------------------------------------ +-- Derived properties of _⊓_ and _⊔_ + +private + module ⊓-⊔-properties = MinMaxOp ⊓-operator ⊔-operator + module ⊓-⊔-latticeProperties = LatticeMinMaxOp ⊓-operator ⊔-operator + +open ⊓-⊔-properties public + using + ( ⊓-idem -- : Idempotent _⊓_ + ; ⊓-sel -- : Selective _⊓_ + ; ⊓-assoc -- : Associative _⊓_ + ; ⊓-comm -- : Commutative _⊓_ + + ; ⊔-idem -- : Idempotent _⊔_ + ; ⊔-sel -- : Selective _⊔_ + ; ⊔-assoc -- : Associative _⊔_ + ; ⊔-comm -- : Commutative _⊔_ + + ; ⊓-distribˡ-⊔ -- : _⊓_ DistributesOverˡ _⊔_ + ; ⊓-distribʳ-⊔ -- : _⊓_ DistributesOverʳ _⊔_ + ; ⊓-distrib-⊔ -- : _⊓_ DistributesOver _⊔_ + ; ⊔-distribˡ-⊓ -- : _⊔_ DistributesOverˡ _⊓_ + ; ⊔-distribʳ-⊓ -- : _⊔_ DistributesOverʳ _⊓_ + ; ⊔-distrib-⊓ -- : _⊔_ DistributesOver _⊓_ + ; ⊓-absorbs-⊔ -- : _⊓_ Absorbs _⊔_ + ; ⊔-absorbs-⊓ -- : _⊔_ Absorbs _⊓_ + ; ⊔-⊓-absorptive -- : Absorptive _⊔_ _⊓_ + ; ⊓-⊔-absorptive -- : Absorptive _⊓_ _⊔_ + + ; ⊓-isMagma -- : IsMagma _⊓_ + ; ⊓-isSemigroup -- : IsSemigroup _⊓_ + ; ⊓-isCommutativeSemigroup -- : IsCommutativeSemigroup _⊓_ + ; ⊓-isBand -- : IsBand _⊓_ + ; ⊓-isSelectiveMagma -- : IsSelectiveMagma _⊓_ + + ; ⊔-isMagma -- : IsMagma _⊔_ + ; ⊔-isSemigroup -- : IsSemigroup _⊔_ + ; ⊔-isCommutativeSemigroup -- : IsCommutativeSemigroup _⊔_ + ; ⊔-isBand -- : IsBand _⊔_ + ; ⊔-isSelectiveMagma -- : IsSelectiveMagma _⊔_ + + ; ⊓-magma -- : Magma _ _ + ; ⊓-semigroup -- : Semigroup _ _ + ; ⊓-band -- : Band _ _ + ; ⊓-commutativeSemigroup -- : CommutativeSemigroup _ _ + ; ⊓-selectiveMagma -- : SelectiveMagma _ _ + + ; ⊔-magma -- : Magma _ _ + ; ⊔-semigroup -- : Semigroup _ _ + ; ⊔-band -- : Band _ _ + ; ⊔-commutativeSemigroup -- : CommutativeSemigroup _ _ + ; ⊔-selectiveMagma -- : SelectiveMagma _ _ + + ; ⊓-glb -- : ∀ {m n o} → m ≥ o → n ≥ o → m ⊓ n ≥ o + ; ⊓-triangulate -- : ∀ m n o → m ⊓ n ⊓ o ≡ (m ⊓ n) ⊓ (n ⊓ o) + ; ⊓-mono-≤ -- : _⊓_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ + ; ⊓-monoˡ-≤ -- : ∀ n → (_⊓ n) Preserves _≤_ ⟶ _≤_ + ; ⊓-monoʳ-≤ -- : ∀ n → (n ⊓_) Preserves _≤_ ⟶ _≤_ + + ; ⊔-lub -- : ∀ {m n o} → m ≤ o → n ≤ o → m ⊔ n ≤ o + ; ⊔-triangulate -- : ∀ m n o → m ⊔ n ⊔ o ≡ (m ⊔ n) ⊔ (n ⊔ o) + ; ⊔-mono-≤ -- : _⊔_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ + ; ⊔-monoˡ-≤ -- : ∀ n → (_⊔ n) Preserves _≤_ ⟶ _≤_ + ; ⊔-monoʳ-≤ -- : ∀ n → (n ⊔_) Preserves _≤_ ⟶ _≤_ + ) + renaming + ( x⊓y≈y⇒y≤x to m⊓n≡n⇒n≤m -- : ∀ {m n} → m ⊓ n ≡ n → n ≤ m + ; x⊓y≈x⇒x≤y to m⊓n≡m⇒m≤n -- : ∀ {m n} → m ⊓ n ≡ m → m ≤ n + ; x⊓y≤x to m⊓n≤m -- : ∀ m n → m ⊓ n ≤ m + ; x⊓y≤y to m⊓n≤n -- : ∀ m n → m ⊓ n ≤ n + ; x≤y⇒x⊓z≤y to m≤n⇒m⊓o≤n -- : ∀ {m n} o → m ≤ n → m ⊓ o ≤ n + ; x≤y⇒z⊓x≤y to m≤n⇒o⊓m≤n -- : ∀ {m n} o → m ≤ n → o ⊓ m ≤ n + ; x≤y⊓z⇒x≤y to m≤n⊓o⇒m≤n -- : ∀ {m} n o → m ≤ n ⊓ o → m ≤ n + ; x≤y⊓z⇒x≤z to m≤n⊓o⇒m≤o -- : ∀ {m} n o → m ≤ n ⊓ o → m ≤ o + + ; x⊔y≈y⇒x≤y to m⊔n≡n⇒m≤n -- : ∀ {m n} → m ⊔ n ≡ n → m ≤ n + ; x⊔y≈x⇒y≤x to m⊔n≡m⇒n≤m -- : ∀ {m n} → m ⊔ n ≡ m → n ≤ m + ; x≤x⊔y to m≤m⊔n -- : ∀ m n → m ≤ m ⊔ n + ; x≤y⊔x to m≤n⊔m -- : ∀ m n → m ≤ n ⊔ m + ; x≤y⇒x≤y⊔z to m≤n⇒m≤n⊔o -- : ∀ {m n} o → m ≤ n → m ≤ n ⊔ o + ; x≤y⇒x≤z⊔y to m≤n⇒m≤o⊔n -- : ∀ {m n} o → m ≤ n → m ≤ o ⊔ n + ; x⊔y≤z⇒x≤z to m⊔n≤o⇒m≤o -- : ∀ m n {o} → m ⊔ n ≤ o → m ≤ o + ; x⊔y≤z⇒y≤z to m⊔n≤o⇒n≤o -- : ∀ m n {o} → m ⊔ n ≤ o → n ≤ o + + ; x⊓y≤x⊔y to m⊓n≤m⊔n -- : ∀ m n → m ⊓ n ≤ m ⊔ n + ) + +open ⊓-⊔-latticeProperties public + using + ( ⊓-isSemilattice -- : IsSemilattice _⊓_ + ; ⊔-isSemilattice -- : IsSemilattice _⊔_ + ; ⊔-⊓-isLattice -- : IsLattice _⊔_ _⊓_ + ; ⊓-⊔-isLattice -- : IsLattice _⊓_ _⊔_ + ; ⊔-⊓-isDistributiveLattice -- : IsDistributiveLattice _⊔_ _⊓_ + ; ⊓-⊔-isDistributiveLattice -- : IsDistributiveLattice _⊓_ _⊔_ + + ; ⊓-semilattice -- : Semilattice _ _ + ; ⊔-semilattice -- : Semilattice _ _ + ; ⊔-⊓-lattice -- : Lattice _ _ + ; ⊓-⊔-lattice -- : Lattice _ _ + ; ⊔-⊓-distributiveLattice -- : DistributiveLattice _ _ + ; ⊓-⊔-distributiveLattice -- : DistributiveLattice _ _ + ) + +------------------------------------------------------------------------ +-- Automatically derived properties of _⊓_ and _⊔_ + +⊔-identityˡ : LeftIdentity 0 _⊔_ +⊔-identityˡ _ = refl + +⊔-identityʳ : RightIdentity 0 _⊔_ +⊔-identityʳ zero = refl +⊔-identityʳ (suc n) = refl + +⊔-identity : Identity 0 _⊔_ +⊔-identity = ⊔-identityˡ , ⊔-identityʳ + +------------------------------------------------------------------------ +-- Structures + +⊔-0-isMonoid : IsMonoid _⊔_ 0 +⊔-0-isMonoid = record + { isSemigroup = ⊔-isSemigroup + ; identity = ⊔-identity + } + +⊔-0-isCommutativeMonoid : IsCommutativeMonoid _⊔_ 0 +⊔-0-isCommutativeMonoid = record + { isMonoid = ⊔-0-isMonoid + ; comm = ⊔-comm + } + +------------------------------------------------------------------------ +-- Bundles + +⊔-0-monoid : Monoid 0ℓ 0ℓ +⊔-0-monoid = record + { isMonoid = ⊔-0-isMonoid + } + +⊔-0-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ +⊔-0-commutativeMonoid = record + { isCommutativeMonoid = ⊔-0-isCommutativeMonoid + } + +------------------------------------------------------------------------ +-- Other properties of _⊔_ and _≤_/_<_ + +mono-≤-distrib-⊔ : ∀ {f} → f Preserves _≤_ ⟶ _≤_ → + ∀ m n → f (m ⊔ n) ≡ f m ⊔ f n +mono-≤-distrib-⊔ {f} = ⊓-⊔-properties.mono-≤-distrib-⊔ (cong f) + +mono-≤-distrib-⊓ : ∀ {f} → f Preserves _≤_ ⟶ _≤_ → + ∀ m n → f (m ⊓ n) ≡ f m ⊓ f n +mono-≤-distrib-⊓ {f} = ⊓-⊔-properties.mono-≤-distrib-⊓ (cong f) + +antimono-≤-distrib-⊓ : ∀ {f} → f Preserves _≤_ ⟶ _≥_ → + ∀ m n → f (m ⊓ n) ≡ f m ⊔ f n +antimono-≤-distrib-⊓ {f} = ⊓-⊔-properties.antimono-≤-distrib-⊓ (cong f) + +antimono-≤-distrib-⊔ : ∀ {f} → f Preserves _≤_ ⟶ _≥_ → + ∀ m n → f (m ⊔ n) ≡ f m ⊓ f n +antimono-≤-distrib-⊔ {f} = ⊓-⊔-properties.antimono-≤-distrib-⊔ (cong f) + +m<n⇒m<n⊔o : ∀ o → m < n → m < n ⊔ o +m<n⇒m<n⊔o = m≤n⇒m≤n⊔o + +m<n⇒m<o⊔n : ∀ o → m < n → m < o ⊔ n +m<n⇒m<o⊔n = m≤n⇒m≤o⊔n + +m⊔n<o⇒m<o : ∀ m n {o} → m ⊔ n < o → m < o +m⊔n<o⇒m<o m n m⊔n<o = ≤-<-trans (m≤m⊔n m n) m⊔n<o + +m⊔n<o⇒n<o : ∀ m n {o} → m ⊔ n < o → n < o +m⊔n<o⇒n<o m n m⊔n<o = ≤-<-trans (m≤n⊔m m n) m⊔n<o + +⊔-mono-< : _⊔_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_ +⊔-mono-< = ⊔-mono-≤ + +⊔-pres-<m : n < m → o < m → n ⊔ o < m +⊔-pres-<m {m = m} n<m o<m = subst (_ <_) (⊔-idem m) (⊔-mono-< n<m o<m) + +------------------------------------------------------------------------ +-- Other properties of _⊔_ and _+_ + ++-distribˡ-⊔ : _+_ DistributesOverˡ _⊔_ ++-distribˡ-⊔ zero n o = refl ++-distribˡ-⊔ (suc m) n o = cong suc (+-distribˡ-⊔ m n o) + ++-distribʳ-⊔ : _+_ DistributesOverʳ _⊔_ ++-distribʳ-⊔ = comm∧distrˡ⇒distrʳ +-comm +-distribˡ-⊔ + ++-distrib-⊔ : _+_ DistributesOver _⊔_ ++-distrib-⊔ = +-distribˡ-⊔ , +-distribʳ-⊔ -≤′⇒≤ : _≤′_ ⇒ _≤_ -≤′⇒≤ ≤′-refl = ≤-refl -≤′⇒≤ (≤′-step m≤′n) = m≤n⇒m≤1+n (≤′⇒≤ m≤′n) +m⊔n≤m+n : ∀ m n → m ⊔ n ≤ m + n +m⊔n≤m+n m n with ⊔-sel m n +... | inj₁ m⊔n≡m rewrite m⊔n≡m = m≤m+n m n +... | inj₂ m⊔n≡n rewrite m⊔n≡n = m≤n+m n m -≤⇒≤′ : _≤_ ⇒ _≤′_ -≤⇒≤′ z≤n = z≤′n -≤⇒≤′ (s≤s m≤n) = s≤′s (≤⇒≤′ m≤n) +------------------------------------------------------------------------ +-- Other properties of _⊔_ and _*_ -≤′-step-injective : ∀ {m n} {p q : m ≤′ n} → ≤′-step p ≡ ≤′-step q → p ≡ q -≤′-step-injective refl = refl +*-distribˡ-⊔ : _*_ DistributesOverˡ _⊔_ +*-distribˡ-⊔ m zero o = sym (cong (_⊔ m * o) (*-zeroʳ m)) +*-distribˡ-⊔ m (suc n) zero = begin-equality + m * (suc n ⊔ zero) ≡⟨⟩ + m * suc n ≡⟨ ⊔-identityʳ (m * suc n) ⟨ + m * suc n ⊔ zero ≡⟨ cong (m * suc n ⊔_) (*-zeroʳ m) ⟨ + m * suc n ⊔ m * zero ∎ +*-distribˡ-⊔ m (suc n) (suc o) = begin-equality + m * (suc n ⊔ suc o) ≡⟨⟩ + m * suc (n ⊔ o) ≡⟨ *-suc m (n ⊔ o) ⟩ + m + m * (n ⊔ o) ≡⟨ cong (m +_) (*-distribˡ-⊔ m n o) ⟩ + m + (m * n ⊔ m * o) ≡⟨ +-distribˡ-⊔ m (m * n) (m * o) ⟩ + (m + m * n) ⊔ (m + m * o) ≡⟨ cong₂ _⊔_ (*-suc m n) (*-suc m o) ⟨ + (m * suc n) ⊔ (m * suc o) ∎ + +*-distribʳ-⊔ : _*_ DistributesOverʳ _⊔_ +*-distribʳ-⊔ = comm∧distrˡ⇒distrʳ *-comm *-distribˡ-⊔ + +*-distrib-⊔ : _*_ DistributesOver _⊔_ +*-distrib-⊔ = *-distribˡ-⊔ , *-distribʳ-⊔ + +------------------------------------------------------------------------ +-- Properties of _⊓_ +------------------------------------------------------------------------ + +------------------------------------------------------------------------ +-- Algebraic properties + +⊓-zeroˡ : LeftZero 0 _⊓_ +⊓-zeroˡ _ = refl + +⊓-zeroʳ : RightZero 0 _⊓_ +⊓-zeroʳ zero = refl +⊓-zeroʳ (suc n) = refl + +⊓-zero : Zero 0 _⊓_ +⊓-zero = ⊓-zeroˡ , ⊓-zeroʳ + +------------------------------------------------------------------------ +-- Structures + +⊔-⊓-isSemiringWithoutOne : IsSemiringWithoutOne _⊔_ _⊓_ 0 +⊔-⊓-isSemiringWithoutOne = record + { +-isCommutativeMonoid = ⊔-0-isCommutativeMonoid + ; *-cong = cong₂ _⊓_ + ; *-assoc = ⊓-assoc + ; distrib = ⊓-distrib-⊔ + ; zero = ⊓-zero + } + +⊔-⊓-isCommutativeSemiringWithoutOne + : IsCommutativeSemiringWithoutOne _⊔_ _⊓_ 0 +⊔-⊓-isCommutativeSemiringWithoutOne = record + { isSemiringWithoutOne = ⊔-⊓-isSemiringWithoutOne + ; *-comm = ⊓-comm + } + +------------------------------------------------------------------------ +-- Bundles + +⊔-⊓-commutativeSemiringWithoutOne : CommutativeSemiringWithoutOne 0ℓ 0ℓ +⊔-⊓-commutativeSemiringWithoutOne = record + { isCommutativeSemiringWithoutOne = + ⊔-⊓-isCommutativeSemiringWithoutOne + } + +------------------------------------------------------------------------ +-- Other properties of _⊓_ and _≤_/_<_ + +m<n⇒m⊓o<n : ∀ o → m < n → m ⊓ o < n +m<n⇒m⊓o<n o m<n = ≤-<-trans (m⊓n≤m _ o) m<n + +m<n⇒o⊓m<n : ∀ o → m < n → o ⊓ m < n +m<n⇒o⊓m<n o m<n = ≤-<-trans (m⊓n≤n o _) m<n + +m<n⊓o⇒m<n : ∀ n o → m < n ⊓ o → m < n +m<n⊓o⇒m<n = m≤n⊓o⇒m≤n + +m<n⊓o⇒m<o : ∀ n o → m < n ⊓ o → m < o +m<n⊓o⇒m<o = m≤n⊓o⇒m≤o + +⊓-mono-< : _⊓_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_ +⊓-mono-< = ⊓-mono-≤ + +⊓-pres-m< : m < n → m < o → m < n ⊓ o +⊓-pres-m< {m} m<n m<o = subst (_< _) (⊓-idem m) (⊓-mono-< m<n m<o) + +------------------------------------------------------------------------ +-- Other properties of _⊓_ and _+_ + ++-distribˡ-⊓ : _+_ DistributesOverˡ _⊓_ ++-distribˡ-⊓ zero n o = refl ++-distribˡ-⊓ (suc m) n o = cong suc (+-distribˡ-⊓ m n o) + ++-distribʳ-⊓ : _+_ DistributesOverʳ _⊓_ ++-distribʳ-⊓ = comm∧distrˡ⇒distrʳ +-comm +-distribˡ-⊓ + ++-distrib-⊓ : _+_ DistributesOver _⊓_ ++-distrib-⊓ = +-distribˡ-⊓ , +-distribʳ-⊓ + +m⊓n≤m+n : ∀ m n → m ⊓ n ≤ m + n +m⊓n≤m+n m n with ⊓-sel m n +... | inj₁ m⊓n≡m rewrite m⊓n≡m = m≤m+n m n +... | inj₂ m⊓n≡n rewrite m⊓n≡n = m≤n+m n m + +------------------------------------------------------------------------ +-- Other properties of _⊓_ and _*_ + +*-distribˡ-⊓ : _*_ DistributesOverˡ _⊓_ +*-distribˡ-⊓ m 0 o = begin-equality + m * (0 ⊓ o) ≡⟨⟩ + m * 0 ≡⟨ *-zeroʳ m ⟩ + 0 ≡⟨⟩ + 0 ⊓ (m * o) ≡⟨ cong (_⊓ (m * o)) (*-zeroʳ m) ⟨ + (m * 0) ⊓ (m * o) ∎ +*-distribˡ-⊓ m (suc n) 0 = begin-equality + m * (suc n ⊓ 0) ≡⟨⟩ + m * 0 ≡⟨ *-zeroʳ m ⟩ + 0 ≡⟨ ⊓-zeroʳ (m * suc n) ⟨ + (m * suc n) ⊓ 0 ≡⟨ cong (m * suc n ⊓_) (*-zeroʳ m) ⟨ + (m * suc n) ⊓ (m * 0) ∎ +*-distribˡ-⊓ m (suc n) (suc o) = begin-equality + m * (suc n ⊓ suc o) ≡⟨⟩ + m * suc (n ⊓ o) ≡⟨ *-suc m (n ⊓ o) ⟩ + m + m * (n ⊓ o) ≡⟨ cong (m +_) (*-distribˡ-⊓ m n o) ⟩ + m + (m * n) ⊓ (m * o) ≡⟨ +-distribˡ-⊓ m (m * n) (m * o) ⟩ + (m + m * n) ⊓ (m + m * o) ≡⟨ cong₂ _⊓_ (*-suc m n) (*-suc m o) ⟨ + (m * suc n) ⊓ (m * suc o) ∎ + +*-distribʳ-⊓ : _*_ DistributesOverʳ _⊓_ +*-distribʳ-⊓ = comm∧distrˡ⇒distrʳ *-comm *-distribˡ-⊓ + +*-distrib-⊓ : _*_ DistributesOver _⊓_ +*-distrib-⊓ = *-distribˡ-⊓ , *-distribʳ-⊓ + +------------------------------------------------------------------------ +-- Properties of _∸_ +------------------------------------------------------------------------ + +0∸n≡0 : LeftZero zero _∸_ +0∸n≡0 zero = refl +0∸n≡0 (suc _) = refl + +n∸n≡0 : ∀ n → n ∸ n ≡ 0 +n∸n≡0 zero = refl +n∸n≡0 (suc n) = n∸n≡0 n + +------------------------------------------------------------------------ +-- Properties of _∸_ and pred + +pred[m∸n]≡m∸[1+n] : ∀ m n → pred (m ∸ n) ≡ m ∸ suc n +pred[m∸n]≡m∸[1+n] zero zero = refl +pred[m∸n]≡m∸[1+n] (suc m) zero = refl +pred[m∸n]≡m∸[1+n] zero (suc n) = refl +pred[m∸n]≡m∸[1+n] (suc m) (suc n) = pred[m∸n]≡m∸[1+n] m n + +------------------------------------------------------------------------ +-- Properties of _∸_ and _≤_/_<_ + +m∸n≤m : ∀ m n → m ∸ n ≤ m +m∸n≤m n zero = ≤-refl +m∸n≤m zero (suc n) = ≤-refl +m∸n≤m (suc m) (suc n) = ≤-trans (m∸n≤m m n) (n≤1+n m) + +m≮m∸n : ∀ m n → m ≮ m ∸ n +m≮m∸n m zero = n≮n m +m≮m∸n (suc m) (suc n) = m≮m∸n m n ∘ ≤-trans (n≤1+n (suc m)) + +1+m≢m∸n : ∀ {m} n → suc m ≢ m ∸ n +1+m≢m∸n {m} n eq = m≮m∸n m n (≤-reflexive eq) + +∸-mono : _∸_ Preserves₂ _≤_ ⟶ _≥_ ⟶ _≤_ +∸-mono z≤n (s≤s n₁≥n₂) = z≤n +∸-mono (s≤s m₁≤m₂) (s≤s n₁≥n₂) = ∸-mono m₁≤m₂ n₁≥n₂ +∸-mono m₁≤m₂ (z≤n {n = n₁}) = ≤-trans (m∸n≤m _ n₁) m₁≤m₂ + +∸-monoˡ-≤ : ∀ o → m ≤ n → m ∸ o ≤ n ∸ o +∸-monoˡ-≤ o m≤n = ∸-mono {u = o} m≤n ≤-refl + +∸-monoʳ-≤ : ∀ o → m ≤ n → o ∸ m ≥ o ∸ n +∸-monoʳ-≤ _ m≤n = ∸-mono ≤-refl m≤n + +∸-monoˡ-< : ∀ {m n o} → m < o → n ≤ m → m ∸ n < o ∸ n +∸-monoˡ-< {m} {zero} {o} m<o n≤m = m<o +∸-monoˡ-< {suc m} {suc n} {suc o} (s≤s m<o) (s≤s n≤m) = ∸-monoˡ-< m<o n≤m + +∸-monoʳ-< : ∀ {m n o} → o < n → n ≤ m → m ∸ n < m ∸ o +∸-monoʳ-< {n = suc n} {zero} (s≤s o<n) (s≤s n<m) = s≤s (m∸n≤m _ n) +∸-monoʳ-< {n = suc n} {suc o} (s≤s o<n) (s≤s n<m) = ∸-monoʳ-< o<n n<m + +∸-cancelʳ-≤ : ∀ {m n o} → m ≤ o → o ∸ n ≤ o ∸ m → m ≤ n +∸-cancelʳ-≤ {_} {_} z≤n _ = z≤n +∸-cancelʳ-≤ {suc m} {zero} (s≤s _) o<o∸m = contradiction o<o∸m (m≮m∸n _ m) +∸-cancelʳ-≤ {suc m} {suc n} (s≤s m≤o) o∸n<o∸m = s≤s (∸-cancelʳ-≤ m≤o o∸n<o∸m) + +∸-cancelʳ-< : ∀ {m n o} → o ∸ m < o ∸ n → n < m +∸-cancelʳ-< {zero} {n} {o} o<o∸n = contradiction o<o∸n (m≮m∸n o n) +∸-cancelʳ-< {suc m} {zero} {_} o∸n<o∸m = 0<1+n +∸-cancelʳ-< {suc m} {suc n} {suc o} o∸n<o∸m = s≤s (∸-cancelʳ-< o∸n<o∸m) + +∸-cancelˡ-≡ : n ≤ m → o ≤ m → m ∸ n ≡ m ∸ o → n ≡ o +∸-cancelˡ-≡ {_} z≤n z≤n _ = refl +∸-cancelˡ-≡ {o = suc o} z≤n (s≤s _) eq = contradiction eq (1+m≢m∸n o) +∸-cancelˡ-≡ {n = suc n} (s≤s _) z≤n eq = contradiction (sym eq) (1+m≢m∸n n) +∸-cancelˡ-≡ {_} (s≤s n≤m) (s≤s o≤m) eq = cong suc (∸-cancelˡ-≡ n≤m o≤m eq) + +∸-cancelʳ-≡ : o ≤ m → o ≤ n → m ∸ o ≡ n ∸ o → m ≡ n +∸-cancelʳ-≡ z≤n z≤n eq = eq +∸-cancelʳ-≡ (s≤s o≤m) (s≤s o≤n) eq = cong suc (∸-cancelʳ-≡ o≤m o≤n eq) + +m∸n≡0⇒m≤n : m ∸ n ≡ 0 → m ≤ n +m∸n≡0⇒m≤n {zero} {_} _ = z≤n +m∸n≡0⇒m≤n {suc m} {suc n} eq = s≤s (m∸n≡0⇒m≤n eq) + +m≤n⇒m∸n≡0 : m ≤ n → m ∸ n ≡ 0 +m≤n⇒m∸n≡0 {n = n} z≤n = 0∸n≡0 n +m≤n⇒m∸n≡0 {_} (s≤s m≤n) = m≤n⇒m∸n≡0 m≤n + +m<n⇒0<n∸m : m < n → 0 < n ∸ m +m<n⇒0<n∸m {zero} {suc n} _ = 0<1+n +m<n⇒0<n∸m {suc m} {suc n} (s≤s m<n) = m<n⇒0<n∸m m<n + +m∸n≢0⇒n<m : m ∸ n ≢ 0 → n < m +m∸n≢0⇒n<m {m} {n} m∸n≢0 with n <? m +... | yes n<m = n<m +... | no n≮m = contradiction (m≤n⇒m∸n≡0 (≮⇒≥ n≮m)) m∸n≢0 + +m>n⇒m∸n≢0 : m > n → m ∸ n ≢ 0 +m>n⇒m∸n≢0 {n = suc n} (s≤s m>n) = m>n⇒m∸n≢0 m>n + +m≤n⇒n∸m≤n : m ≤ n → n ∸ m ≤ n +m≤n⇒n∸m≤n z≤n = ≤-refl +m≤n⇒n∸m≤n (s≤s m≤n) = m≤n⇒m≤1+n (m≤n⇒n∸m≤n m≤n) + +------------------------------------------------------------------------ +-- Properties of _∸_ and _+_ + ++-∸-comm : ∀ {m} n {o} → o ≤ m → (m + n) ∸ o ≡ (m ∸ o) + n ++-∸-comm {zero} _ {zero} _ = refl ++-∸-comm {suc m} _ {zero} _ = refl ++-∸-comm {suc m} n {suc o} (s≤s o≤m) = +-∸-comm n o≤m + +∸-+-assoc : ∀ m n o → (m ∸ n) ∸ o ≡ m ∸ (n + o) +∸-+-assoc zero zero o = refl +∸-+-assoc zero (suc n) o = 0∸n≡0 o +∸-+-assoc (suc m) zero o = refl +∸-+-assoc (suc m) (suc n) o = ∸-+-assoc m n o + ++-∸-assoc : ∀ m {n o} → o ≤ n → (m + n) ∸ o ≡ m + (n ∸ o) ++-∸-assoc m (z≤n {n = n}) = begin-equality m + n ∎ ++-∸-assoc m (s≤s {m = o} {n = n} o≤n) = begin-equality + (m + suc n) ∸ suc o ≡⟨ cong (_∸ suc o) (+-suc m n) ⟩ + suc (m + n) ∸ suc o ≡⟨⟩ + (m + n) ∸ o ≡⟨ +-∸-assoc m o≤n ⟩ + m + (n ∸ o) ∎ + +m+n≤o⇒m≤o∸n : ∀ m n o → m + n ≤ o → m ≤ o ∸ n +m+n≤o⇒m≤o∸n zero n o le = z≤n +m+n≤o⇒m≤o∸n (suc m) n (suc o) (s≤s le) + rewrite +-∸-assoc 1 (m+n≤o⇒n≤o m le) = s≤s (m+n≤o⇒m≤o∸n m n o le) + +m≤o∸n⇒m+n≤o : ∀ m {n o} (n≤o : n ≤ o) → m ≤ o ∸ n → m + n ≤ o +m≤o∸n⇒m+n≤o m z≤n le rewrite +-identityʳ m = le +m≤o∸n⇒m+n≤o m {suc n} (s≤s n≤o) le rewrite +-suc m n = s≤s (m≤o∸n⇒m+n≤o m n≤o le) + +m≤n+m∸n : ∀ m n → m ≤ n + (m ∸ n) +m≤n+m∸n zero n = z≤n +m≤n+m∸n (suc m) zero = ≤-refl +m≤n+m∸n (suc m) (suc n) = s≤s (m≤n+m∸n m n) + +m+n∸n≡m : ∀ m n → m + n ∸ n ≡ m +m+n∸n≡m m n = begin-equality + (m + n) ∸ n ≡⟨ +-∸-assoc m (≤-refl {x = n}) ⟩ + m + (n ∸ n) ≡⟨ cong (m +_) (n∸n≡0 n) ⟩ + m + 0 ≡⟨ +-identityʳ m ⟩ + m ∎ + +m+n∸m≡n : ∀ m n → m + n ∸ m ≡ n +m+n∸m≡n m n = trans (cong (_∸ m) (+-comm m n)) (m+n∸n≡m n m) + +m+[n∸m]≡n : m ≤ n → m + (n ∸ m) ≡ n +m+[n∸m]≡n {m} {n} m≤n = begin-equality + m + (n ∸ m) ≡⟨ sym $ +-∸-assoc m m≤n ⟩ + (m + n) ∸ m ≡⟨ cong (_∸ m) (+-comm m n) ⟩ + (n + m) ∸ m ≡⟨ m+n∸n≡m n m ⟩ + n ∎ + +m∸n+n≡m : ∀ {m n} → n ≤ m → (m ∸ n) + n ≡ m +m∸n+n≡m {m} {n} n≤m = begin-equality + (m ∸ n) + n ≡⟨ sym (+-∸-comm n n≤m) ⟩ + (m + n) ∸ n ≡⟨ m+n∸n≡m m n ⟩ + m ∎ + +m∸[m∸n]≡n : ∀ {m n} → n ≤ m → m ∸ (m ∸ n) ≡ n +m∸[m∸n]≡n {m} {_} z≤n = n∸n≡0 m +m∸[m∸n]≡n {suc m} {suc n} (s≤s n≤m) = begin-equality + suc m ∸ (m ∸ n) ≡⟨ +-∸-assoc 1 (m∸n≤m m n) ⟩ + suc (m ∸ (m ∸ n)) ≡⟨ cong suc (m∸[m∸n]≡n n≤m) ⟩ + suc n ∎ + +[m+n]∸[m+o]≡n∸o : ∀ m n o → (m + n) ∸ (m + o) ≡ n ∸ o +[m+n]∸[m+o]≡n∸o zero n o = refl +[m+n]∸[m+o]≡n∸o (suc m) n o = [m+n]∸[m+o]≡n∸o m n o + +------------------------------------------------------------------------ +-- Properties of _∸_ and _*_ + +*-distribʳ-∸ : _*_ DistributesOverʳ _∸_ +*-distribʳ-∸ m zero zero = refl +*-distribʳ-∸ zero zero (suc o) = sym (0∸n≡0 (o * zero)) +*-distribʳ-∸ (suc m) zero (suc o) = refl +*-distribʳ-∸ m (suc n) zero = refl +*-distribʳ-∸ m (suc n) (suc o) = begin-equality + (n ∸ o) * m ≡⟨ *-distribʳ-∸ m n o ⟩ + n * m ∸ o * m ≡⟨ sym $ [m+n]∸[m+o]≡n∸o m _ _ ⟩ + m + n * m ∸ (m + o * m) ∎ + +*-distribˡ-∸ : _*_ DistributesOverˡ _∸_ +*-distribˡ-∸ = comm∧distrʳ⇒distrˡ *-comm *-distribʳ-∸ + +*-distrib-∸ : _*_ DistributesOver _∸_ +*-distrib-∸ = *-distribˡ-∸ , *-distribʳ-∸ + +even≢odd : ∀ m n → 2 * m ≢ suc (2 * n) +even≢odd (suc m) zero eq = contradiction (suc-injective eq) (m+1+n≢0 m) +even≢odd (suc m) (suc n) eq = even≢odd m n (suc-injective (begin-equality + suc (2 * m) ≡⟨ sym (+-suc m _) ⟩ + m + suc (m + 0) ≡⟨ suc-injective eq ⟩ + suc n + suc (n + 0) ≡⟨ cong suc (+-suc n _) ⟩ + suc (suc (2 * n)) ∎)) + +------------------------------------------------------------------------ +-- Properties of _∸_ and _⊓_ and _⊔_ + +m⊓n+n∸m≡n : ∀ m n → (m ⊓ n) + (n ∸ m) ≡ n +m⊓n+n∸m≡n zero n = refl +m⊓n+n∸m≡n (suc m) zero = refl +m⊓n+n∸m≡n (suc m) (suc n) = cong suc $ m⊓n+n∸m≡n m n + +[m∸n]⊓[n∸m]≡0 : ∀ m n → (m ∸ n) ⊓ (n ∸ m) ≡ 0 +[m∸n]⊓[n∸m]≡0 zero zero = refl +[m∸n]⊓[n∸m]≡0 zero (suc n) = refl +[m∸n]⊓[n∸m]≡0 (suc m) zero = refl +[m∸n]⊓[n∸m]≡0 (suc m) (suc n) = [m∸n]⊓[n∸m]≡0 m n + +∸-distribˡ-⊓-⊔ : ∀ m n o → m ∸ (n ⊓ o) ≡ (m ∸ n) ⊔ (m ∸ o) +∸-distribˡ-⊓-⊔ m n o = antimono-≤-distrib-⊓ (∸-monoʳ-≤ m) n o + +∸-distribʳ-⊓ : _∸_ DistributesOverʳ _⊓_ +∸-distribʳ-⊓ m n o = mono-≤-distrib-⊓ (∸-monoˡ-≤ m) n o + +∸-distribˡ-⊔-⊓ : ∀ m n o → m ∸ (n ⊔ o) ≡ (m ∸ n) ⊓ (m ∸ o) +∸-distribˡ-⊔-⊓ m n o = antimono-≤-distrib-⊔ (∸-monoʳ-≤ m) n o + +∸-distribʳ-⊔ : _∸_ DistributesOverʳ _⊔_ +∸-distribʳ-⊔ m n o = mono-≤-distrib-⊔ (∸-monoˡ-≤ m) n o + +------------------------------------------------------------------------ +-- Properties of pred +------------------------------------------------------------------------ + +pred[n]≤n : pred n ≤ n +pred[n]≤n {zero} = z≤n +pred[n]≤n {suc n} = n≤1+n n + +≤pred⇒≤ : m ≤ pred n → m ≤ n +≤pred⇒≤ {n = zero} le = le +≤pred⇒≤ {n = suc n} le = m≤n⇒m≤1+n le + +≤⇒pred≤ : m ≤ n → pred m ≤ n +≤⇒pred≤ {zero} le = le +≤⇒pred≤ {suc m} le = ≤-trans (n≤1+n m) le + +<⇒≤pred : m < n → m ≤ pred n +<⇒≤pred (s≤s le) = le + +suc-pred : ∀ n .{{_ : NonZero n}} → suc (pred n) ≡ n +suc-pred (suc n) = refl + +pred-mono-≤ : pred Preserves _≤_ ⟶ _≤_ +pred-mono-≤ {zero} _ = z≤n +pred-mono-≤ {suc _} {suc _} m≤n = s≤s⁻¹ m≤n + +pred-mono-< : .{{NonZero m}} → m < n → pred m < pred n +pred-mono-< {m = suc _} {n = suc _} = s<s⁻¹ + +------------------------------------------------------------------------ +-- Properties of ∣_-_∣ +------------------------------------------------------------------------ + +------------------------------------------------------------------------ +-- Basic + +m≡n⇒∣m-n∣≡0 : m ≡ n → ∣ m - n ∣ ≡ 0 +m≡n⇒∣m-n∣≡0 {zero} refl = refl +m≡n⇒∣m-n∣≡0 {suc m} refl = m≡n⇒∣m-n∣≡0 {m} refl + +∣m-n∣≡0⇒m≡n : ∣ m - n ∣ ≡ 0 → m ≡ n +∣m-n∣≡0⇒m≡n {zero} {zero} eq = refl +∣m-n∣≡0⇒m≡n {suc m} {suc n} eq = cong suc (∣m-n∣≡0⇒m≡n eq) + +m≤n⇒∣n-m∣≡n∸m : m ≤ n → ∣ n - m ∣ ≡ n ∸ m +m≤n⇒∣n-m∣≡n∸m {n = zero} z≤n = refl +m≤n⇒∣n-m∣≡n∸m {n = suc n} z≤n = refl +m≤n⇒∣n-m∣≡n∸m {n = _} (s≤s m≤n) = m≤n⇒∣n-m∣≡n∸m m≤n + +m≤n⇒∣m-n∣≡n∸m : m ≤ n → ∣ m - n ∣ ≡ n ∸ m +m≤n⇒∣m-n∣≡n∸m {n = zero} z≤n = refl +m≤n⇒∣m-n∣≡n∸m {n = suc n} z≤n = refl +m≤n⇒∣m-n∣≡n∸m {n = _} (s≤s m≤n) = m≤n⇒∣m-n∣≡n∸m m≤n + +∣m-n∣≡m∸n⇒n≤m : ∣ m - n ∣ ≡ m ∸ n → n ≤ m +∣m-n∣≡m∸n⇒n≤m {zero} {zero} eq = z≤n +∣m-n∣≡m∸n⇒n≤m {suc m} {zero} eq = z≤n +∣m-n∣≡m∸n⇒n≤m {suc m} {suc n} eq = s≤s (∣m-n∣≡m∸n⇒n≤m eq) + +∣n-n∣≡0 : ∀ n → ∣ n - n ∣ ≡ 0 +∣n-n∣≡0 n = m≡n⇒∣m-n∣≡0 {n} refl + +∣m-m+n∣≡n : ∀ m n → ∣ m - m + n ∣ ≡ n +∣m-m+n∣≡n zero n = refl +∣m-m+n∣≡n (suc m) n = ∣m-m+n∣≡n m n + +∣m+n-m+o∣≡∣n-o∣ : ∀ m n o → ∣ m + n - m + o ∣ ≡ ∣ n - o ∣ +∣m+n-m+o∣≡∣n-o∣ zero n o = refl +∣m+n-m+o∣≡∣n-o∣ (suc m) n o = ∣m+n-m+o∣≡∣n-o∣ m n o + +m∸n≤∣m-n∣ : ∀ m n → m ∸ n ≤ ∣ m - n ∣ +m∸n≤∣m-n∣ m n with ≤-total m n +... | inj₁ m≤n = subst (_≤ ∣ m - n ∣) (sym (m≤n⇒m∸n≡0 m≤n)) z≤n +... | inj₂ n≤m = subst (m ∸ n ≤_) (sym (m≤n⇒∣n-m∣≡n∸m n≤m)) ≤-refl + +∣m-n∣≤m⊔n : ∀ m n → ∣ m - n ∣ ≤ m ⊔ n +∣m-n∣≤m⊔n zero m = ≤-refl +∣m-n∣≤m⊔n (suc m) zero = ≤-refl +∣m-n∣≤m⊔n (suc m) (suc n) = m≤n⇒m≤1+n (∣m-n∣≤m⊔n m n) + +∣-∣-identityˡ : LeftIdentity 0 ∣_-_∣ +∣-∣-identityˡ x = refl + +∣-∣-identityʳ : RightIdentity 0 ∣_-_∣ +∣-∣-identityʳ zero = refl +∣-∣-identityʳ (suc x) = refl + +∣-∣-identity : Identity 0 ∣_-_∣ +∣-∣-identity = ∣-∣-identityˡ , ∣-∣-identityʳ + +∣-∣-comm : Commutative ∣_-_∣ +∣-∣-comm zero zero = refl +∣-∣-comm zero (suc n) = refl +∣-∣-comm (suc m) zero = refl +∣-∣-comm (suc m) (suc n) = ∣-∣-comm m n + +∣m-n∣≡[m∸n]∨[n∸m] : ∀ m n → (∣ m - n ∣ ≡ m ∸ n) ⊎ (∣ m - n ∣ ≡ n ∸ m) +∣m-n∣≡[m∸n]∨[n∸m] m n with ≤-total m n +... | inj₂ n≤m = inj₁ $ m≤n⇒∣n-m∣≡n∸m n≤m +... | inj₁ m≤n = inj₂ $ begin-equality + ∣ m - n ∣ ≡⟨ ∣-∣-comm m n ⟩ + ∣ n - m ∣ ≡⟨ m≤n⇒∣n-m∣≡n∸m m≤n ⟩ + n ∸ m ∎ + +private + + *-distribˡ-∣-∣-aux : ∀ a m n → m ≤ n → a * ∣ n - m ∣ ≡ ∣ a * n - a * m ∣ + *-distribˡ-∣-∣-aux a m n m≤n = begin-equality + a * ∣ n - m ∣ ≡⟨ cong (a *_) (m≤n⇒∣n-m∣≡n∸m m≤n) ⟩ + a * (n ∸ m) ≡⟨ *-distribˡ-∸ a n m ⟩ + a * n ∸ a * m ≡⟨ sym $′ m≤n⇒∣n-m∣≡n∸m (*-monoʳ-≤ a m≤n) ⟩ + ∣ a * n - a * m ∣ ∎ + +*-distribˡ-∣-∣ : _*_ DistributesOverˡ ∣_-_∣ +*-distribˡ-∣-∣ a m n with ≤-total m n +... | inj₂ n≤m = *-distribˡ-∣-∣-aux a n m n≤m +... | inj₁ m≤n = begin-equality + a * ∣ m - n ∣ ≡⟨ cong (a *_) (∣-∣-comm m n) ⟩ + a * ∣ n - m ∣ ≡⟨ *-distribˡ-∣-∣-aux a m n m≤n ⟩ + ∣ a * n - a * m ∣ ≡⟨ ∣-∣-comm (a * n) (a * m) ⟩ + ∣ a * m - a * n ∣ ∎ + +*-distribʳ-∣-∣ : _*_ DistributesOverʳ ∣_-_∣ +*-distribʳ-∣-∣ = comm∧distrˡ⇒distrʳ *-comm *-distribˡ-∣-∣ + +*-distrib-∣-∣ : _*_ DistributesOver ∣_-_∣ +*-distrib-∣-∣ = *-distribˡ-∣-∣ , *-distribʳ-∣-∣ + +m≤n+∣n-m∣ : ∀ m n → m ≤ n + ∣ n - m ∣ +m≤n+∣n-m∣ zero n = z≤n +m≤n+∣n-m∣ (suc m) zero = ≤-refl +m≤n+∣n-m∣ (suc m) (suc n) = s≤s (m≤n+∣n-m∣ m n) + +m≤n+∣m-n∣ : ∀ m n → m ≤ n + ∣ m - n ∣ +m≤n+∣m-n∣ m n = subst (m ≤_) (cong (n +_) (∣-∣-comm n m)) (m≤n+∣n-m∣ m n) + +m≤∣m-n∣+n : ∀ m n → m ≤ ∣ m - n ∣ + n +m≤∣m-n∣+n m n = subst (m ≤_) (+-comm n _) (m≤n+∣m-n∣ m n) + +∣-∣-triangle : TriangleInequality ∣_-_∣ +∣-∣-triangle zero y z = m≤n+∣n-m∣ z y +∣-∣-triangle x zero z = begin + ∣ x - z ∣ ≤⟨ ∣m-n∣≤m⊔n x z ⟩ + x ⊔ z ≤⟨ m⊔n≤m+n x z ⟩ + x + z ≡⟨ cong₂ _+_ (sym (∣-∣-identityʳ x)) refl ⟩ + ∣ x - 0 ∣ + z ∎ + where open ≤-Reasoning +∣-∣-triangle x y zero = begin + ∣ x - 0 ∣ ≡⟨ ∣-∣-identityʳ x ⟩ + x ≤⟨ m≤∣m-n∣+n x y ⟩ + ∣ x - y ∣ + y ≡⟨ cong₂ _+_ refl (sym (∣-∣-identityʳ y)) ⟩ + ∣ x - y ∣ + ∣ y - 0 ∣ ∎ + where open ≤-Reasoning +∣-∣-triangle (suc x) (suc y) (suc z) = ∣-∣-triangle x y z + +∣-∣≡∣-∣′ : ∀ m n → ∣ m - n ∣ ≡ ∣ m - n ∣′ +∣-∣≡∣-∣′ m n with m <ᵇ n in eq +... | false = m≤n⇒∣n-m∣≡n∸m {n} {m} (≮⇒≥ (λ m<n → subst T eq (<⇒<ᵇ m<n))) +... | true = m≤n⇒∣m-n∣≡n∸m {m} {n} (<⇒≤ (<ᵇ⇒< m n (subst T (sym eq) _))) + +------------------------------------------------------------------------ +-- Metric structures + +∣-∣-isProtoMetric : IsProtoMetric _≡_ ∣_-_∣ +∣-∣-isProtoMetric = record + { isPartialOrder = ≤-isPartialOrder + ; ≈-isEquivalence = isEquivalence + ; cong = cong₂ ∣_-_∣ + ; nonNegative = z≤n + } + +∣-∣-isPreMetric : IsPreMetric _≡_ ∣_-_∣ +∣-∣-isPreMetric = record + { isProtoMetric = ∣-∣-isProtoMetric + ; ≈⇒0 = m≡n⇒∣m-n∣≡0 + } + +∣-∣-isQuasiSemiMetric : IsQuasiSemiMetric _≡_ ∣_-_∣ +∣-∣-isQuasiSemiMetric = record + { isPreMetric = ∣-∣-isPreMetric + ; 0⇒≈ = ∣m-n∣≡0⇒m≡n + } + +∣-∣-isSemiMetric : IsSemiMetric _≡_ ∣_-_∣ +∣-∣-isSemiMetric = record + { isQuasiSemiMetric = ∣-∣-isQuasiSemiMetric + ; sym = ∣-∣-comm + } + +∣-∣-isMetric : IsMetric _≡_ ∣_-_∣ +∣-∣-isMetric = record + { isSemiMetric = ∣-∣-isSemiMetric + ; triangle = ∣-∣-triangle + } + +------------------------------------------------------------------------ +-- Metric bundles + +∣-∣-quasiSemiMetric : QuasiSemiMetric 0ℓ 0ℓ +∣-∣-quasiSemiMetric = record + { isQuasiSemiMetric = ∣-∣-isQuasiSemiMetric + } + +∣-∣-semiMetric : SemiMetric 0ℓ 0ℓ +∣-∣-semiMetric = record + { isSemiMetric = ∣-∣-isSemiMetric + } + +∣-∣-preMetric : PreMetric 0ℓ 0ℓ +∣-∣-preMetric = record + { isPreMetric = ∣-∣-isPreMetric + } + +∣-∣-metric : Metric 0ℓ 0ℓ +∣-∣-metric = record + { isMetric = ∣-∣-isMetric + } + +------------------------------------------------------------------------ +-- Properties of ⌊_/2⌋ and ⌈_/2⌉ +------------------------------------------------------------------------ + +⌊n/2⌋-mono : ⌊_/2⌋ Preserves _≤_ ⟶ _≤_ +⌊n/2⌋-mono z≤n = z≤n +⌊n/2⌋-mono (s≤s z≤n) = z≤n +⌊n/2⌋-mono (s≤s (s≤s m≤n)) = s≤s (⌊n/2⌋-mono m≤n) + +⌈n/2⌉-mono : ⌈_/2⌉ Preserves _≤_ ⟶ _≤_ +⌈n/2⌉-mono m≤n = ⌊n/2⌋-mono (s≤s m≤n) + +⌊n/2⌋≤⌈n/2⌉ : ∀ n → ⌊ n /2⌋ ≤ ⌈ n /2⌉ +⌊n/2⌋≤⌈n/2⌉ zero = z≤n +⌊n/2⌋≤⌈n/2⌉ (suc zero) = z≤n +⌊n/2⌋≤⌈n/2⌉ (suc (suc n)) = s≤s (⌊n/2⌋≤⌈n/2⌉ n) + +⌊n/2⌋+⌈n/2⌉≡n : ∀ n → ⌊ n /2⌋ + ⌈ n /2⌉ ≡ n +⌊n/2⌋+⌈n/2⌉≡n zero = refl +⌊n/2⌋+⌈n/2⌉≡n (suc n) = begin-equality + ⌊ suc n /2⌋ + suc ⌊ n /2⌋ ≡⟨ +-comm ⌊ suc n /2⌋ (suc ⌊ n /2⌋) ⟩ + suc ⌊ n /2⌋ + ⌊ suc n /2⌋ ≡⟨⟩ + suc (⌊ n /2⌋ + ⌊ suc n /2⌋) ≡⟨ cong suc (⌊n/2⌋+⌈n/2⌉≡n n) ⟩ + suc n ∎ + +⌊n/2⌋≤n : ∀ n → ⌊ n /2⌋ ≤ n +⌊n/2⌋≤n zero = z≤n +⌊n/2⌋≤n (suc zero) = z≤n +⌊n/2⌋≤n (suc (suc n)) = s≤s (m≤n⇒m≤1+n (⌊n/2⌋≤n n)) + +⌊n/2⌋<n : ∀ n → ⌊ suc n /2⌋ < suc n +⌊n/2⌋<n zero = z<s +⌊n/2⌋<n (suc n) = s<s (s≤s (⌊n/2⌋≤n n)) + +n≡⌊n+n/2⌋ : ∀ n → n ≡ ⌊ n + n /2⌋ +n≡⌊n+n/2⌋ zero = refl +n≡⌊n+n/2⌋ (suc zero) = refl +n≡⌊n+n/2⌋ (suc n′@(suc n)) = + cong suc (trans (n≡⌊n+n/2⌋ _) (cong ⌊_/2⌋ (sym (+-suc n n′)))) + +⌈n/2⌉≤n : ∀ n → ⌈ n /2⌉ ≤ n +⌈n/2⌉≤n zero = z≤n +⌈n/2⌉≤n (suc n) = s≤s (⌊n/2⌋≤n n) + +⌈n/2⌉<n : ∀ n → ⌈ suc (suc n) /2⌉ < suc (suc n) +⌈n/2⌉<n n = s<s (⌊n/2⌋<n n) + +n≡⌈n+n/2⌉ : ∀ n → n ≡ ⌈ n + n /2⌉ +n≡⌈n+n/2⌉ zero = refl +n≡⌈n+n/2⌉ (suc zero) = refl +n≡⌈n+n/2⌉ (suc n′@(suc n)) = + cong suc (trans (n≡⌈n+n/2⌉ _) (cong ⌈_/2⌉ (sym (+-suc n n′)))) + +------------------------------------------------------------------------ +-- Properties of !_ + +1≤n! : ∀ n → 1 ≤ n ! +1≤n! zero = ≤-refl +1≤n! (suc n) = *-mono-≤ (m≤m+n 1 n) (1≤n! n) + +infix 4 _!≢0 _!*_!≢0 + +_!≢0 : ∀ n → NonZero (n !) +n !≢0 = >-nonZero (1≤n! n) ------------------------------------------------------------------------- --- Properties of _<′_ and _<_ ------------------------------------------------------------------------- +_!*_!≢0 : ∀ m n → NonZero (m ! * n !) +m !* n !≢0 = m*n≢0 _ _ {{m !≢0}} {{n !≢0}} -z<′s : ∀ {n} → zero <′ suc n -z<′s {zero} = <′-base -z<′s {suc n} = <′-step (z<′s {n}) +------------------------------------------------------------------------ +-- Properties of _≤′_ and _<′_ -s<′s : ∀ {m n} → m <′ n → suc m <′ suc n -s<′s <′-base = <′-base -s<′s (<′-step m<′n) = <′-step (s<′s m<′n) +≤′-trans : Transitive _≤′_ +≤′-trans m≤n ≤′-refl = m≤n +≤′-trans m≤n (≤′-step n≤o) = ≤′-step (≤′-trans m≤n n≤o) -<⇒<′ : ∀ {m n} → m < n → m <′ n -<⇒<′ z<s = z<′s -<⇒<′ (s<s m<n@(s≤s _)) = s<′s (<⇒<′ m<n) +z≤′n : zero ≤′ n +z≤′n {zero} = ≤′-refl +z≤′n {suc n} = ≤′-step z≤′n -<′⇒< : ∀ {m n} → m <′ n → m < n -<′⇒< <′-base = n<1+n _ -<′⇒< (<′-step m<′n) = m<n⇒m<1+n (<′⇒< m<′n) +s≤′s : m ≤′ n → suc m ≤′ suc n +s≤′s ≤′-refl = ≤′-refl +s≤′s (≤′-step m≤′n) = ≤′-step (s≤′s m≤′n) -m<1+n⇒m<n∨m≡n′ : ∀ {m n} → m < suc n → m < n ⊎ m ≡ n -m<1+n⇒m<n∨m≡n′ m<n with <⇒<′ m<n -... | <′-base = inj₂ refl -... | <′-step m<′n = inj₁ (<′⇒< m<′n) +≤′⇒≤ : _≤′_ ⇒ _≤_ +≤′⇒≤ ≤′-refl = ≤-refl +≤′⇒≤ (≤′-step m≤′n) = m≤n⇒m≤1+n (≤′⇒≤ m≤′n) ------------------------------------------------------------------------- --- Other properties of _≤′_ and _<′_ ------------------------------------------------------------------------- +≤⇒≤′ : _≤_ ⇒ _≤′_ +≤⇒≤′ z≤n = z≤′n +≤⇒≤′ (s≤s m≤n) = s≤′s (≤⇒≤′ m≤n) -infix 4 _≤′?_ _<′?_ _≥′?_ _>′?_ +≤′-step-injective : {p q : m ≤′ n} → ≤′-step p ≡ ≤′-step q → p ≡ q +≤′-step-injective refl = refl -_≤′?_ : Decidable _≤′_ -m ≤′? n = map′ ≤⇒≤′ ≤′⇒≤ (m ≤? n) +------------------------------------------------------------------------ +-- Properties of _<′_ and _<_ +------------------------------------------------------------------------ -_<′?_ : Decidable _<′_ -m <′? n = suc m ≤′? n +z<′s : zero <′ suc n +z<′s {zero} = <′-base +z<′s {suc n} = <′-step (z<′s {n}) -_≥′?_ : Decidable _≥′_ -_≥′?_ = flip _≤′?_ +s<′s : m <′ n → suc m <′ suc n +s<′s <′-base = <′-base +s<′s (<′-step m<′n) = <′-step (s<′s m<′n) -_>′?_ : Decidable _>′_ -_>′?_ = flip _<′?_ +<⇒<′ : m < n → m <′ n +<⇒<′ z<s = z<′s +<⇒<′ (s<s m<n@(s≤s _)) = s<′s (<⇒<′ m<n) -m≤′m+n : ∀ m n → m ≤′ m + n -m≤′m+n m n = ≤⇒≤′ (m≤m+n m n) +<′⇒< : m <′ n → m < n +<′⇒< <′-base = n<1+n _ +<′⇒< (<′-step m<′n) = m<n⇒m<1+n (<′⇒< m<′n) -n≤′m+n : ∀ m n → n ≤′ m + n -n≤′m+n zero n = ≤′-refl -n≤′m+n (suc m) n = ≤′-step (n≤′m+n m n) +m<1+n⇒m<n∨m≡n′ : m < suc n → m < n ⊎ m ≡ n +m<1+n⇒m<n∨m≡n′ m<n with <⇒<′ m<n +... | <′-base = inj₂ refl +... | <′-step m<′n = inj₁ (<′⇒< m<′n) -⌈n/2⌉≤′n : ∀ n → ⌈ n /2⌉ ≤′ n -⌈n/2⌉≤′n zero = ≤′-refl -⌈n/2⌉≤′n (suc zero) = ≤′-refl -⌈n/2⌉≤′n (suc (suc n)) = s≤′s (≤′-step (⌈n/2⌉≤′n n)) +------------------------------------------------------------------------ +-- Other properties of _≤′_ and _<′_ +------------------------------------------------------------------------ -⌊n/2⌋≤′n : ∀ n → ⌊ n /2⌋ ≤′ n -⌊n/2⌋≤′n zero = ≤′-refl -⌊n/2⌋≤′n (suc n) = ≤′-step (⌈n/2⌉≤′n n) +infix 4 _≤′?_ _<′?_ _≥′?_ _>′?_ ------------------------------------------------------------------------- --- Properties of _≤″_ and _<″_ ------------------------------------------------------------------------- +_≤′?_ : Decidable _≤′_ +m ≤′? n = map′ ≤⇒≤′ ≤′⇒≤ (m ≤? n) -m<ᵇn⇒1+m+[n-1+m]≡n : ∀ m n → T (m <ᵇ n) → suc m + (n ∸ suc m) ≡ n -m<ᵇn⇒1+m+[n-1+m]≡n m n lt = m+[n∸m]≡n (<ᵇ⇒< m n lt) +_<′?_ : Decidable _<′_ +m <′? n = suc m ≤′? n -m<ᵇ1+m+n : ∀ m {n} → T (m <ᵇ suc (m + n)) -m<ᵇ1+m+n m = <⇒<ᵇ (m≤m+n (suc m) _) +_≥′?_ : Decidable _≥′_ +_≥′?_ = flip _≤′?_ -<ᵇ⇒<″ : ∀ {m n} → T (m <ᵇ n) → m <″ n -<ᵇ⇒<″ {m} {n} leq = less-than-or-equal (m+[n∸m]≡n (<ᵇ⇒< m n leq)) +_>′?_ : Decidable _>′_ +_>′?_ = flip _<′?_ -<″⇒<ᵇ : ∀ {m n} → m <″ n → T (m <ᵇ n) -<″⇒<ᵇ {m} (less-than-or-equal refl) = <⇒<ᵇ (m≤m+n (suc m) _) +m≤′m+n : ∀ m n → m ≤′ m + n +m≤′m+n m n = ≤⇒≤′ (m≤m+n m n) --- equivalence to _≤_ +n≤′m+n : ∀ m n → n ≤′ m + n +n≤′m+n zero n = ≤′-refl +n≤′m+n (suc m) n = ≤′-step (n≤′m+n m n) -≤″⇒≤ : _≤″_ ⇒ _≤_ -≤″⇒≤ {zero} (less-than-or-equal refl) = z≤n -≤″⇒≤ {suc m} (less-than-or-equal refl) = - s≤s (≤″⇒≤ (less-than-or-equal refl)) +⌈n/2⌉≤′n : ∀ n → ⌈ n /2⌉ ≤′ n +⌈n/2⌉≤′n zero = ≤′-refl +⌈n/2⌉≤′n (suc zero) = ≤′-refl +⌈n/2⌉≤′n (suc (suc n)) = s≤′s (≤′-step (⌈n/2⌉≤′n n)) -≤⇒≤″ : _≤_ ⇒ _≤″_ -≤⇒≤″ = less-than-or-equal ∘ m+[n∸m]≡n +⌊n/2⌋≤′n : ∀ n → ⌊ n /2⌋ ≤′ n +⌊n/2⌋≤′n zero = ≤′-refl +⌊n/2⌋≤′n (suc n) = ≤′-step (⌈n/2⌉≤′n n) --- NB: we use the builtin function `_<ᵇ_ : (m n : ℕ) → Bool` here so --- that the function quickly decides whether to return `yes` or `no`. --- It still takes a linear amount of time to generate the proof if it --- is inspected. We expect the main benefit to be visible for compiled --- code: the backend erases proofs. +------------------------------------------------------------------------ +-- Properties of _≤″_ and _<″_ +------------------------------------------------------------------------ -infix 4 _<″?_ _≤″?_ _≥″?_ _>″?_ +m<ᵇn⇒1+m+[n-1+m]≡n : ∀ m n → T (m <ᵇ n) → suc m + (n ∸ suc m) ≡ n +m<ᵇn⇒1+m+[n-1+m]≡n m n lt = m+[n∸m]≡n (<ᵇ⇒< m n lt) -_<″?_ : Decidable _<″_ -m <″? n = map′ <ᵇ⇒<″ <″⇒<ᵇ (T? (m <ᵇ n)) +m<ᵇ1+m+n : ∀ m {n} → T (m <ᵇ suc (m + n)) +m<ᵇ1+m+n m = <⇒<ᵇ (m≤m+n (suc m) _) -_≤″?_ : Decidable _≤″_ -zero ≤″? n = yes (less-than-or-equal refl) -suc m ≤″? n = m <″? n +<ᵇ⇒<″ : T (m <ᵇ n) → m <″ n +<ᵇ⇒<″ {m} {n} leq = less-than-or-equal (m+[n∸m]≡n (<ᵇ⇒< m n leq)) -_≥″?_ : Decidable _≥″_ -_≥″?_ = flip _≤″?_ +<″⇒<ᵇ : ∀ {m n} → m <″ n → T (m <ᵇ n) +<″⇒<ᵇ {m} (<″-offset k) = <⇒<ᵇ (m≤m+n (suc m) k) -_>″?_ : Decidable _>″_ -_>″?_ = flip _<″?_ +-- equivalence to the old definition of _≤″_ -≤″-irrelevant : Irrelevant _≤″_ -≤″-irrelevant {m} (less-than-or-equal eq₁) - (less-than-or-equal eq₂) - with +-cancelˡ-≡ m _ _ (trans eq₁ (sym eq₂)) -... | refl = cong less-than-or-equal (≡-irrelevant eq₁ eq₂) +≤″-proof : ∀ {m n} (le : m ≤″ n) → let less-than-or-equal {k} _ = le in m + k ≡ n +≤″-proof (less-than-or-equal prf) = prf -<″-irrelevant : Irrelevant _<″_ -<″-irrelevant = ≤″-irrelevant +-- equivalence to _≤_ ->″-irrelevant : Irrelevant _>″_ ->″-irrelevant = ≤″-irrelevant +≤″⇒≤ : _≤″_ ⇒ _≤_ +≤″⇒≤ {zero} (≤″-offset k) = z≤n {k} +≤″⇒≤ {suc m} (≤″-offset k) = s≤s (≤″⇒≤ (≤″-offset k)) -≥″-irrelevant : Irrelevant _≥″_ -≥″-irrelevant = ≤″-irrelevant +≤⇒≤″ : _≤_ ⇒ _≤″_ +≤⇒≤″ = less-than-or-equal ∘ m+[n∸m]≡n ------------------------------------------------------------------------- --- Properties of _≤‴_ ------------------------------------------------------------------------- +-- NB: we use the builtin function `_<ᵇ_ : (m n : ℕ) → Bool` here so +-- that the function quickly decides whether to return `yes` or `no`. +-- It still takes a linear amount of time to generate the proof if it +-- is inspected. We expect the main benefit to be visible for compiled +-- code: the backend erases proofs. -≤‴⇒≤″ : ∀{m n} → m ≤‴ n → m ≤″ n -≤‴⇒≤″ {m = m} ≤‴-refl = less-than-or-equal {k = 0} (+-identityʳ m) -≤‴⇒≤″ {m = m} (≤‴-step x) = less-than-or-equal (trans (+-suc m _) (_≤″_.proof ind)) where - ind = ≤‴⇒≤″ x +infix 4 _<″?_ _≤″?_ _≥″?_ _>″?_ -m≤‴m+k : ∀{m n k} → m + k ≡ n → m ≤‴ n -m≤‴m+k {m} {k = zero} refl = subst (λ z → m ≤‴ z) (sym (+-identityʳ m)) (≤‴-refl {m}) -m≤‴m+k {m} {k = suc k} proof - = ≤‴-step (m≤‴m+k {k = k} (trans (sym (+-suc m _)) proof)) +_<″?_ : Decidable _<″_ +m <″? n = map′ <ᵇ⇒<″ <″⇒<ᵇ (T? (m <ᵇ n)) -≤″⇒≤‴ : ∀{m n} → m ≤″ n → m ≤‴ n -≤″⇒≤‴ (less-than-or-equal {k} proof) = m≤‴m+k proof +_≤″?_ : Decidable _≤″_ +zero ≤″? n = yes (≤″-offset n) +suc m ≤″? n = m <″? n -0≤‴n : ∀{n} → 0 ≤‴ n -0≤‴n {n} = m≤‴m+k refl +_≥″?_ : Decidable _≥″_ +_≥″?_ = flip _≤″?_ -<ᵇ⇒<‴ : ∀ {m n} → T (m <ᵇ n) → m <‴ n -<ᵇ⇒<‴ {m} {n} leq = ≤″⇒≤‴ (<ᵇ⇒<″ leq) +_>″?_ : Decidable _>″_ +_>″?_ = flip _<″?_ -<‴⇒<ᵇ : ∀ {m n} → m <‴ n → T (m <ᵇ n) -<‴⇒<ᵇ leq = <″⇒<ᵇ (≤‴⇒≤″ leq) +≤″-irrelevant : Irrelevant _≤″_ +≤″-irrelevant {m} (less-than-or-equal eq₁) + (less-than-or-equal eq₂) + with refl ← +-cancelˡ-≡ m _ _ (trans eq₁ (sym eq₂)) + = cong less-than-or-equal (≡-irrelevant eq₁ eq₂) -infix 4 _<‴?_ _≤‴?_ _≥‴?_ _>‴?_ +<″-irrelevant : Irrelevant _<″_ +<″-irrelevant = ≤″-irrelevant -_<‴?_ : Decidable _<‴_ -m <‴? n = map′ <ᵇ⇒<‴ <‴⇒<ᵇ (T? (m <ᵇ n)) +>″-irrelevant : Irrelevant _>″_ +>″-irrelevant = ≤″-irrelevant -_≤‴?_ : Decidable _≤‴_ -zero ≤‴? n = yes 0≤‴n -suc m ≤‴? n = m <‴? n +≥″-irrelevant : Irrelevant _≥″_ +≥″-irrelevant = ≤″-irrelevant -_≥‴?_ : Decidable _≥‴_ -_≥‴?_ = flip _≤‴?_ +------------------------------------------------------------------------ +-- Properties of _≤‴_ +------------------------------------------------------------------------ -_>‴?_ : Decidable _>‴_ -_>‴?_ = flip _<‴?_ +≤‴⇒≤″ : ∀{m n} → m ≤‴ n → m ≤″ n +≤‴⇒≤″ {m = m} ≤‴-refl = less-than-or-equal {k = 0} (+-identityʳ m) +≤‴⇒≤″ {m = m} (≤‴-step m≤n) = less-than-or-equal (trans (+-suc m _) (≤″-proof (≤‴⇒≤″ m≤n))) -≤⇒≤‴ : _≤_ ⇒ _≤‴_ -≤⇒≤‴ = ≤″⇒≤‴ ∘ ≤⇒≤″ +m≤‴m+k : ∀{m n k} → m + k ≡ n → m ≤‴ n +m≤‴m+k {m} {k = zero} refl = subst (λ z → m ≤‴ z) (sym (+-identityʳ m)) (≤‴-refl {m}) +m≤‴m+k {m} {k = suc k} prf = ≤‴-step (m≤‴m+k {k = k} (trans (sym (+-suc m _)) prf)) -≤‴⇒≤ : _≤‴_ ⇒ _≤_ -≤‴⇒≤ = ≤″⇒≤ ∘ ≤‴⇒≤″ +≤″⇒≤‴ : ∀{m n} → m ≤″ n → m ≤‴ n +≤″⇒≤‴ m≤n = m≤‴m+k (≤″-proof m≤n) ------------------------------------------------------------------------- --- Other properties ------------------------------------------------------------------------- +0≤‴n : 0 ≤‴ n +0≤‴n = m≤‴m+k refl --- If there is an injection from a type to ℕ, then the type has --- decidable equality. +<ᵇ⇒<‴ : T (m <ᵇ n) → m <‴ n +<ᵇ⇒<‴ leq = ≤″⇒≤‴ (<ᵇ⇒<″ leq) -eq? : ∀ {a} {A : Set a} → A ↣ ℕ → DecidableEquality A -eq? inj = via-injection inj _≟_ +<‴⇒<ᵇ : ∀ {m n} → m <‴ n → T (m <ᵇ n) +<‴⇒<ᵇ leq = <″⇒<ᵇ (≤‴⇒≤″ leq) --- It's possible to decide existential and universal predicates up to --- a limit. +infix 4 _<‴?_ _≤‴?_ _≥‴?_ _>‴?_ -module _ {p} {P : Pred ℕ p} (P? : U.Decidable P) where +_<‴?_ : Decidable _<‴_ +m <‴? n = map′ <ᵇ⇒<‴ <‴⇒<ᵇ (T? (m <ᵇ n)) - anyUpTo? : ∀ v → Dec (∃ λ n → n < v × P n) - anyUpTo? zero = no λ {(_ , () , _)} - anyUpTo? (suc v) with P? v | anyUpTo? v - ... | yes Pv | _ = yes (v , ≤-refl , Pv) - ... | _ | yes (n , n<v , Pn) = yes (n , m≤n⇒m≤1+n n<v , Pn) - ... | no ¬Pv | no ¬Pn<v = no ¬Pn<1+v - where - ¬Pn<1+v : ∄ λ n → n < suc v × P n - ¬Pn<1+v (n , s≤s n≤v , Pn) with n ≟ v - ... | yes refl = ¬Pv Pn - ... | no n≢v = ¬Pn<v (n , ≤∧≢⇒< n≤v n≢v , Pn) +_≤‴?_ : Decidable _≤‴_ +zero ≤‴? n = yes 0≤‴n +suc m ≤‴? n = m <‴? n - allUpTo? : ∀ v → Dec (∀ {n} → n < v → P n) - allUpTo? zero = yes λ() - allUpTo? (suc v) with P? v | allUpTo? v - ... | no ¬Pv | _ = no (λ prf → ¬Pv (prf ≤-refl)) - ... | _ | no ¬Pn<v = no (λ prf → ¬Pn<v (prf ∘ m≤n⇒m≤1+n)) - ... | yes Pn | yes Pn<v = yes Pn<1+v - where - Pn<1+v : ∀ {n} → n < suc v → P n - Pn<1+v {n} (s≤s n≤v) with n ≟ v - ... | yes refl = Pn - ... | no n≢v = Pn<v (≤∧≢⇒< n≤v n≢v) +_≥‴?_ : Decidable _≥‴_ +_≥‴?_ = flip _≤‴?_ +_>‴?_ : Decidable _>‴_ +_>‴?_ = flip _<‴?_ +≤⇒≤‴ : _≤_ ⇒ _≤‴_ +≤⇒≤‴ = ≤″⇒≤‴ ∘ ≤⇒≤″ ------------------------------------------------------------------------- --- DEPRECATED NAMES ------------------------------------------------------------------------- --- Please use the new names as continuing support for the old names is --- not guaranteed. +≤‴⇒≤ : _≤‴_ ⇒ _≤_ +≤‴⇒≤ = ≤″⇒≤ ∘ ≤‴⇒≤″ --- Version 1.3 +------------------------------------------------------------------------ +-- Other properties +------------------------------------------------------------------------ -∀[m≤n⇒m≢o]⇒o<n : ∀ n o → (∀ {m} → m ≤ n → m ≢ o) → n < o -∀[m≤n⇒m≢o]⇒o<n = ∀[m≤n⇒m≢o]⇒n<o -{-# WARNING_ON_USAGE ∀[m≤n⇒m≢o]⇒o<n -"Warning: ∀[m≤n⇒m≢o]⇒o<n was deprecated in v1.3. +-- If there is an injection from a type to ℕ, then the type has +-- decidable equality. + +eq? : ∀ {a} {A : Set a} → A ↣ ℕ → DecidableEquality A +eq? inj = via-injection inj _≟_ + +-- It's possible to decide existential and universal predicates up to +-- a limit. + +module _ {p} {P : Pred ℕ p} (P? : U.Decidable P) where + + anyUpTo? : ∀ v → Dec (∃ λ n → n < v × P n) + anyUpTo? zero = no λ {(_ , () , _)} + anyUpTo? (suc v) with P? v | anyUpTo? v + ... | yes Pv | _ = yes (v , ≤-refl , Pv) + ... | _ | yes (n , n<v , Pn) = yes (n , m≤n⇒m≤1+n n<v , Pn) + ... | no ¬Pv | no ¬Pn<v = no ¬Pn<1+v + where + ¬Pn<1+v : ¬ (∃ λ n → n < suc v × P n) + ¬Pn<1+v (n , s≤s n≤v , Pn) with n ≟ v + ... | yes refl = ¬Pv Pn + ... | no n≢v = ¬Pn<v (n , ≤∧≢⇒< n≤v n≢v , Pn) + + allUpTo? : ∀ v → Dec (∀ {n} → n < v → P n) + allUpTo? zero = yes λ() + allUpTo? (suc v) with P? v | allUpTo? v + ... | no ¬Pv | _ = no λ prf → ¬Pv (prf ≤-refl) + ... | _ | no ¬Pn<v = no λ prf → ¬Pn<v (prf ∘ m≤n⇒m≤1+n) + ... | yes Pn | yes Pn<v = yes Pn<1+v + where + Pn<1+v : ∀ {n} → n < suc v → P n + Pn<1+v {n} (s≤s n≤v) with n ≟ v + ... | yes refl = Pn + ... | no n≢v = Pn<v (≤∧≢⇒< n≤v n≢v) + + + +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 1.3 + +∀[m≤n⇒m≢o]⇒o<n : ∀ n o → (∀ {m} → m ≤ n → m ≢ o) → n < o +∀[m≤n⇒m≢o]⇒o<n = ∀[m≤n⇒m≢o]⇒n<o +{-# WARNING_ON_USAGE ∀[m≤n⇒m≢o]⇒o<n +"Warning: ∀[m≤n⇒m≢o]⇒o<n was deprecated in v1.3. Please use ∀[m≤n⇒m≢o]⇒n<o instead." -#-} -∀[m<n⇒m≢o]⇒o≤n : ∀ n o → (∀ {m} → m < n → m ≢ o) → n ≤ o -∀[m<n⇒m≢o]⇒o≤n = ∀[m<n⇒m≢o]⇒n≤o -{-# WARNING_ON_USAGE ∀[m<n⇒m≢o]⇒o≤n -"Warning: ∀[m<n⇒m≢o]⇒o≤n was deprecated in v1.3. +#-} +∀[m<n⇒m≢o]⇒o≤n : ∀ n o → (∀ {m} → m < n → m ≢ o) → n ≤ o +∀[m<n⇒m≢o]⇒o≤n = ∀[m<n⇒m≢o]⇒n≤o +{-# WARNING_ON_USAGE ∀[m<n⇒m≢o]⇒o≤n +"Warning: ∀[m<n⇒m≢o]⇒o≤n was deprecated in v1.3. Please use ∀[m<n⇒m≢o]⇒n≤o instead." -#-} +#-} --- Version 1.4 +-- Version 1.4 -*-+-isSemiring = +-*-isSemiring -{-# WARNING_ON_USAGE *-+-isSemiring -"Warning: *-+-isSemiring was deprecated in v1.4. +*-+-isSemiring = +-*-isSemiring +{-# WARNING_ON_USAGE *-+-isSemiring +"Warning: *-+-isSemiring was deprecated in v1.4. Please use +-*-isSemiring instead." -#-} -*-+-isCommutativeSemiring = +-*-isCommutativeSemiring -{-# WARNING_ON_USAGE *-+-isCommutativeSemiring -"Warning: *-+-isCommutativeSemiring was deprecated in v1.4. +#-} +*-+-isCommutativeSemiring = +-*-isCommutativeSemiring +{-# WARNING_ON_USAGE *-+-isCommutativeSemiring +"Warning: *-+-isCommutativeSemiring was deprecated in v1.4. Please use +-*-isCommutativeSemiring instead." -#-} -*-+-semiring = +-*-semiring -{-# WARNING_ON_USAGE *-+-semiring -"Warning: *-+-semiring was deprecated in v1.4. +#-} +*-+-semiring = +-*-semiring +{-# WARNING_ON_USAGE *-+-semiring +"Warning: *-+-semiring was deprecated in v1.4. Please use +-*-semiring instead." -#-} -*-+-commutativeSemiring = +-*-commutativeSemiring -{-# WARNING_ON_USAGE *-+-commutativeSemiring -"Warning: *-+-commutativeSemiring was deprecated in v1.4. +#-} +*-+-commutativeSemiring = +-*-commutativeSemiring +{-# WARNING_ON_USAGE *-+-commutativeSemiring +"Warning: *-+-commutativeSemiring was deprecated in v1.4. Please use +-*-commutativeSemiring instead." -#-} +#-} --- Version 1.6 +-- Version 1.6 -∣m+n-m+o∣≡∣n-o| = ∣m+n-m+o∣≡∣n-o∣ -{-# WARNING_ON_USAGE ∣m+n-m+o∣≡∣n-o| -"Warning: ∣m+n-m+o∣≡∣n-o| was deprecated in v1.6. +∣m+n-m+o∣≡∣n-o| = ∣m+n-m+o∣≡∣n-o∣ +{-# WARNING_ON_USAGE ∣m+n-m+o∣≡∣n-o| +"Warning: ∣m+n-m+o∣≡∣n-o| was deprecated in v1.6. Please use ∣m+n-m+o∣≡∣n-o∣ instead. Note the final is a \\| rather than a |" -#-} -m≤n⇒n⊔m≡n = m≥n⇒m⊔n≡m -{-# WARNING_ON_USAGE m≤n⇒n⊔m≡n -"Warning: m≤n⇒n⊔m≡n was deprecated in v1.6. Please use m≥n⇒m⊔n≡m instead." -#-} -m≤n⇒n⊓m≡m = m≥n⇒m⊓n≡n -{-# WARNING_ON_USAGE m≤n⇒n⊓m≡m -"Warning: m≤n⇒n⊓m≡m was deprecated in v1.6. Please use m≥n⇒m⊓n≡n instead." -#-} -n⊔m≡m⇒n≤m = m⊔n≡n⇒m≤n -{-# WARNING_ON_USAGE n⊔m≡m⇒n≤m -"Warning: n⊔m≡m⇒n≤m was deprecated in v1.6. Please use m⊔n≡n⇒m≤n instead." -#-} -n⊔m≡n⇒m≤n = m⊔n≡m⇒n≤m -{-# WARNING_ON_USAGE n⊔m≡n⇒m≤n -"Warning: n⊔m≡n⇒m≤n was deprecated in v1.6. Please use m⊔n≡m⇒n≤m instead." -#-} -n≤m⊔n = m≤n⊔m -{-# WARNING_ON_USAGE n≤m⊔n -"Warning: n≤m⊔n was deprecated in v1.6. Please use m≤n⊔m instead." -#-} -⊔-least = ⊔-lub -{-# WARNING_ON_USAGE ⊔-least -"Warning: ⊔-least was deprecated in v1.6. Please use ⊔-lub instead." -#-} -⊓-greatest = ⊓-glb -{-# WARNING_ON_USAGE ⊓-greatest -"Warning: ⊓-greatest was deprecated in v1.6. Please use ⊓-glb instead." -#-} -⊔-pres-≤m = ⊔-lub -{-# WARNING_ON_USAGE ⊔-pres-≤m -"Warning: ⊔-pres-≤m was deprecated in v1.6. Please use ⊔-lub instead." -#-} -⊓-pres-m≤ = ⊓-glb -{-# WARNING_ON_USAGE ⊓-pres-m≤ -"Warning: ⊓-pres-m≤ was deprecated in v1.6. Please use ⊓-glb instead." -#-} -⊔-abs-⊓ = ⊔-absorbs-⊓ -{-# WARNING_ON_USAGE ⊔-abs-⊓ -"Warning: ⊔-abs-⊓ was deprecated in v1.6. Please use ⊔-absorbs-⊓ instead." -#-} -⊓-abs-⊔ = ⊓-absorbs-⊔ -{-# WARNING_ON_USAGE ⊓-abs-⊔ -"Warning: ⊓-abs-⊔ was deprecated in v1.6. Please use ⊓-absorbs-⊔ instead." -#-} - --- Version 2.0 - -suc[pred[n]]≡n : ∀ {n} → n ≢ 0 → suc (pred n) ≡ n -suc[pred[n]]≡n {zero} 0≢0 = contradiction refl 0≢0 -suc[pred[n]]≡n {suc n} _ = refl -{-# WARNING_ON_USAGE suc[pred[n]]≡n -"Warning: suc[pred[n]]≡n was deprecated in v2.0. Please use suc-pred instead. Note that the proof now uses instance arguments" -#-} - -≤-step = m≤n⇒m≤1+n -{-# WARNING_ON_USAGE ≤-step -"Warning: ≤-step was deprecated in v2.0. Please use m≤n⇒m≤1+n instead. " -#-} - -≤-stepsˡ = m≤n⇒m≤o+n -{-# WARNING_ON_USAGE ≤-stepsˡ -"Warning: ≤-stepsˡ was deprecated in v2.0. Please use m≤n⇒m≤o+n instead. " -#-} - -≤-stepsʳ = m≤n⇒m≤n+o -{-# WARNING_ON_USAGE ≤-stepsʳ -"Warning: ≤-stepsʳ was deprecated in v2.0. Please use m≤n⇒m≤n+o instead. " -#-} - -<-step = m<n⇒m<1+n -{-# WARNING_ON_USAGE <-step -"Warning: <-step was deprecated in v2.0. Please use m<n⇒m<1+n instead. " -#-} - -{- issue1844/issue1755: raw bundles have moved to `Data.X.Base` -} -open Data.Nat.Base public - using (*-rawMagma; *-1-rawMonoid) +#-} +m≤n⇒n⊔m≡n = m≥n⇒m⊔n≡m +{-# WARNING_ON_USAGE m≤n⇒n⊔m≡n +"Warning: m≤n⇒n⊔m≡n was deprecated in v1.6. Please use m≥n⇒m⊔n≡m instead." +#-} +m≤n⇒n⊓m≡m = m≥n⇒m⊓n≡n +{-# WARNING_ON_USAGE m≤n⇒n⊓m≡m +"Warning: m≤n⇒n⊓m≡m was deprecated in v1.6. Please use m≥n⇒m⊓n≡n instead." +#-} +n⊔m≡m⇒n≤m = m⊔n≡n⇒m≤n +{-# WARNING_ON_USAGE n⊔m≡m⇒n≤m +"Warning: n⊔m≡m⇒n≤m was deprecated in v1.6. Please use m⊔n≡n⇒m≤n instead." +#-} +n⊔m≡n⇒m≤n = m⊔n≡m⇒n≤m +{-# WARNING_ON_USAGE n⊔m≡n⇒m≤n +"Warning: n⊔m≡n⇒m≤n was deprecated in v1.6. Please use m⊔n≡m⇒n≤m instead." +#-} +n≤m⊔n = m≤n⊔m +{-# WARNING_ON_USAGE n≤m⊔n +"Warning: n≤m⊔n was deprecated in v1.6. Please use m≤n⊔m instead." +#-} +⊔-least = ⊔-lub +{-# WARNING_ON_USAGE ⊔-least +"Warning: ⊔-least was deprecated in v1.6. Please use ⊔-lub instead." +#-} +⊓-greatest = ⊓-glb +{-# WARNING_ON_USAGE ⊓-greatest +"Warning: ⊓-greatest was deprecated in v1.6. Please use ⊓-glb instead." +#-} +⊔-pres-≤m = ⊔-lub +{-# WARNING_ON_USAGE ⊔-pres-≤m +"Warning: ⊔-pres-≤m was deprecated in v1.6. Please use ⊔-lub instead." +#-} +⊓-pres-m≤ = ⊓-glb +{-# WARNING_ON_USAGE ⊓-pres-m≤ +"Warning: ⊓-pres-m≤ was deprecated in v1.6. Please use ⊓-glb instead." +#-} +⊔-abs-⊓ = ⊔-absorbs-⊓ +{-# WARNING_ON_USAGE ⊔-abs-⊓ +"Warning: ⊔-abs-⊓ was deprecated in v1.6. Please use ⊔-absorbs-⊓ instead." +#-} +⊓-abs-⊔ = ⊓-absorbs-⊔ +{-# WARNING_ON_USAGE ⊓-abs-⊔ +"Warning: ⊓-abs-⊔ was deprecated in v1.6. Please use ⊓-absorbs-⊔ instead." +#-} + +-- Version 2.0 + +suc[pred[n]]≡n : n ≢ 0 → suc (pred n) ≡ n +suc[pred[n]]≡n {zero} 0≢0 = contradiction refl 0≢0 +suc[pred[n]]≡n {suc n} _ = refl +{-# WARNING_ON_USAGE suc[pred[n]]≡n +"Warning: suc[pred[n]]≡n was deprecated in v2.0. Please use suc-pred instead. Note that the proof now uses instance arguments" +#-} + +≤-step = m≤n⇒m≤1+n +{-# WARNING_ON_USAGE ≤-step +"Warning: ≤-step was deprecated in v2.0. Please use m≤n⇒m≤1+n instead. " +#-} + +≤-stepsˡ = m≤n⇒m≤o+n +{-# WARNING_ON_USAGE ≤-stepsˡ +"Warning: ≤-stepsˡ was deprecated in v2.0. Please use m≤n⇒m≤o+n instead. " +#-} + +≤-stepsʳ = m≤n⇒m≤n+o +{-# WARNING_ON_USAGE ≤-stepsʳ +"Warning: ≤-stepsʳ was deprecated in v2.0. Please use m≤n⇒m≤n+o instead. " +#-} + +<-step = m<n⇒m<1+n +{-# WARNING_ON_USAGE <-step +"Warning: <-step was deprecated in v2.0. Please use m<n⇒m<1+n instead. " +#-} + +pred-mono = pred-mono-≤ +{-# WARNING_ON_USAGE pred-mono +"Warning: pred-mono was deprecated in v2.0. Please use pred-mono-≤ instead. " +#-} + +{- issue1844/issue1755: raw bundles have moved to `Data.X.Base` -} +open Data.Nat.Base public + using (*-rawMagma; *-1-rawMonoid) + +<-transʳ = ≤-<-trans +{-# WARNING_ON_USAGE <-transʳ +"Warning: <-transʳ was deprecated in v2.0. Please use ≤-<-trans instead. " +#-} + +<-transˡ = <-≤-trans +{-# WARNING_ON_USAGE <-transˡ +"Warning: <-transˡ was deprecated in v2.0. Please use <-≤-trans instead. " +#-} + \ No newline at end of file diff --git a/Data.Nat.Show.html b/Data.Nat.Show.html index 093165a9..0ea52a6d 100644 --- a/Data.Nat.Show.html +++ b/Data.Nat.Show.html @@ -11,77 +11,77 @@ open import Data.Bool.Base using (_∧_) open import Data.Char.Base as Char using (Char) -open import Data.Digit using (showDigit; toDigits; toNatDigits) -open import Data.List.Base as List using (List; []; _∷_) -open import Data.List.Effectful using (module TraversableA) -open import Data.Maybe.Base as Maybe using (Maybe; nothing; _<∣>_; when) +open import Data.Digit using (showDigit; toDigits; toNatDigits) +open import Data.List.Base as List using (List; []; _∷_) +open import Data.List.Effectful using (module TraversableA) +open import Data.Maybe.Base as Maybe using (Maybe; nothing; _<∣>_; when) import Data.Maybe.Effectful as Maybe open import Data.Nat -open import Data.Product using (proj₁) -open import Data.String as String using (String) -open import Function.Base -open import Relation.Nullary.Decidable using (True) +open import Data.Product.Base using (proj₁) +open import Data.String.Base using (toList; fromList; String) +open import Function.Base using (_∘′_; _∘_) +open import Relation.Nullary.Decidable using (True) ------------------------------------------------------------------------- --- Read +------------------------------------------------------------------------ +-- Read -readMaybe : ∀ base {base≤16 : True (base ≤? 16)} → String → Maybe ℕ -readMaybe _ "" = nothing -readMaybe base = Maybe.map convert - ∘′ TraversableA.mapA Maybe.applicative readDigit - ∘′ String.toList +readMaybe : ∀ base {base≤16 : True (base ≤? 16)} → String → Maybe ℕ +readMaybe _ "" = nothing +readMaybe base = Maybe.map convert + ∘′ TraversableA.mapA Maybe.applicative readDigit + ∘′ toList - where + where - convert : List ℕ → ℕ - convert = List.foldl (λ acc d → base * acc + d) 0 + convert : List ℕ → ℕ + convert = List.foldl (λ acc d → base * acc + d) 0 - char0 = Char.toℕ '0' - char9 = Char.toℕ '9' - chara = Char.toℕ 'a' - charf = Char.toℕ 'f' + char0 = Char.toℕ '0' + char9 = Char.toℕ '9' + chara = Char.toℕ 'a' + charf = Char.toℕ 'f' - readDigit : Char → Maybe ℕ - readDigit c = digit Maybe.>>= λ n → when (n <ᵇ base) n where + readDigit : Char → Maybe ℕ + readDigit c = digit Maybe.>>= λ n → when (n <ᵇ base) n where - charc = Char.toℕ c + charc = Char.toℕ c - dec = when ((char0 ≤ᵇ charc) ∧ (charc ≤ᵇ char9)) (charc ∸ char0) - hex = when ((chara ≤ᵇ charc) ∧ (charc ≤ᵇ charf)) (10 + charc ∸ chara) - digit = dec <∣> hex + dec = when ((char0 ≤ᵇ charc) ∧ (charc ≤ᵇ char9)) (charc ∸ char0) + hex = when ((chara ≤ᵇ charc) ∧ (charc ≤ᵇ charf)) (10 + charc ∸ chara) + digit = dec <∣> hex ------------------------------------------------------------------------- --- Show +------------------------------------------------------------------------ +-- Show --- Decimal notation --- Time complexity is O(log₁₀(n)) +-- Decimal notation +-- Time complexity is O(log₁₀(n)) -toDigitChar : ℕ → Char -toDigitChar n = Char.fromℕ (n + Char.toℕ '0') +toDigitChar : ℕ → Char +toDigitChar n = Char.fromℕ (n + Char.toℕ '0') -toDecimalChars : ℕ → List Char -toDecimalChars = List.map toDigitChar ∘′ toNatDigits 10 +toDecimalChars : ℕ → List Char +toDecimalChars = List.map toDigitChar ∘′ toNatDigits 10 -show : ℕ → String -show = String.fromList ∘ toDecimalChars +show : ℕ → String +show = fromList ∘′ toDecimalChars --- Arbitrary base betwen 2 & 16. --- Warning: when compiled the time complexity of `showInBase b n` is --- O(n) instead of the expected O(log(n)). +-- Arbitrary base betwen 2 & 16. +-- Warning: when compiled the time complexity of `showInBase b n` is +-- O(n) instead of the expected O(log(n)). -charsInBase : (base : ℕ) - {base≥2 : True (2 ≤? base)} - {base≤16 : True (base ≤? 16)} → - ℕ → List Char -charsInBase base {base≥2} {base≤16} = List.map (showDigit {base≤16 = base≤16}) - ∘ List.reverse - ∘ proj₁ - ∘ toDigits base {base≥2 = base≥2} +charsInBase : (base : ℕ) + {base≥2 : True (2 ≤? base)} + {base≤16 : True (base ≤? 16)} → + ℕ → List Char +charsInBase base {base≥2} {base≤16} = List.map (showDigit {base≤16 = base≤16}) + ∘ List.reverse + ∘ proj₁ + ∘ toDigits base {base≥2 = base≥2} -showInBase : (base : ℕ) - {base≥2 : True (2 ≤? base)} - {base≤16 : True (base ≤? 16)} → - ℕ → String -showInBase base {base≥2} {base≤16} = String.fromList - ∘ charsInBase base {base≥2} {base≤16} +showInBase : (base : ℕ) + {base≥2 : True (2 ≤? base)} + {base≤16 : True (base ≤? 16)} → + ℕ → String +showInBase base {base≥2} {base≤16} = fromList + ∘ charsInBase base {base≥2} {base≤16} \ No newline at end of file diff --git a/Data.Nat.Solver.html b/Data.Nat.Solver.html index 83aa2361..4b7276b4 100644 --- a/Data.Nat.Solver.html +++ b/Data.Nat.Solver.html @@ -20,5 +20,5 @@ -- containing _+_ and _*_ module +-*-Solver = - Solver (ACR.fromCommutativeSemiring +-*-commutativeSemiring) _≟_ + Solver (ACR.fromCommutativeSemiring +-*-commutativeSemiring) _≟_ \ No newline at end of file diff --git a/Data.Nat.Square.html b/Data.Nat.Square.html index 052d9be9..f36560db 100644 --- a/Data.Nat.Square.html +++ b/Data.Nat.Square.html @@ -13,9 +13,9 @@ _² : ℕ → ℕ n ² = n * n -n^2≡n² : ∀ n → n ^ 2 ≡ n ² -n^2≡n² n = Eq.cong (n *_) (*-identityʳ n) +n^2≡n² : ∀ n → n ^ 2 ≡ n ² +n^2≡n² n = Eq.cong (n *_) (*-identityʳ n) -²-mono : _² Preserves _≤_ ⟶ _≤_ -²-mono m≤n = *-mono-≤ m≤n m≤n +²-mono : _² Preserves _≤_ ⟶ _≤_ +²-mono m≤n = *-mono-≤ m≤n m≤n \ No newline at end of file diff --git a/Data.Nat.html b/Data.Nat.html index 14a1837f..d050a0ce 100644 --- a/Data.Nat.html +++ b/Data.Nat.html @@ -23,19 +23,19 @@ open import Data.Nat.Properties public using -- key values - ( nonZero? + ( nonZero? -- equalities - ; _≟_ ; eq? + ; _≟_ ; eq? -- standard orders & their relationship - ; _≤?_ ; _≥?_ ; _<?_ ; _>?_ - ; ≤-<-connex ; ≥->-connex ; <-≤-connex ; >-≥-connex - ; <-cmp + ; _≤?_ ; _≥?_ ; _<?_ ; _>?_ + ; ≤-<-connex ; ≥->-connex ; <-≤-connex ; >-≥-connex + ; <-cmp -- alternative definitions of the orders - ; _≤′?_; _≥′?_; _<′?_; _>′?_ - ; _≤″?_; _<″?_; _≥″?_; _>″?_ - ; _<‴?_; _≤‴?_; _≥‴?_; _>‴?_ + ; _≤′?_; _≥′?_; _<′?_; _>′?_ + ; _≤″?_; _<″?_; _≥″?_; _>″?_ + ; _<‴?_; _≤‴?_; _≥‴?_; _>‴?_ -- bounded predicates - ; anyUpTo? ; allUpTo? + ; anyUpTo? ; allUpTo? ) ------------------------------------------------------------------------ @@ -43,6 +43,9 @@ -- Version 0.17 -open import Data.Nat.Properties public - using (≤-pred) +-- Version 2.0 + +-- solely for the re-export of this name, formerly in `Data.Nat.Properties.Core` +open import Data.Nat.Properties public + using (≤-pred) \ No newline at end of file diff --git a/Data.Parity.Base.html b/Data.Parity.Base.html index dfc38606..9d00e4dc 100644 --- a/Data.Parity.Base.html +++ b/Data.Parity.Base.html @@ -27,91 +27,93 @@ -- The opposite parity. -_⁻¹ : Parity → Parity -1ℙ ⁻¹ = 0ℙ -0ℙ ⁻¹ = 1ℙ - --- Addition. - -infixl 7 _+_ - -_+_ : Parity → Parity → Parity -0ℙ + p = p -1ℙ + p = p ⁻¹ - --- Multiplication. - -infixl 7 _*_ - -_*_ : Parity → Parity → Parity -0ℙ * p = 0ℙ -1ℙ * p = p - ------------------------------------------------------------------------- --- Raw Bundles - -+-rawMagma : RawMagma 0ℓ 0ℓ -+-rawMagma = record - { _≈_ = _≡_ - ; _∙_ = _+_ - } - -+-0-rawMonoid : RawMonoid 0ℓ 0ℓ -+-0-rawMonoid = record - { _≈_ = _≡_ - ; _∙_ = _+_ - ; ε = 0ℙ - } - -+-0-rawGroup : RawGroup 0ℓ 0ℓ -+-0-rawGroup = record - { _≈_ = _≡_ - ; _∙_ = _+_ - ; _⁻¹ = _⁻¹ - ; ε = 0ℙ - } - -*-rawMagma : RawMagma 0ℓ 0ℓ -*-rawMagma = record - { _≈_ = _≡_ - ; _∙_ = _*_ - } - -*-1-rawMonoid : RawMonoid 0ℓ 0ℓ -*-1-rawMonoid = record - { _≈_ = _≡_ - ; _∙_ = _*_ - ; ε = 1ℙ - } - -+-*-rawNearSemiring : RawNearSemiring 0ℓ 0ℓ -+-*-rawNearSemiring = record - { Carrier = _ - ; _≈_ = _≡_ - ; _+_ = _+_ - ; _*_ = _*_ - ; 0# = 0ℙ - } - -+-*-rawSemiring : RawSemiring 0ℓ 0ℓ -+-*-rawSemiring = record - { Carrier = _ - ; _≈_ = _≡_ - ; _+_ = _+_ - ; _*_ = _*_ - ; 0# = 0ℙ - ; 1# = 1ℙ - } - - ------------------------------------------------------------------------- --- Homomorphisms between Parity and Sign - -toSign : Parity → Sign -toSign 0ℙ = + -toSign 1ℙ = - - -fromSign : Sign → Parity -fromSign + = 0ℙ -fromSign - = 1ℙ +infix 8 _⁻¹ + +_⁻¹ : Parity → Parity +1ℙ ⁻¹ = 0ℙ +0ℙ ⁻¹ = 1ℙ + +-- Addition. + +infixl 7 _+_ + +_+_ : Parity → Parity → Parity +0ℙ + p = p +1ℙ + p = p ⁻¹ + +-- Multiplication. + +infixl 7 _*_ + +_*_ : Parity → Parity → Parity +0ℙ * p = 0ℙ +1ℙ * p = p + +------------------------------------------------------------------------ +-- Raw Bundles + ++-rawMagma : RawMagma 0ℓ 0ℓ ++-rawMagma = record + { _≈_ = _≡_ + ; _∙_ = _+_ + } + ++-0-rawMonoid : RawMonoid 0ℓ 0ℓ ++-0-rawMonoid = record + { _≈_ = _≡_ + ; _∙_ = _+_ + ; ε = 0ℙ + } + ++-0-rawGroup : RawGroup 0ℓ 0ℓ ++-0-rawGroup = record + { _≈_ = _≡_ + ; _∙_ = _+_ + ; _⁻¹ = _⁻¹ + ; ε = 0ℙ + } + +*-rawMagma : RawMagma 0ℓ 0ℓ +*-rawMagma = record + { _≈_ = _≡_ + ; _∙_ = _*_ + } + +*-1-rawMonoid : RawMonoid 0ℓ 0ℓ +*-1-rawMonoid = record + { _≈_ = _≡_ + ; _∙_ = _*_ + ; ε = 1ℙ + } + ++-*-rawNearSemiring : RawNearSemiring 0ℓ 0ℓ ++-*-rawNearSemiring = record + { Carrier = _ + ; _≈_ = _≡_ + ; _+_ = _+_ + ; _*_ = _*_ + ; 0# = 0ℙ + } + ++-*-rawSemiring : RawSemiring 0ℓ 0ℓ ++-*-rawSemiring = record + { Carrier = _ + ; _≈_ = _≡_ + ; _+_ = _+_ + ; _*_ = _*_ + ; 0# = 0ℙ + ; 1# = 1ℙ + } + + +------------------------------------------------------------------------ +-- Homomorphisms between Parity and Sign + +toSign : Parity → Sign +toSign 0ℙ = + +toSign 1ℙ = - + +fromSign : Sign → Parity +fromSign + = 0ℙ +fromSign - = 1ℙ \ No newline at end of file diff --git a/Data.Product.Algebra.html b/Data.Product.Algebra.html index 75992f41..a456e324 100644 --- a/Data.Product.Algebra.html +++ b/Data.Product.Algebra.html @@ -12,176 +12,170 @@ open import Algebra open import Data.Bool.Base using (true; false) open import Data.Empty.Polymorphic using (⊥; ⊥-elim) -open import Data.Product -open import Data.Product.Properties -open import Data.Sum as Sum using (_⊎_; inj₁; inj₂; [_,_]′) -open import Data.Sum.Algebra -open import Data.Unit.Polymorphic using (⊤; tt) -open import Function.Base using (_∘′_) -open import Function.Bundles using (_↔_; Inverse; mk↔′) -open import Function.Properties.Inverse using (↔-isEquivalence) -open import Level using (Level; suc) -open import Relation.Binary.PropositionalEquality.Core - -import Function.Definitions as FuncDef - ------------------------------------------------------------------------- - -private - variable - a b c d p : Level - A : Set a - B : Set b - C : Set c - D : Set d - - module _ {A : Set a} {B : Set b} where - open FuncDef {A = A} {B} _≡_ _≡_ - ------------------------------------------------------------------------- --- Properties of Σ - --- Σ is associative -Σ-assoc : {B : A → Set b} {C : (a : A) → B a → Set c} → - Σ (Σ A B) (uncurry C) ↔ Σ A (λ a → Σ (B a) (C a)) -Σ-assoc = mk↔′ assocʳ assocˡ cong′ cong′ - --- Σ is associative, alternate formulation -Σ-assoc-alt : {B : A → Set b} {C : Σ A B → Set c} → - Σ (Σ A B) C ↔ Σ A (λ a → Σ (B a) (curry C a)) -Σ-assoc-alt = mk↔′ assocʳ-curried assocˡ-curried cong′ cong′ - ------------------------------------------------------------------------- --- Algebraic properties - --- × is a congruence -×-cong : A ↔ B → C ↔ D → (A × C) ↔ (B × D) -×-cong i j = mk↔′ (map I.to J.to) (map I.from J.from) - (λ {(a , b) → cong₂ _,_ (I.inverseˡ a) (J.inverseˡ b)}) - (λ {(a , b) → cong₂ _,_ (I.inverseʳ a) (J.inverseʳ b)}) - where module I = Inverse i; module J = Inverse j - --- × is commutative. --- (we don't use Commutative because it isn't polymorphic enough) -×-comm : (A : Set a) (B : Set b) → (A × B) ↔ (B × A) -×-comm _ _ = mk↔′ swap swap swap-involutive swap-involutive - -module _ (ℓ : Level) where - - -- × is associative - ×-assoc : Associative {ℓ = ℓ} _↔_ _×_ - ×-assoc _ _ _ = mk↔′ assocʳ′ assocˡ′ cong′ cong′ - - -- ⊤ is the identity for × - ×-identityˡ : LeftIdentity {ℓ = ℓ} _↔_ ⊤ _×_ - ×-identityˡ _ = mk↔′ proj₂ (tt ,_) cong′ cong′ - - ×-identityʳ : RightIdentity {ℓ = ℓ} _↔_ ⊤ _×_ - ×-identityʳ _ = mk↔′ proj₁ (_, tt) cong′ cong′ - - ×-identity : Identity _↔_ ⊤ _×_ - ×-identity = ×-identityˡ , ×-identityʳ - - -- ⊥ is the zero for × - ×-zeroˡ : LeftZero {ℓ = ℓ} _↔_ ⊥ _×_ - ×-zeroˡ A = mk↔′ proj₁ ⊥-elim ⊥-elim λ () - - ×-zeroʳ : RightZero {ℓ = ℓ} _↔_ ⊥ _×_ - ×-zeroʳ A = mk↔′ proj₂ ⊥-elim ⊥-elim λ () - - ×-zero : Zero _↔_ ⊥ _×_ - ×-zero = ×-zeroˡ , ×-zeroʳ - - -- × distributes over ⊎ - ×-distribˡ-⊎ : _DistributesOverˡ_ {ℓ = ℓ} _↔_ _×_ _⊎_ - ×-distribˡ-⊎ _ _ _ = mk↔′ - (uncurry λ x → [ inj₁ ∘′ (x ,_) , inj₂ ∘′ (x ,_) ]′) - [ map₂ inj₁ , map₂ inj₂ ]′ - Sum.[ cong′ , cong′ ] - (uncurry λ _ → Sum.[ cong′ , cong′ ]) - - ×-distribʳ-⊎ : _DistributesOverʳ_ {ℓ = ℓ} _↔_ _×_ _⊎_ - ×-distribʳ-⊎ _ _ _ = mk↔′ - (uncurry [ curry inj₁ , curry inj₂ ]′) - [ map₁ inj₁ , map₁ inj₂ ]′ - Sum.[ cong′ , cong′ ] - (uncurry Sum.[ (λ _ → cong′) , (λ _ → cong′) ]) - - ×-distrib-⊎ : _DistributesOver_ {ℓ = ℓ} _↔_ _×_ _⊎_ - ×-distrib-⊎ = ×-distribˡ-⊎ , ×-distribʳ-⊎ - ------------------------------------------------------------------------- --- Algebraic structures - - ×-isMagma : IsMagma {ℓ = ℓ} _↔_ _×_ - ×-isMagma = record - { isEquivalence = ↔-isEquivalence - ; ∙-cong = ×-cong - } - - ×-isSemigroup : IsSemigroup _↔_ _×_ - ×-isSemigroup = record - { isMagma = ×-isMagma - ; assoc = λ _ _ _ → Σ-assoc - } - - ×-isMonoid : IsMonoid _↔_ _×_ ⊤ - ×-isMonoid = record - { isSemigroup = ×-isSemigroup - ; identity = ×-identityˡ , ×-identityʳ - } - - ×-isCommutativeMonoid : IsCommutativeMonoid _↔_ _×_ ⊤ - ×-isCommutativeMonoid = record - { isMonoid = ×-isMonoid - ; comm = ×-comm - } - - ⊎-×-isSemiringWithoutAnnihilatingZero : IsSemiringWithoutAnnihilatingZero _↔_ _⊎_ _×_ ⊥ ⊤ - ⊎-×-isSemiringWithoutAnnihilatingZero = record - { +-isCommutativeMonoid = ⊎-isCommutativeMonoid ℓ - ; *-cong = ×-cong - ; *-assoc = ×-assoc - ; *-identity = ×-identity - ; distrib = ×-distrib-⊎ - } - - ⊎-×-isSemiring : IsSemiring _↔_ _⊎_ _×_ ⊥ ⊤ - ⊎-×-isSemiring = record - { isSemiringWithoutAnnihilatingZero = ⊎-×-isSemiringWithoutAnnihilatingZero - ; zero = ×-zero - } - - ⊎-×-isCommutativeSemiring : IsCommutativeSemiring _↔_ _⊎_ _×_ ⊥ ⊤ - ⊎-×-isCommutativeSemiring = record - { isSemiring = ⊎-×-isSemiring - ; *-comm = ×-comm - } ------------------------------------------------------------------------- --- Algebraic bundles - - ×-magma : Magma (suc ℓ) ℓ - ×-magma = record - { isMagma = ×-isMagma - } - - ×-semigroup : Semigroup (suc ℓ) ℓ - ×-semigroup = record - { isSemigroup = ×-isSemigroup - } - - ×-monoid : Monoid (suc ℓ) ℓ - ×-monoid = record - { isMonoid = ×-isMonoid - } - - ×-commutativeMonoid : CommutativeMonoid (suc ℓ) ℓ - ×-commutativeMonoid = record - { isCommutativeMonoid = ×-isCommutativeMonoid - } - - ×-⊎-commutativeSemiring : CommutativeSemiring (suc ℓ) ℓ - ×-⊎-commutativeSemiring = record - { isCommutativeSemiring = ⊎-×-isCommutativeSemiring - } +open import Data.Product.Base +open import Data.Product.Properties +open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂; [_,_]′) +open import Data.Sum.Algebra +open import Data.Unit.Polymorphic using (⊤; tt) +open import Function.Base using (_∘′_) +open import Function.Bundles using (_↔_; Inverse; mk↔ₛ′) +open import Function.Properties.Inverse using (↔-isEquivalence) +open import Level using (Level; suc) +open import Relation.Binary.PropositionalEquality.Core + +import Function.Definitions as FuncDef + +------------------------------------------------------------------------ + +private + variable + a b c d p : Level + A B C D : Set a + +------------------------------------------------------------------------ +-- Properties of Σ + +-- Σ is associative +Σ-assoc : {B : A → Set b} {C : (a : A) → B a → Set c} → + Σ (Σ A B) (uncurry C) ↔ Σ A (λ a → Σ (B a) (C a)) +Σ-assoc = mk↔ₛ′ assocʳ assocˡ cong′ cong′ + +-- Σ is associative, alternate formulation +Σ-assoc-alt : {B : A → Set b} {C : Σ A B → Set c} → + Σ (Σ A B) C ↔ Σ A (λ a → Σ (B a) (curry C a)) +Σ-assoc-alt = mk↔ₛ′ assocʳ-curried assocˡ-curried cong′ cong′ + +------------------------------------------------------------------------ +-- Algebraic properties + +-- × is a congruence +×-cong : A ↔ B → C ↔ D → (A × C) ↔ (B × D) +×-cong i j = mk↔ₛ′ (map I.to J.to) (map I.from J.from) + (λ {(a , b) → cong₂ _,_ (I.strictlyInverseˡ a) (J.strictlyInverseˡ b)}) + (λ {(a , b) → cong₂ _,_ (I.strictlyInverseʳ a) (J.strictlyInverseʳ b)}) + where module I = Inverse i; module J = Inverse j + +-- × is commutative. +-- (we don't use Commutative because it isn't polymorphic enough) +×-comm : (A : Set a) (B : Set b) → (A × B) ↔ (B × A) +×-comm _ _ = mk↔ₛ′ swap swap swap-involutive swap-involutive + +module _ (ℓ : Level) where + + -- × is associative + ×-assoc : Associative {ℓ = ℓ} _↔_ _×_ + ×-assoc _ _ _ = mk↔ₛ′ assocʳ′ assocˡ′ cong′ cong′ + + -- ⊤ is the identity for × + ×-identityˡ : LeftIdentity {ℓ = ℓ} _↔_ ⊤ _×_ + ×-identityˡ _ = mk↔ₛ′ proj₂ (tt ,_) cong′ cong′ + + ×-identityʳ : RightIdentity {ℓ = ℓ} _↔_ ⊤ _×_ + ×-identityʳ _ = mk↔ₛ′ proj₁ (_, tt) cong′ cong′ + + ×-identity : Identity _↔_ ⊤ _×_ + ×-identity = ×-identityˡ , ×-identityʳ + + -- ⊥ is the zero for × + ×-zeroˡ : LeftZero {ℓ = ℓ} _↔_ ⊥ _×_ + ×-zeroˡ A = mk↔ₛ′ proj₁ ⊥-elim ⊥-elim λ () + + ×-zeroʳ : RightZero {ℓ = ℓ} _↔_ ⊥ _×_ + ×-zeroʳ A = mk↔ₛ′ proj₂ ⊥-elim ⊥-elim λ () + + ×-zero : Zero _↔_ ⊥ _×_ + ×-zero = ×-zeroˡ , ×-zeroʳ + + -- × distributes over ⊎ + ×-distribˡ-⊎ : _DistributesOverˡ_ {ℓ = ℓ} _↔_ _×_ _⊎_ + ×-distribˡ-⊎ _ _ _ = mk↔ₛ′ + (uncurry λ x → [ inj₁ ∘′ (x ,_) , inj₂ ∘′ (x ,_) ]′) + [ map₂ inj₁ , map₂ inj₂ ]′ + Sum.[ cong′ , cong′ ] + (uncurry λ _ → Sum.[ cong′ , cong′ ]) + + ×-distribʳ-⊎ : _DistributesOverʳ_ {ℓ = ℓ} _↔_ _×_ _⊎_ + ×-distribʳ-⊎ _ _ _ = mk↔ₛ′ + (uncurry [ curry inj₁ , curry inj₂ ]′) + [ map₁ inj₁ , map₁ inj₂ ]′ + Sum.[ cong′ , cong′ ] + (uncurry Sum.[ (λ _ → cong′) , (λ _ → cong′) ]) + + ×-distrib-⊎ : _DistributesOver_ {ℓ = ℓ} _↔_ _×_ _⊎_ + ×-distrib-⊎ = ×-distribˡ-⊎ , ×-distribʳ-⊎ + +------------------------------------------------------------------------ +-- Algebraic structures + + ×-isMagma : IsMagma {ℓ = ℓ} _↔_ _×_ + ×-isMagma = record + { isEquivalence = ↔-isEquivalence + ; ∙-cong = ×-cong + } + + ×-isSemigroup : IsSemigroup _↔_ _×_ + ×-isSemigroup = record + { isMagma = ×-isMagma + ; assoc = λ _ _ _ → Σ-assoc + } + + ×-isMonoid : IsMonoid _↔_ _×_ ⊤ + ×-isMonoid = record + { isSemigroup = ×-isSemigroup + ; identity = ×-identityˡ , ×-identityʳ + } + + ×-isCommutativeMonoid : IsCommutativeMonoid _↔_ _×_ ⊤ + ×-isCommutativeMonoid = record + { isMonoid = ×-isMonoid + ; comm = ×-comm + } + + ⊎-×-isSemiringWithoutAnnihilatingZero : IsSemiringWithoutAnnihilatingZero _↔_ _⊎_ _×_ ⊥ ⊤ + ⊎-×-isSemiringWithoutAnnihilatingZero = record + { +-isCommutativeMonoid = ⊎-isCommutativeMonoid ℓ + ; *-cong = ×-cong + ; *-assoc = ×-assoc + ; *-identity = ×-identity + ; distrib = ×-distrib-⊎ + } + + ⊎-×-isSemiring : IsSemiring _↔_ _⊎_ _×_ ⊥ ⊤ + ⊎-×-isSemiring = record + { isSemiringWithoutAnnihilatingZero = ⊎-×-isSemiringWithoutAnnihilatingZero + ; zero = ×-zero + } + + ⊎-×-isCommutativeSemiring : IsCommutativeSemiring _↔_ _⊎_ _×_ ⊥ ⊤ + ⊎-×-isCommutativeSemiring = record + { isSemiring = ⊎-×-isSemiring + ; *-comm = ×-comm + } +------------------------------------------------------------------------ +-- Algebraic bundles + + ×-magma : Magma (suc ℓ) ℓ + ×-magma = record + { isMagma = ×-isMagma + } + + ×-semigroup : Semigroup (suc ℓ) ℓ + ×-semigroup = record + { isSemigroup = ×-isSemigroup + } + + ×-monoid : Monoid (suc ℓ) ℓ + ×-monoid = record + { isMonoid = ×-isMonoid + } + + ×-commutativeMonoid : CommutativeMonoid (suc ℓ) ℓ + ×-commutativeMonoid = record + { isCommutativeMonoid = ×-isCommutativeMonoid + } + + ×-⊎-commutativeSemiring : CommutativeSemiring (suc ℓ) ℓ + ×-⊎-commutativeSemiring = record + { isCommutativeSemiring = ⊎-×-isCommutativeSemiring + } \ No newline at end of file diff --git a/Data.Product.Base.html b/Data.Product.Base.html index 9f556800..4dc72028 100644 --- a/Data.Product.Base.html +++ b/Data.Product.Base.html @@ -10,166 +10,186 @@ module Data.Product.Base where open import Function.Base -open import Level +open import Level using (Level; _⊔_) -private - variable - a b c d e f ℓ p q r : Level - A : Set a - B : Set b - C : Set c - D : Set d - E : Set e - F : Set f +private + variable + a b c d e f ℓ p q r : Level + A : Set a + B : Set b + C : Set c + D : Set d + E : Set e + F : Set f ------------------------------------------------------------------------- --- Definition of dependent products +------------------------------------------------------------------------ +-- Definition of dependent products -open import Agda.Builtin.Sigma public - renaming (fst to proj₁; snd to proj₂) - hiding (module Σ) +open import Agda.Builtin.Sigma public + renaming (fst to proj₁; snd to proj₂) + hiding (module Σ) -module Σ = Agda.Builtin.Sigma.Σ - renaming (fst to proj₁; snd to proj₂) +module Σ = Agda.Builtin.Sigma.Σ + renaming (fst to proj₁; snd to proj₂) --- The syntax declaration below is attached to Σ-syntax, to make it --- easy to import Σ without the special syntax. +------------------------------------------------------------------------ +-- Existential quantifiers -infix 2 Σ-syntax +∃ : ∀ {A : Set a} → (A → Set b) → Set (a ⊔ b) +∃ = Σ _ -Σ-syntax : (A : Set a) → (A → Set b) → Set (a ⊔ b) -Σ-syntax = Σ +∃₂ : ∀ {A : Set a} {B : A → Set b} + (C : (x : A) → B x → Set c) → Set (a ⊔ b ⊔ c) +∃₂ C = ∃ λ a → ∃ λ b → C a b -syntax Σ-syntax A (λ x → B) = Σ[ x ∈ A ] B +------------------------------------------------------------------------ +-- Syntaxes ------------------------------------------------------------------------- --- Definition of non-dependent products +-- The syntax declaration below is attached to Σ-syntax, to make it +-- easy to import Σ without the special syntax. -infixr 4 _,′_ -infixr 2 _×_ +infix 2 Σ-syntax -_×_ : ∀ (A : Set a) (B : Set b) → Set (a ⊔ b) -A × B = Σ[ x ∈ A ] B +Σ-syntax : (A : Set a) → (A → Set b) → Set (a ⊔ b) +Σ-syntax = Σ -_,′_ : A → B → A × B -_,′_ = _,_ +syntax Σ-syntax A (λ x → B) = Σ[ x ∈ A ] B ------------------------------------------------------------------------- --- Operations over dependent products +infix 2 ∃-syntax -infix 4 -,_ -infixr 2 _-×-_ _-,-_ -infixl 2 _<*>_ +∃-syntax : ∀ {A : Set a} → (A → Set b) → Set (a ⊔ b) +∃-syntax = ∃ --- Sometimes the first component can be inferred. +syntax ∃-syntax (λ x → B) = ∃[ x ] B --,_ : ∀ {A : Set a} {B : A → Set b} {x} → B x → Σ _ B --, y = _ , y +------------------------------------------------------------------------ +-- Definition of non-dependent products -<_,_> : ∀ {A : Set a} {B : A → Set b} {C : ∀ {x} → B x → Set c} - (f : (x : A) → B x) → ((x : A) → C (f x)) → - ((x : A) → Σ (B x) C) -< f , g > x = (f x , g x) +infixr 4 _,′_ +infixr 2 _×_ -map : ∀ {P : A → Set p} {Q : B → Set q} → - (f : A → B) → (∀ {x} → P x → Q (f x)) → - Σ A P → Σ B Q -map f g (x , y) = (f x , g y) +_×_ : ∀ (A : Set a) (B : Set b) → Set (a ⊔ b) +A × B = Σ[ x ∈ A ] B -map₁ : (A → B) → A × C → B × C -map₁ f = map f id +_,′_ : A → B → A × B +_,′_ = _,_ -map₂ : ∀ {A : Set a} {B : A → Set b} {C : A → Set c} → - (∀ {x} → B x → C x) → Σ A B → Σ A C -map₂ f = map id f +------------------------------------------------------------------------ +-- Operations over dependent products --- A version of map where the output can depend on the input -dmap : ∀ {B : A → Set b} {P : A → Set p} {Q : ∀ {a} → P a → B a → Set q} → - (f : (a : A) → B a) → (∀ {a} (b : P a) → Q b (f a)) → - ((a , b) : Σ A P) → Σ (B a) (Q b) -dmap f g (x , y) = f x , g y +infix 4 -,_ +infixr 2 _-×-_ _-,-_ +infixl 2 _<*>_ -zip : ∀ {P : A → Set p} {Q : B → Set q} {R : C → Set r} → - (_∙_ : A → B → C) → - (∀ {x y} → P x → Q y → R (x ∙ y)) → - Σ A P → Σ B Q → Σ C R -zip _∙_ _∘_ (a , p) (b , q) = ((a ∙ b) , (p ∘ q)) +-- Sometimes the first component can be inferred. -curry : ∀ {A : Set a} {B : A → Set b} {C : Σ A B → Set c} → - ((p : Σ A B) → C p) → - ((x : A) → (y : B x) → C (x , y)) -curry f x y = f (x , y) +-,_ : ∀ {A : Set a} {B : A → Set b} {x} → B x → Σ _ B +-, y = _ , y -uncurry : ∀ {A : Set a} {B : A → Set b} {C : Σ A B → Set c} → - ((x : A) → (y : B x) → C (x , y)) → - ((p : Σ A B) → C p) -uncurry f (x , y) = f x y +<_,_> : ∀ {A : Set a} {B : A → Set b} {C : ∀ {x} → B x → Set c} + (f : (x : A) → B x) → ((x : A) → C (f x)) → + ((x : A) → Σ (B x) C) +< f , g > x = (f x , g x) --- Rewriting dependent products -assocʳ : {B : A → Set b} {C : (a : A) → B a → Set c} → - Σ (Σ A B) (uncurry C) → Σ A (λ a → Σ (B a) (C a)) -assocʳ ((a , b) , c) = (a , (b , c)) +map : ∀ {P : A → Set p} {Q : B → Set q} → + (f : A → B) → (∀ {x} → P x → Q (f x)) → + Σ A P → Σ B Q +map f g (x , y) = (f x , g y) -assocˡ : {B : A → Set b} {C : (a : A) → B a → Set c} → - Σ A (λ a → Σ (B a) (C a)) → Σ (Σ A B) (uncurry C) -assocˡ (a , (b , c)) = ((a , b) , c) +map₁ : (A → B) → A × C → B × C +map₁ f = map f id --- Alternate form of associativity for dependent products --- where the C parameter is uncurried. -assocʳ-curried : {B : A → Set b} {C : Σ A B → Set c} → - Σ (Σ A B) C → Σ A (λ a → Σ (B a) (curry C a)) -assocʳ-curried ((a , b) , c) = (a , (b , c)) +map₂ : ∀ {A : Set a} {B : A → Set b} {C : A → Set c} → + (∀ {x} → B x → C x) → Σ A B → Σ A C +map₂ f = map id f -assocˡ-curried : {B : A → Set b} {C : Σ A B → Set c} → - Σ A (λ a → Σ (B a) (curry C a)) → Σ (Σ A B) C -assocˡ-curried (a , (b , c)) = ((a , b) , c) +-- A version of map where the output can depend on the input +dmap : ∀ {B : A → Set b} {P : A → Set p} {Q : ∀ {a} → P a → B a → Set q} → + (f : (a : A) → B a) → (∀ {a} (b : P a) → Q b (f a)) → + ((a , b) : Σ A P) → Σ (B a) (Q b) +dmap f g (x , y) = f x , g y ------------------------------------------------------------------------- --- Operations for non-dependent products +zip : ∀ {P : A → Set p} {Q : B → Set q} {R : C → Set r} → + (_∙_ : A → B → C) → + (∀ {x y} → P x → Q y → R (x ∙ y)) → + Σ A P → Σ B Q → Σ C R +zip _∙_ _∘_ (a , p) (b , q) = ((a ∙ b) , (p ∘ q)) --- Any of the above operations for dependent products will also work for --- non-dependent products but sometimes Agda has difficulty inferring --- the non-dependency. Primed (′ = \prime) versions of the operations --- are therefore provided below that sometimes have better inference --- properties. +curry : ∀ {A : Set a} {B : A → Set b} {C : Σ A B → Set c} → + ((p : Σ A B) → C p) → + ((x : A) → (y : B x) → C (x , y)) +curry f x y = f (x , y) -zip′ : (A → B → C) → (D → E → F) → A × D → B × E → C × F -zip′ f g = zip f g +uncurry : ∀ {A : Set a} {B : A → Set b} {C : Σ A B → Set c} → + ((x : A) → (y : B x) → C (x , y)) → + ((p : Σ A B) → C p) +uncurry f (x , y) = f x y -curry′ : (A × B → C) → (A → B → C) -curry′ = curry +-- Rewriting dependent products +assocʳ : {B : A → Set b} {C : (a : A) → B a → Set c} → + Σ (Σ A B) (uncurry C) → Σ A (λ a → Σ (B a) (C a)) +assocʳ ((a , b) , c) = (a , (b , c)) -uncurry′ : (A → B → C) → (A × B → C) -uncurry′ = uncurry +assocˡ : {B : A → Set b} {C : (a : A) → B a → Set c} → + Σ A (λ a → Σ (B a) (C a)) → Σ (Σ A B) (uncurry C) +assocˡ (a , (b , c)) = ((a , b) , c) -map₂′ : (B → C) → A × B → A × C -map₂′ f = map₂ f +-- Alternate form of associativity for dependent products +-- where the C parameter is uncurried. +assocʳ-curried : {B : A → Set b} {C : Σ A B → Set c} → + Σ (Σ A B) C → Σ A (λ a → Σ (B a) (curry C a)) +assocʳ-curried ((a , b) , c) = (a , (b , c)) -dmap′ : ∀ {x y} {X : A → Set x} {Y : B → Set y} → - ((a : A) → X a) → ((b : B) → Y b) → - ((a , b) : A × B) → X a × Y b -dmap′ f g = dmap f g +assocˡ-curried : {B : A → Set b} {C : Σ A B → Set c} → + Σ A (λ a → Σ (B a) (curry C a)) → Σ (Σ A B) C +assocˡ-curried (a , (b , c)) = ((a , b) , c) -_<*>_ : ∀ {x y} {X : A → Set x} {Y : B → Set y} → - ((a : A) → X a) × ((b : B) → Y b) → - ((a , b) : A × B) → X a × Y b -_<*>_ = uncurry dmap′ +------------------------------------------------------------------------ +-- Operations for non-dependent products --- Operations that can only be defined for non-dependent products +-- Any of the above operations for dependent products will also work for +-- non-dependent products but sometimes Agda has difficulty inferring +-- the non-dependency. Primed (′ = \prime) versions of the operations +-- are therefore provided below that sometimes have better inference +-- properties. -swap : A × B → B × A -swap (x , y) = (y , x) +zip′ : (A → B → C) → (D → E → F) → A × D → B × E → C × F +zip′ f g = zip f g -_-×-_ : (A → B → Set p) → (A → B → Set q) → (A → B → Set _) -f -×- g = f -⟪ _×_ ⟫- g +curry′ : (A × B → C) → (A → B → C) +curry′ = curry -_-,-_ : (A → B → C) → (A → B → D) → (A → B → C × D) -f -,- g = f -⟪ _,_ ⟫- g +uncurry′ : (A → B → C) → (A × B → C) +uncurry′ = uncurry --- Rewriting non-dependent products -assocʳ′ : (A × B) × C → A × (B × C) -assocʳ′ ((a , b) , c) = (a , (b , c)) +map₂′ : (B → C) → A × B → A × C +map₂′ f = map₂ f -assocˡ′ : A × (B × C) → (A × B) × C -assocˡ′ (a , (b , c)) = ((a , b) , c) +dmap′ : ∀ {x y} {X : A → Set x} {Y : B → Set y} → + ((a : A) → X a) → ((b : B) → Y b) → + ((a , b) : A × B) → X a × Y b +dmap′ f g = dmap f g + +_<*>_ : ∀ {x y} {X : A → Set x} {Y : B → Set y} → + ((a : A) → X a) × ((b : B) → Y b) → + ((a , b) : A × B) → X a × Y b +_<*>_ = uncurry dmap′ + +-- Operations that can only be defined for non-dependent products + +swap : A × B → B × A +swap (x , y) = (y , x) + +_-×-_ : (A → B → Set p) → (A → B → Set q) → (A → B → Set _) +f -×- g = f -⟪ _×_ ⟫- g + +_-,-_ : (A → B → C) → (A → B → D) → (A → B → C × D) +f -,- g = f -⟪ _,_ ⟫- g + +-- Rewriting non-dependent products +assocʳ′ : (A × B) × C → A × (B × C) +assocʳ′ ((a , b) , c) = (a , (b , c)) + +assocˡ′ : A × (B × C) → (A × B) × C +assocˡ′ (a , (b , c)) = ((a , b) , c) \ No newline at end of file diff --git a/Data.Product.Function.Dependent.Propositional.html b/Data.Product.Function.Dependent.Propositional.html index d6344d0c..0f5c08d7 100644 --- a/Data.Product.Function.Dependent.Propositional.html +++ b/Data.Product.Function.Dependent.Propositional.html @@ -10,327 +10,308 @@ module Data.Product.Function.Dependent.Propositional where -open import Data.Product -open import Data.Product.Function.NonDependent.Setoid -open import Data.Product.Relation.Binary.Pointwise.NonDependent -open import Relation.Binary hiding (_⇔_) -open import Function.Base -open import Function.Equality using (_⟶_; _⟨$⟩_) -open import Function.Equivalence as Equiv using (_⇔_; module Equivalence) -open import Function.HalfAdjointEquivalence using (↔→≃; _≃_) -open import Function.Injection as Inj - using (Injective; _↣_; module Injection) -open import Function.Inverse as Inv using (_↔_; module Inverse) -open import Function.LeftInverse as LeftInv - using (_↞_; _LeftInverseOf_; module LeftInverse) -open import Function.Related -open import Function.Related.TypeIsomorphisms -open import Function.Surjection as Surj using (_↠_; module Surjection) -open import Relation.Binary.PropositionalEquality as P using (_≡_) - ------------------------------------------------------------------------- --- Combinators for various function types - -module _ {a₁ a₂} {A₁ : Set a₁} {A₂ : Set a₂} - {b₁ b₂} {B₁ : A₁ → Set b₁} {B₂ : A₂ → Set b₂} - where - - ⇔ : (A₁⇔A₂ : A₁ ⇔ A₂) → - (∀ {x} → B₁ x → B₂ (Equivalence.to A₁⇔A₂ ⟨$⟩ x)) → - (∀ {y} → B₂ y → B₁ (Equivalence.from A₁⇔A₂ ⟨$⟩ y)) → - Σ A₁ B₁ ⇔ Σ A₂ B₂ - ⇔ A₁⇔A₂ B-to B-from = Equiv.equivalence - (map (Equivalence.to A₁⇔A₂ ⟨$⟩_) B-to) - (map (Equivalence.from A₁⇔A₂ ⟨$⟩_) B-from) - - ⇔-↠ : ∀ (A₁↠A₂ : A₁ ↠ A₂) → - (∀ {x} → _⇔_ (B₁ x) (B₂ (Surjection.to A₁↠A₂ ⟨$⟩ x))) → - _⇔_ (Σ A₁ B₁) (Σ A₂ B₂) - ⇔-↠ A₁↠A₂ B₁⇔B₂ = Equiv.equivalence - (map (Surjection.to A₁↠A₂ ⟨$⟩_) (Equivalence.to B₁⇔B₂ ⟨$⟩_)) - (map (Surjection.from A₁↠A₂ ⟨$⟩_) - ((Equivalence.from B₁⇔B₂ ⟨$⟩_) ∘ - P.subst B₂ (P.sym $ Surjection.right-inverse-of A₁↠A₂ _))) - - -- See also Data.Product.Relation.Binary.Pointwise.Dependent.WithK.↣. - - ↣ : ∀ (A₁↔A₂ : A₁ ↔ A₂) → - (∀ {x} → B₁ x ↣ B₂ (Inverse.to A₁↔A₂ ⟨$⟩ x)) → - Σ A₁ B₁ ↣ Σ A₂ B₂ - ↣ A₁↔A₂ B₁↣B₂ = Inj.injection to to-injective - where - open P.≡-Reasoning - - A₁≃A₂ = ↔→≃ A₁↔A₂ - - subst-application′ : - let open _≃_ A₁≃A₂ in - {x₁ x₂ : A₁} {y : B₁ (from (to x₁))} - (g : ∀ x → B₁ (from (to x)) → B₂ (to x)) (eq : to x₁ ≡ to x₂) → - P.subst B₂ eq (g x₁ y) ≡ g x₂ (P.subst B₁ (P.cong from eq) y) - subst-application′ {x₁} {x₂} {y} g eq = - P.subst B₂ eq (g x₁ y) ≡⟨ P.cong (P.subst B₂ eq) (P.sym (g′-lemma _ _)) ⟩ - P.subst B₂ eq (g′ (to x₁) y) ≡⟨ P.subst-application B₁ g′ eq ⟩ - g′ (to x₂) (P.subst B₁ (P.cong from eq) y) ≡⟨ g′-lemma _ _ ⟩ - g x₂ (P.subst B₁ (P.cong from eq) y) ∎ - where - open _≃_ A₁≃A₂ - - g′ : ∀ x → B₁ (from x) → B₂ x - g′ x = - P.subst B₂ (right-inverse-of x) ∘ - g (from x) ∘ - P.subst B₁ (P.sym (P.cong from (right-inverse-of x))) - - g′-lemma : ∀ x y → g′ (to x) y ≡ g x y - g′-lemma x y = - P.subst B₂ (right-inverse-of (to x)) - (g (from (to x)) $ - P.subst B₁ (P.sym (P.cong from (right-inverse-of (to x)))) y) ≡⟨ P.cong (λ p → P.subst B₂ p (g (from (to x)) - (P.subst B₁ (P.sym (P.cong from p)) y))) - (P.sym (left-right x)) ⟩ - P.subst B₂ (P.cong to (left-inverse-of x)) - (g (from (to x)) $ - P.subst B₁ - (P.sym (P.cong from (P.cong to (left-inverse-of x)))) - y) ≡⟨ lemma _ ⟩ - - g x y ∎ - where - lemma : - ∀ {x′} eq {y : B₁ (from (to x′))} → - P.subst B₂ (P.cong to eq) - (g (from (to x)) - (P.subst B₁ (P.sym (P.cong from (P.cong to eq))) y)) ≡ - g x′ y - lemma P.refl = P.refl - - to = map (_≃_.to A₁≃A₂) (Injection.to B₁↣B₂ ⟨$⟩_) - - to-injective : Injective (P.→-to-⟶ {B = P.setoid _} to) - to-injective {(x₁ , x₂)} {(y₁ , y₂)} = - Σ-≡,≡→≡ ∘′ - - map (_≃_.injective A₁≃A₂) (λ {eq₁} eq₂ → - - let lemma = - - Injection.to B₁↣B₂ ⟨$⟩ - P.subst B₁ (_≃_.injective A₁≃A₂ eq₁) x₂ ≡⟨⟩ - - Injection.to B₁↣B₂ ⟨$⟩ - P.subst B₁ - (P.trans (P.sym (_≃_.left-inverse-of A₁≃A₂ x₁)) - (P.trans (P.cong (_≃_.from A₁≃A₂) eq₁) - (P.trans (_≃_.left-inverse-of A₁≃A₂ y₁) - P.refl))) - x₂ ≡⟨ P.cong (λ p → Injection.to B₁↣B₂ ⟨$⟩ - P.subst B₁ - (P.trans (P.sym (_≃_.left-inverse-of A₁≃A₂ _)) - (P.trans (P.cong (_≃_.from A₁≃A₂) eq₁) p)) - x₂) - (P.trans-reflʳ _) ⟩ - Injection.to B₁↣B₂ ⟨$⟩ - P.subst B₁ - (P.trans (P.sym (_≃_.left-inverse-of A₁≃A₂ x₁)) - (P.trans (P.cong (_≃_.from A₁≃A₂) eq₁) - (_≃_.left-inverse-of A₁≃A₂ y₁))) - x₂ ≡⟨ P.cong (Injection.to B₁↣B₂ ⟨$⟩_) - (P.sym (P.subst-subst (P.sym (_≃_.left-inverse-of A₁≃A₂ _)))) ⟩ - Injection.to B₁↣B₂ ⟨$⟩ - (P.subst B₁ (P.trans (P.cong (_≃_.from A₁≃A₂) eq₁) - (_≃_.left-inverse-of A₁≃A₂ y₁)) $ - P.subst B₁ (P.sym (_≃_.left-inverse-of A₁≃A₂ x₁)) x₂) ≡⟨ P.cong (Injection.to B₁↣B₂ ⟨$⟩_) - (P.sym (P.subst-subst (P.cong (_≃_.from A₁≃A₂) eq₁))) ⟩ - Injection.to B₁↣B₂ ⟨$⟩ - (P.subst B₁ (_≃_.left-inverse-of A₁≃A₂ y₁) $ - P.subst B₁ (P.cong (_≃_.from A₁≃A₂) eq₁) $ - P.subst B₁ (P.sym (_≃_.left-inverse-of A₁≃A₂ x₁)) x₂) ≡⟨ P.sym (subst-application′ - (λ x y → Injection.to B₁↣B₂ ⟨$⟩ - P.subst B₁ (_≃_.left-inverse-of A₁≃A₂ x) y) - eq₁) ⟩ - P.subst B₂ eq₁ - (Injection.to B₁↣B₂ ⟨$⟩ - (P.subst B₁ (_≃_.left-inverse-of A₁≃A₂ x₁) $ - P.subst B₁ (P.sym (_≃_.left-inverse-of A₁≃A₂ x₁)) x₂)) ≡⟨ P.cong (P.subst B₂ eq₁ ∘ (Injection.to B₁↣B₂ ⟨$⟩_)) - (P.subst-subst (P.sym (_≃_.left-inverse-of A₁≃A₂ _))) ⟩ - P.subst B₂ eq₁ - (Injection.to B₁↣B₂ ⟨$⟩ - P.subst B₁ - (P.trans (P.sym (_≃_.left-inverse-of A₁≃A₂ x₁)) - (_≃_.left-inverse-of A₁≃A₂ x₁)) - x₂) ≡⟨ P.cong (λ p → P.subst B₂ eq₁ - (Injection.to B₁↣B₂ ⟨$⟩ P.subst B₁ p x₂)) - (P.trans-symˡ (_≃_.left-inverse-of A₁≃A₂ _)) ⟩ - P.subst B₂ eq₁ - (Injection.to B₁↣B₂ ⟨$⟩ P.subst B₁ P.refl x₂) ≡⟨⟩ - - P.subst B₂ eq₁ (Injection.to B₁↣B₂ ⟨$⟩ x₂) ≡⟨ eq₂ ⟩ - - Injection.to B₁↣B₂ ⟨$⟩ y₂ ∎ - - in - - P.subst B₁ (_≃_.injective A₁≃A₂ eq₁) x₂ ≡⟨ Injection.injective B₁↣B₂ lemma ⟩ - y₂ ∎) ∘ - - Σ-≡,≡←≡ - - ↞ : (A₁↞A₂ : A₁ ↞ A₂) → - (∀ {x} → B₁ (LeftInverse.from A₁↞A₂ ⟨$⟩ x) ↞ B₂ x) → - Σ A₁ B₁ ↞ Σ A₂ B₂ - ↞ A₁↞A₂ B₁↞B₂ = record - { to = P.→-to-⟶ to - ; from = P.→-to-⟶ from - ; left-inverse-of = left-inverse-of - } - where - open P.≡-Reasoning - - from = map (LeftInverse.from A₁↞A₂ ⟨$⟩_) (LeftInverse.from B₁↞B₂ ⟨$⟩_) - - to = map - (LeftInverse.to A₁↞A₂ ⟨$⟩_) - (λ {x} y → - LeftInverse.to B₁↞B₂ ⟨$⟩ - P.subst B₁ (P.sym (LeftInverse.left-inverse-of A₁↞A₂ x)) y) - - left-inverse-of : ∀ p → from (to p) ≡ p - left-inverse-of (x , y) = Σ-≡,≡→≡ - ( LeftInverse.left-inverse-of A₁↞A₂ x - , (P.subst B₁ (LeftInverse.left-inverse-of A₁↞A₂ x) - (LeftInverse.from B₁↞B₂ ⟨$⟩ (LeftInverse.to B₁↞B₂ ⟨$⟩ - (P.subst B₁ (P.sym (LeftInverse.left-inverse-of A₁↞A₂ x)) - y))) ≡⟨ P.cong (P.subst B₁ _) (LeftInverse.left-inverse-of B₁↞B₂ _) ⟩ - - P.subst B₁ (LeftInverse.left-inverse-of A₁↞A₂ x) - (P.subst B₁ (P.sym (LeftInverse.left-inverse-of A₁↞A₂ x)) - y) ≡⟨ P.subst-subst-sym (LeftInverse.left-inverse-of A₁↞A₂ x) ⟩ - - y ∎) - ) - - ↠ : (A₁↠A₂ : A₁ ↠ A₂) → - (∀ {x} → B₁ x ↠ B₂ (Surjection.to A₁↠A₂ ⟨$⟩ x)) → - Σ A₁ B₁ ↠ Σ A₂ B₂ - ↠ A₁↠A₂ B₁↠B₂ = record - { to = P.→-to-⟶ to - ; surjective = record - { from = P.→-to-⟶ from - ; right-inverse-of = right-inverse-of - } - } - where - open P.≡-Reasoning - - to = map (Surjection.to A₁↠A₂ ⟨$⟩_) - (Surjection.to B₁↠B₂ ⟨$⟩_) - from = map - (Surjection.from A₁↠A₂ ⟨$⟩_) - (λ {x} y → - Surjection.from B₁↠B₂ ⟨$⟩ - P.subst B₂ (P.sym (Surjection.right-inverse-of A₁↠A₂ x)) y) - - right-inverse-of : ∀ p → to (from p) ≡ p - right-inverse-of (x , y) = Σ-≡,≡→≡ - ( Surjection.right-inverse-of A₁↠A₂ x - , (P.subst B₂ (Surjection.right-inverse-of A₁↠A₂ x) - (Surjection.to B₁↠B₂ ⟨$⟩ (Surjection.from B₁↠B₂ ⟨$⟩ - (P.subst B₂ (P.sym (Surjection.right-inverse-of A₁↠A₂ x)) - y))) ≡⟨ P.cong (P.subst B₂ _) (Surjection.right-inverse-of B₁↠B₂ _) ⟩ - - P.subst B₂ (Surjection.right-inverse-of A₁↠A₂ x) - (P.subst B₂ (P.sym (Surjection.right-inverse-of A₁↠A₂ x)) - y) ≡⟨ P.subst-subst-sym (Surjection.right-inverse-of A₁↠A₂ x) ⟩ - - y ∎) - ) - - ↔ : (A₁↔A₂ : A₁ ↔ A₂) → - (∀ {x} → B₁ x ↔ B₂ (Inverse.to A₁↔A₂ ⟨$⟩ x)) → - Σ A₁ B₁ ↔ Σ A₂ B₂ - ↔ A₁↔A₂ B₁↔B₂ = Inv.inverse - (Surjection.to surjection′ ⟨$⟩_) - (Surjection.from surjection′ ⟨$⟩_) - left-inverse-of - (Surjection.right-inverse-of surjection′) - where - open P.≡-Reasoning - - A₁≃A₂ = ↔→≃ A₁↔A₂ - - surjection′ : _↠_ (Σ A₁ B₁) (Σ A₂ B₂) - surjection′ = - ↠ (Inverse.surjection (_≃_.inverse A₁≃A₂)) - (Inverse.surjection B₁↔B₂) - - left-inverse-of : - ∀ p → Surjection.from surjection′ ⟨$⟩ - (Surjection.to surjection′ ⟨$⟩ p) ≡ p - left-inverse-of (x , y) = Σ-≡,≡→≡ - ( _≃_.left-inverse-of A₁≃A₂ x - , (P.subst B₁ (_≃_.left-inverse-of A₁≃A₂ x) - (Inverse.from B₁↔B₂ ⟨$⟩ - (P.subst B₂ (P.sym (_≃_.right-inverse-of A₁≃A₂ - (_≃_.to A₁≃A₂ x))) - (Inverse.to B₁↔B₂ ⟨$⟩ y))) ≡⟨ P.subst-application B₂ (λ _ → Inverse.from B₁↔B₂ ⟨$⟩_) _ ⟩ - - Inverse.from B₁↔B₂ ⟨$⟩ - (P.subst B₂ (P.cong (_≃_.to A₁≃A₂) - (_≃_.left-inverse-of A₁≃A₂ x)) - (P.subst B₂ (P.sym (_≃_.right-inverse-of A₁≃A₂ - (_≃_.to A₁≃A₂ x))) - (Inverse.to B₁↔B₂ ⟨$⟩ y))) ≡⟨ P.cong (λ eq → Inverse.from B₁↔B₂ ⟨$⟩ P.subst B₂ eq - (P.subst B₂ (P.sym (_≃_.right-inverse-of A₁≃A₂ _)) _)) - (_≃_.left-right A₁≃A₂ _) ⟩ - Inverse.from B₁↔B₂ ⟨$⟩ - (P.subst B₂ (_≃_.right-inverse-of A₁≃A₂ - (_≃_.to A₁≃A₂ x)) - (P.subst B₂ (P.sym (_≃_.right-inverse-of A₁≃A₂ - (_≃_.to A₁≃A₂ x))) - (Inverse.to B₁↔B₂ ⟨$⟩ y))) ≡⟨ P.cong (Inverse.from B₁↔B₂ ⟨$⟩_) - (P.subst-subst-sym (_≃_.right-inverse-of A₁≃A₂ _)) ⟩ - - Inverse.from B₁↔B₂ ⟨$⟩ (Inverse.to B₁↔B₂ ⟨$⟩ y) ≡⟨ Inverse.left-inverse-of B₁↔B₂ _ ⟩ - - y ∎) - ) - -private - - swap-coercions : ∀ {k a₁ a₂ b₁ b₂} {A₁ : Set a₁} {A₂ : Set a₂} - {B₁ : A₁ → Set b₁} (B₂ : A₂ → Set b₂) - (A₁↔A₂ : _↔_ A₁ A₂) → - (∀ {x} → B₁ x ∼[ k ] B₂ (Inverse.to A₁↔A₂ ⟨$⟩ x)) → - ∀ {x} → B₁ (Inverse.from A₁↔A₂ ⟨$⟩ x) ∼[ k ] B₂ x - swap-coercions {k} {B₁ = B₁} B₂ A₁↔A₂ eq {x} = - B₁ (Inverse.from A₁↔A₂ ⟨$⟩ x) - ∼⟨ eq ⟩ - B₂ (Inverse.to A₁↔A₂ ⟨$⟩ (Inverse.from A₁↔A₂ ⟨$⟩ x)) - ↔⟨ K-reflexive - (P.cong B₂ $ Inverse.right-inverse-of A₁↔A₂ x) ⟩ - B₂ x - ∎ - where open EquationalReasoning - -cong : ∀ {k a₁ a₂ b₁ b₂} - {A₁ : Set a₁} {A₂ : Set a₂} - {B₁ : A₁ → Set b₁} {B₂ : A₂ → Set b₂} - (A₁↔A₂ : _↔_ A₁ A₂) → - (∀ {x} → B₁ x ∼[ k ] B₂ (Inverse.to A₁↔A₂ ⟨$⟩ x)) → - Σ A₁ B₁ ∼[ k ] Σ A₂ B₂ -cong {implication} = - λ A₁↔A₂ → map (_⟨$⟩_ (Inverse.to A₁↔A₂)) -cong {reverse-implication} {B₂ = B₂} = - λ A₁↔A₂ B₁←B₂ → lam (map (_⟨$⟩_ (Inverse.from A₁↔A₂)) - (app-← (swap-coercions B₂ A₁↔A₂ B₁←B₂))) -cong {equivalence} = ⇔-↠ ∘ Inverse.surjection -cong {injection} = ↣ -cong {reverse-injection} {B₂ = B₂} = - λ A₁↔A₂ B₁↢B₂ → lam (↣ (Inv.sym A₁↔A₂) - (app-↢ (swap-coercions B₂ A₁↔A₂ B₁↢B₂))) -cong {left-inverse} = - λ A₁↔A₂ → ↞ (Inverse.left-inverse A₁↔A₂) ∘ swap-coercions _ A₁↔A₂ -cong {surjection} = ↠ ∘ Inverse.surjection -cong {bijection} = ↔ +open import Data.Product.Base as Prod +open import Data.Product.Function.NonDependent.Setoid using () +open import Data.Product.Relation.Binary.Pointwise.NonDependent using () +open import Data.Product.Properties using (Σ-≡,≡→≡; Σ-≡,≡↔≡; Σ-≡,≡←≡) +open import Level using (Level; 0ℓ) +open import Function.Related.TypeIsomorphisms +open import Function.Related.Propositional +open import Function.Base +open import Function.Properties.Inverse +open import Function.Properties.RightInverse +open import Function.Properties.Inverse.HalfAdjointEquivalence +open import Function.Consequences.Propositional + using (inverseʳ⇒injective; strictlySurjective⇒surjective) +open import Function.Definitions using (Inverseˡ; Inverseʳ; Injective; StrictlySurjective) +open import Function.Bundles +open import Relation.Binary.PropositionalEquality as P using (_≡_) + +private + variable + i a b c d : Level + I J : Set i + A B : I → Set a + +------------------------------------------------------------------------ +-- Functions + +module _ where + open Func + + Σ-⟶ : (I⟶J : I ⟶ J) → + (∀ {i} → A i ⟶ B (to I⟶J i)) → + Σ I A ⟶ Σ J B + Σ-⟶ I⟶J A⟶B = mk⟶ $ Prod.map (to I⟶J) (to A⟶B) + +------------------------------------------------------------------------ +-- Equivalences + +module _ where + open Surjection + + Σ-⇔ : (I↠J : I ↠ J) → + (∀ {i} → A i ⇔ B (to I↠J i)) → + Σ I A ⇔ Σ J B + Σ-⇔ {B = B} I↠J A⇔B = mk⇔ + (map (to I↠J) (Equivalence.to A⇔B)) + (map (to⁻ I↠J) (Equivalence.from A⇔B ∘ P.subst B (P.sym (proj₂ (surjective I↠J _) P.refl)))) + + -- See also Data.Product.Relation.Binary.Pointwise.Dependent.WithK.↣. + +------------------------------------------------------------------------ +-- Injections + +module _ where + + Σ-↣ : (I↔J : I ↔ J) → + (∀ {i} → A i ↣ B (Inverse.to I↔J i)) → + Σ I A ↣ Σ J B + Σ-↣ {I = I} {J = J} {A = A} {B = B} I↔J A↣B = mk↣ to-injective + where + open P.≡-Reasoning + + I≃J = ↔⇒≃ I↔J + + subst-application′ : + let open _≃_ I≃J in + {x₁ x₂ : I} {y : A (from (to x₁))} + (g : ∀ x → A (from (to x)) → B (to x)) + (eq : to x₁ ≡ to x₂) → + P.subst B eq (g x₁ y) ≡ g x₂ (P.subst A (P.cong from eq) y) + subst-application′ {x₁} {x₂} {y} g eq = + P.subst B eq (g x₁ y) ≡⟨ P.cong (P.subst B eq) (P.sym (g′-lemma _ _)) ⟩ + P.subst B eq (g′ (to x₁) y) ≡⟨ P.subst-application A g′ eq ⟩ + g′ (to x₂) (P.subst A (P.cong from eq) y) ≡⟨ g′-lemma _ _ ⟩ + g x₂ (P.subst A (P.cong from eq) y) ∎ + where + open _≃_ I≃J + + g′ : ∀ x → A (from x) → B x + g′ x = + P.subst B (right-inverse-of x) ∘ + g (from x) ∘ + P.subst A (P.sym (P.cong from (right-inverse-of x))) + + g′-lemma : ∀ x y → g′ (to x) y ≡ g x y + g′-lemma x y = + P.subst B (right-inverse-of (to x)) + (g (from (to x)) $ + P.subst A (P.sym (P.cong from (right-inverse-of (to x)))) y) ≡⟨ P.cong (λ p → P.subst B p (g (from (to x)) + (P.subst A (P.sym (P.cong from p)) y))) + (P.sym (left-right x)) ⟩ + P.subst B (P.cong to (left-inverse-of x)) + (g (from (to x)) $ + P.subst A + (P.sym (P.cong from (P.cong to (left-inverse-of x)))) + y) ≡⟨ lemma _ ⟩ + + g x y ∎ + where + lemma : ∀ {x′} eq {y : A (from (to x′))} → + P.subst B (P.cong to eq) + (g (from (to x)) + (P.subst A (P.sym (P.cong from (P.cong to eq))) y)) ≡ + g x′ y + lemma P.refl = P.refl + + open Injection + + to′ : Σ I A → Σ J B + to′ = Prod.map (_≃_.to I≃J) (to A↣B) + + to-injective : Injective _≡_ _≡_ to′ + to-injective {(x₁ , x₂)} {(y₁ , y₂)} = + + Σ-≡,≡→≡ ∘′ + + map (_≃_.injective I≃J) (λ {eq₁} eq₂ → injective A↣B ( + to A↣B (P.subst A (_≃_.injective I≃J eq₁) x₂) ≡⟨⟩ + + (let eq = + P.trans (P.sym (_≃_.left-inverse-of I≃J x₁)) + (P.trans (P.cong (_≃_.from I≃J) eq₁) + (P.trans (_≃_.left-inverse-of I≃J y₁) + P.refl)) in + to A↣B (P.subst A eq x₂)) ≡⟨ P.cong (λ p → to A↣B + (P.subst A + (P.trans (P.sym (_≃_.left-inverse-of I≃J _)) + (P.trans (P.cong (_≃_.from I≃J) eq₁) p)) + x₂)) + (P.trans-reflʳ _) ⟩ + + (let eq = P.trans (P.sym (_≃_.left-inverse-of I≃J x₁)) + (P.trans (P.cong (_≃_.from I≃J) eq₁) + (_≃_.left-inverse-of I≃J y₁)) in + to A↣B (P.subst A eq x₂)) ≡⟨ P.cong (to A↣B) + (P.sym (P.subst-subst (P.sym (_≃_.left-inverse-of I≃J _)))) ⟩ + + to A↣B ((P.subst A (P.trans (P.cong (_≃_.from I≃J) eq₁) + (_≃_.left-inverse-of I≃J y₁)) $ + P.subst A (P.sym (_≃_.left-inverse-of I≃J x₁)) x₂)) ≡⟨ P.cong (to A↣B) + (P.sym (P.subst-subst (P.cong (_≃_.from I≃J) eq₁))) ⟩ + to A↣B ( + (P.subst A (_≃_.left-inverse-of I≃J y₁) $ + P.subst A (P.cong (_≃_.from I≃J) eq₁) $ + P.subst A (P.sym (_≃_.left-inverse-of I≃J x₁)) x₂)) ≡⟨ P.sym (subst-application′ + (λ x y → to A↣B + (P.subst A (_≃_.left-inverse-of I≃J x) y)) + eq₁) ⟩ + P.subst B eq₁ (to A↣B $ + (P.subst A (_≃_.left-inverse-of I≃J x₁) $ + P.subst A (P.sym (_≃_.left-inverse-of I≃J x₁)) x₂)) ≡⟨ P.cong (P.subst B eq₁ ∘ to A↣B) + (P.subst-subst (P.sym (_≃_.left-inverse-of I≃J _))) ⟩ + + (let eq = P.trans (P.sym (_≃_.left-inverse-of I≃J x₁)) + (_≃_.left-inverse-of I≃J x₁) in + P.subst B eq₁ (to A↣B (P.subst A eq x₂))) ≡⟨ P.cong (λ p → P.subst B eq₁ (to A↣B (P.subst A p x₂))) + (P.trans-symˡ (_≃_.left-inverse-of I≃J _)) ⟩ + P.subst B eq₁ (to A↣B (P.subst A P.refl x₂)) ≡⟨⟩ + + P.subst B eq₁ (to A↣B x₂) ≡⟨ eq₂ ⟩ + + to A↣B y₂ ∎ + + )) ∘ + + Σ-≡,≡←≡ + +------------------------------------------------------------------------ +-- Surjections + +module _ where + open Surjection + + Σ-↠ : (I↠J : I ↠ J) → + (∀ {x} → A x ↠ B (to I↠J x)) → + Σ I A ↠ Σ J B + Σ-↠ {I = I} {J = J} {A = A} {B = B} I↠J A↠B = + mk↠ₛ strictlySurjective′ + where + to′ : Σ I A → Σ J B + to′ = map (to I↠J) (to A↠B) + + backcast : ∀ {i} → B i → B (to I↠J (to⁻ I↠J i)) + backcast = P.subst B (P.sym (to∘to⁻ I↠J _)) + + to⁻′ : Σ J B → Σ I A + to⁻′ = map (to⁻ I↠J) (Surjection.to⁻ A↠B ∘ backcast) + + strictlySurjective′ : StrictlySurjective _≡_ to′ + strictlySurjective′ (x , y) = to⁻′ (x , y) , Σ-≡,≡→≡ + ( to∘to⁻ I↠J x + , (P.subst B (to∘to⁻ I↠J x) (to A↠B (to⁻ A↠B (backcast y))) ≡⟨ P.cong (P.subst B _) (to∘to⁻ A↠B _) ⟩ + P.subst B (to∘to⁻ I↠J x) (backcast y) ≡⟨ P.subst-subst-sym (to∘to⁻ I↠J x) ⟩ + y ∎) + ) where open P.≡-Reasoning + + +------------------------------------------------------------------------ +-- Left inverses + +module _ where + open LeftInverse + + Σ-↩ : (I↩J : I ↩ J) → + (∀ {i} → A i ↩ B (to I↩J i)) → + Σ I A ↩ Σ J B + Σ-↩ {I = I} {J = J} {A = A} {B = B} I↩J A↩B = mk↩ {to = to′ } {from = from′} inv + where + to′ : Σ I A → Σ J B + to′ = map (to I↩J) (to A↩B) + + backcast : ∀ {j} → B j → B (to I↩J (from I↩J j)) + backcast = P.subst B (P.sym (inverseˡ I↩J P.refl)) + + from′ : Σ J B → Σ I A + from′ = map (from I↩J) (from A↩B ∘ backcast) + + inv : Inverseˡ _≡_ _≡_ to′ from′ + inv {j , b} P.refl = Σ-≡,≡→≡ (strictlyInverseˡ I↩J j , ( + begin + P.subst B (inverseˡ I↩J P.refl) (to A↩B (from A↩B (backcast b))) ≡⟨ P.cong (P.subst B _) (inverseˡ A↩B P.refl) ⟩ + P.subst B (inverseˡ I↩J P.refl) (backcast b) ≡⟨ P.subst-subst-sym (inverseˡ I↩J _) ⟩ + b ∎)) where open P.≡-Reasoning + +------------------------------------------------------------------------ +-- Right inverses + +------------------------------------------------------------------------ +-- Inverses + +module _ where + open Inverse + + Σ-↔ : (I↔J : I ↔ J) → + (∀ {x} → A x ↔ B (to I↔J x)) → + Σ I A ↔ Σ J B + Σ-↔ {I = I} {J = J} {A = A} {B = B} I↔J A↔B = mk↔ₛ′ + (Surjection.to surjection′) + (Surjection.to⁻ surjection′) + (Surjection.to∘to⁻ surjection′) + left-inverse-of + where + open P.≡-Reasoning + + I≃J = ↔⇒≃ I↔J + + surjection′ : Σ I A ↠ Σ J B + surjection′ = Σ-↠ (↔⇒↠ (≃⇒↔ I≃J)) (↔⇒↠ A↔B) + + left-inverse-of : ∀ p → Surjection.to⁻ surjection′ (Surjection.to surjection′ p) ≡ p + left-inverse-of (x , y) = to Σ-≡,≡↔≡ + ( _≃_.left-inverse-of I≃J x + , (P.subst A (_≃_.left-inverse-of I≃J x) + (from A↔B + (P.subst B (P.sym (_≃_.right-inverse-of I≃J + (_≃_.to I≃J x))) + (to A↔B y))) ≡⟨ P.subst-application B (λ _ → from A↔B) _ ⟩ + + from A↔B + (P.subst B (P.cong (_≃_.to I≃J) + (_≃_.left-inverse-of I≃J x)) + (P.subst B (P.sym (_≃_.right-inverse-of I≃J + (_≃_.to I≃J x))) + (to A↔B y))) ≡⟨ P.cong (λ eq → from A↔B (P.subst B eq + (P.subst B (P.sym (_≃_.right-inverse-of I≃J _)) _))) + (_≃_.left-right I≃J _) ⟩ + from A↔B + (P.subst B (_≃_.right-inverse-of I≃J + (_≃_.to I≃J x)) + (P.subst B (P.sym (_≃_.right-inverse-of I≃J + (_≃_.to I≃J x))) + (to A↔B y))) ≡⟨ P.cong (from A↔B) + (P.subst-subst-sym (_≃_.right-inverse-of I≃J _)) ⟩ + + from A↔B (to A↔B y) ≡⟨ Inverse.strictlyInverseʳ A↔B _ ⟩ + + y ∎) + ) + + +private module _ where + open Inverse + + swap-coercions : ∀ {k} (B : J → Set b) + (I↔J : _↔_ I J) → + (∀ {x} → A x ∼[ k ] B (to I↔J x)) → + ∀ {x} → A (from I↔J x) ∼[ k ] B x + swap-coercions {A = A} B I↔J eq {x} = + A (from I↔J x) ∼⟨ eq ⟩ + B (to I↔J (from I↔J x)) ↔⟨ K-reflexive (P.cong B $ strictlyInverseˡ I↔J x) ⟩ + B x ∎ + where open EquationalReasoning + + +cong : ∀ {k} (I↔J : I ↔ J) → + (∀ {x} → A x ∼[ k ] B (Inverse.to I↔J x)) → + Σ I A ∼[ k ] Σ J B +cong {k = implication} I↔J A⟶B = Σ-⟶ (↔⇒⟶ I↔J) A⟶B +cong {B = B} {k = reverseImplication} I↔J A⟵B = Σ-⟶ (↔⇒⟵ I↔J) (swap-coercions {k = reverseImplication} B I↔J A⟵B) +cong {k = equivalence} I↔J A⇔B = Σ-⇔ (↔⇒↠ I↔J) A⇔B +cong {k = injection} I↔J A↣B = Σ-↣ I↔J A↣B +cong {B = B} {k = reverseInjection} I↔J A↢B = Σ-↣ (↔-sym I↔J) (swap-coercions {k = reverseInjection} B I↔J A↢B) +cong {B = B} {k = leftInverse} I↔J A↩B = ↩⇒↪ (Σ-↩ (↔⇒↩ (↔-sym I↔J)) (↪⇒↩ (swap-coercions {k = leftInverse} B I↔J A↩B))) +cong {k = surjection} I↔J A↠B = Σ-↠ (↔⇒↠ I↔J) A↠B +cong {k = bijection} I↔J A↔B = Σ-↔ I↔J A↔B \ No newline at end of file diff --git a/Data.Product.Function.NonDependent.Propositional.html b/Data.Product.Function.NonDependent.Propositional.html index 0365e157..b112a7e6 100644 --- a/Data.Product.Function.NonDependent.Propositional.html +++ b/Data.Product.Function.NonDependent.Propositional.html @@ -10,68 +10,73 @@ module Data.Product.Function.NonDependent.Propositional where -open import Data.Product -open import Data.Product.Function.NonDependent.Setoid -open import Data.Product.Relation.Binary.Pointwise.NonDependent -open import Relation.Binary hiding (_⇔_) -open import Function.Equality using (_⟶_) -open import Function.Equivalence as Eq using (_⇔_; module Equivalence) -open import Function.Injection as Inj using (_↣_; module Injection) -open import Function.Inverse as Inv using (_↔_; module Inverse) -open import Function.LeftInverse as LeftInv - using (_↞_; _LeftInverseOf_; module LeftInverse) -open import Function.Related -open import Function.Surjection as Surj using (_↠_; module Surjection) - ------------------------------------------------------------------------- --- Combinators for various function types - -module _ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d} where - - _×-⇔_ : A ⇔ B → C ⇔ D → (A × C) ⇔ (B × D) - _×-⇔_ A⇔B C⇔D = - Inverse.equivalence Pointwise-≡↔≡ ⟨∘⟩ - (A⇔B ×-equivalence C⇔D) ⟨∘⟩ - Eq.sym (Inverse.equivalence Pointwise-≡↔≡) - where open Eq using () renaming (_∘_ to _⟨∘⟩_) - - _×-↣_ : A ↣ B → C ↣ D → (A × C) ↣ (B × D) - _×-↣_ A↣B C↣D = - Inverse.injection Pointwise-≡↔≡ ⟨∘⟩ - (A↣B ×-injection C↣D) ⟨∘⟩ - Inverse.injection (Inv.sym Pointwise-≡↔≡) - where open Inj using () renaming (_∘_ to _⟨∘⟩_) - - _×-↞_ : A ↞ B → C ↞ D → (A × C) ↞ (B × D) - _×-↞_ A↞B C↞D = - Inverse.left-inverse Pointwise-≡↔≡ ⟨∘⟩ - (A↞B ×-left-inverse C↞D) ⟨∘⟩ - Inverse.left-inverse (Inv.sym Pointwise-≡↔≡) - where open LeftInv using () renaming (_∘_ to _⟨∘⟩_) - - _×-↠_ : A ↠ B → C ↠ D → (A × C) ↠ (B × D) - _×-↠_ A↠B C↠D = - Inverse.surjection Pointwise-≡↔≡ ⟨∘⟩ - (A↠B ×-surjection C↠D) ⟨∘⟩ - Inverse.surjection (Inv.sym Pointwise-≡↔≡) - where open Surj using () renaming (_∘_ to _⟨∘⟩_) - - _×-↔_ : A ↔ B → C ↔ D → (A × C) ↔ (B × D) - _×-↔_ A↔B C↔D = - Pointwise-≡↔≡ ⟨∘⟩ - (A↔B ×-inverse C↔D) ⟨∘⟩ - Inv.sym Pointwise-≡↔≡ - where open Inv using () renaming (_∘_ to _⟨∘⟩_) - -module _ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d} where - - _×-cong_ : ∀ {k} → A ∼[ k ] B → C ∼[ k ] D → (A × C) ∼[ k ] (B × D) - _×-cong_ {implication} = λ f g → map f g - _×-cong_ {reverse-implication} = λ f g → lam (map (app-← f) (app-← g)) - _×-cong_ {equivalence} = _×-⇔_ - _×-cong_ {injection} = _×-↣_ - _×-cong_ {reverse-injection} = λ f g → lam (app-↢ f ×-↣ app-↢ g) - _×-cong_ {left-inverse} = _×-↞_ - _×-cong_ {surjection} = _×-↠_ - _×-cong_ {bijection} = _×-↔_ +open import Data.Product.Base using (_×_; map) +open import Data.Product.Function.NonDependent.Setoid +open import Data.Product.Relation.Binary.Pointwise.NonDependent +open import Function +open import Function.Properties.Inverse as Inv +open import Function.Related.Propositional +open import Function.Construct.Composition as Compose +open import Level using (Level; _⊔_) +open import Relation.Binary hiding (_⇔_) +open import Relation.Binary.PropositionalEquality using (setoid) + +private + variable + a b c d : Level + A B C D : Set a + +------------------------------------------------------------------------ +-- Helper lemma + +private + liftViaInverse : {R : ∀ {a b ℓ₁ ℓ₂} → REL (Setoid a ℓ₁) (Setoid b ℓ₂) (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂)} → + (∀ {a b c ℓ₁ ℓ₂ ℓ₃} {S : Setoid a ℓ₁} {T : Setoid b ℓ₂} {U : Setoid c ℓ₃} → R S T → R T U → R S U) → + (∀ {a b ℓ₁ ℓ₂} {S : Setoid a ℓ₁} {T : Setoid b ℓ₂} → Inverse S T → R S T) → + (R (setoid A) (setoid C) → R (setoid B) (setoid D) → R (setoid A ×ₛ setoid B) (setoid C ×ₛ setoid D)) → + R (setoid A) (setoid C) → R (setoid B) (setoid D) → + R (setoid (A × B)) (setoid (C × D)) + liftViaInverse trans inv⇒R lift RAC RBD = + Inv.transportVia trans inv⇒R (Inv.sym Pointwise-≡↔≡) (lift RAC RBD) Pointwise-≡↔≡ + +------------------------------------------------------------------------ +-- Combinators for various function types + +infixr 2 _×-⇔_ _×-↣_ _×-↠_ _×-⤖_ _×-↩_ _×-↪_ _×-↔_ + +_×-⟶_ : A ⟶ B → C ⟶ D → (A × C) ⟶ (B × D) +_×-⟶_ = liftViaInverse Compose.function Inv.toFunction _×-function_ + +_×-⇔_ : A ⇔ B → C ⇔ D → (A × C) ⇔ (B × D) +_×-⇔_ = liftViaInverse Compose.equivalence Inverse⇒Equivalence _×-equivalence_ + +_×-↣_ : A ↣ B → C ↣ D → (A × C) ↣ (B × D) +_×-↣_ = liftViaInverse Compose.injection Inverse⇒Injection _×-injection_ + +_×-↠_ : A ↠ B → C ↠ D → (A × C) ↠ (B × D) +_×-↠_ = liftViaInverse Compose.surjection Inverse⇒Surjection _×-surjection_ + +_×-⤖_ : A ⤖ B → C ⤖ D → (A × C) ⤖ (B × D) +_×-⤖_ = liftViaInverse Compose.bijection Inverse⇒Bijection _×-bijection_ + +_×-↩_ : A ↩ B → C ↩ D → (A × C) ↩ (B × D) +_×-↩_ = liftViaInverse Compose.leftInverse Inverse.leftInverse _×-leftInverse_ + +_×-↪_ : A ↪ B → C ↪ D → (A × C) ↪ (B × D) +_×-↪_ = liftViaInverse Compose.rightInverse Inverse.rightInverse _×-rightInverse_ + +_×-↔_ : A ↔ B → C ↔ D → (A × C) ↔ (B × D) +_×-↔_ = liftViaInverse Compose.inverse id _×-inverse_ + +infixr 2 _×-cong_ + +_×-cong_ : ∀ {k} → A ∼[ k ] B → C ∼[ k ] D → (A × C) ∼[ k ] (B × D) +_×-cong_ {k = implication} = _×-⟶_ +_×-cong_ {k = reverseImplication} = _×-⟶_ +_×-cong_ {k = equivalence} = _×-⇔_ +_×-cong_ {k = injection} = _×-↣_ +_×-cong_ {k = reverseInjection} = _×-↣_ +_×-cong_ {k = leftInverse} = _×-↪_ +_×-cong_ {k = surjection} = _×-↠_ +_×-cong_ {k = bijection} = _×-↔_ \ No newline at end of file diff --git a/Data.Product.Function.NonDependent.Setoid.html b/Data.Product.Function.NonDependent.Setoid.html index 73f1e270..62d4e09e 100644 --- a/Data.Product.Function.NonDependent.Setoid.html +++ b/Data.Product.Function.NonDependent.Setoid.html @@ -10,134 +10,127 @@ module Data.Product.Function.NonDependent.Setoid where -open import Data.Product -open import Data.Product.Relation.Binary.Pointwise.NonDependent -open import Relation.Binary -open import Function.Equality as F using (_⟶_; _⟨$⟩_) -open import Function.Equivalence as Eq - using (Equivalence; _⇔_; module Equivalence) -open import Function.Injection as Inj - using (Injection; _↣_; module Injection) -open import Function.Inverse as Inv - using (Inverse; _↔_; module Inverse) -open import Function.LeftInverse as LeftInv - using (LeftInverse; _↞_; _LeftInverseOf_; module LeftInverse) -open import Function.Related -open import Function.Surjection as Surj - using (Surjection; _↠_; module Surjection) - ------------------------------------------------------------------------- --- Combinators for equality preserving functions - -module _ {a₁ a₂ b₁ b₂ c₁ c₂ d₁ d₂} - {A : Setoid a₁ a₂} {B : Setoid b₁ b₂} - {C : Setoid c₁ c₂} {D : Setoid d₁ d₂} - where - - _×-⟶_ : (A ⟶ B) → (C ⟶ D) → (A ×ₛ C) ⟶ (B ×ₛ D) - _×-⟶_ f g = record - { _⟨$⟩_ = fg - ; cong = fg-cong - } - where - open Setoid (A ×ₛ C) using () renaming (_≈_ to _≈AC_) - open Setoid (B ×ₛ D) using () renaming (_≈_ to _≈BD_) - - fg = map (f ⟨$⟩_) (g ⟨$⟩_) - - fg-cong : _≈AC_ =[ fg ]⇒ _≈BD_ - fg-cong (_∼₁_ , _∼₂_) = (F.cong f _∼₁_ , F.cong g _∼₂_) - -module _ {a₁ a₂ b₁ b₂ c₁ c₂} - {A : Setoid a₁ a₂} {B : Setoid b₁ b₂} {C : Setoid c₁ c₂} - where - - <_,_>ₛ : (A ⟶ B) → (A ⟶ C) → A ⟶ (B ×ₛ C) - < f , g >ₛ = record - { _⟨$⟩_ = < f ⟨$⟩_ , g ⟨$⟩_ > - ; cong = < F.cong f , F.cong g > - } - -module _ {a₁ a₂ b₁ b₂} {A : Setoid a₁ a₂} {B : Setoid b₁ b₂} where - - proj₁ₛ : (A ×ₛ B) ⟶ A - proj₁ₛ = record { _⟨$⟩_ = proj₁ ; cong = proj₁ } - - proj₂ₛ : (A ×ₛ B) ⟶ B - proj₂ₛ = record { _⟨$⟩_ = proj₂ ; cong = proj₂ } - - swapₛ : (A ×ₛ B) ⟶ (B ×ₛ A) - swapₛ = < proj₂ₛ , proj₁ₛ >ₛ - ------------------------------------------------------------------------- --- Combinators for more complex function types - -module _ {a₁ a₂ b₁ b₂ c₁ c₂ d₁ d₂} - {A : Setoid a₁ a₂} {B : Setoid b₁ b₂} - {C : Setoid c₁ c₂} {D : Setoid d₁ d₂} - where - - _×-equivalence_ : Equivalence A B → Equivalence C D → - Equivalence (A ×ₛ C) (B ×ₛ D) - _×-equivalence_ A⇔B C⇔D = record - { to = to A⇔B ×-⟶ to C⇔D - ; from = from A⇔B ×-⟶ from C⇔D - } where open Equivalence - - _×-injection_ : Injection A B → Injection C D → - Injection (A ×ₛ C) (B ×ₛ D) - A↣B ×-injection C↣D = record - { to = to A↣B ×-⟶ to C↣D - ; injective = map (injective A↣B) (injective C↣D) - } where open Injection - - _×-left-inverse_ : LeftInverse A B → LeftInverse C D → - LeftInverse (A ×ₛ C) (B ×ₛ D) - A↞B ×-left-inverse C↞D = record - { to = Equivalence.to eq - ; from = Equivalence.from eq - ; left-inverse-of = left - } - where - open LeftInverse - eq = LeftInverse.equivalence A↞B ×-equivalence - LeftInverse.equivalence C↞D - - left : Equivalence.from eq LeftInverseOf Equivalence.to eq - left (x , y) = (left-inverse-of A↞B x , left-inverse-of C↞D y) - -module _ {a₁ a₂ b₁ b₂ c₁ c₂ d₁ d₂} - {A : Setoid a₁ a₂} {B : Setoid b₁ b₂} - {C : Setoid c₁ c₂} {D : Setoid d₁ d₂} - where - - _×-surjection_ : Surjection A B → Surjection C D → - Surjection (A ×ₛ C) (B ×ₛ D) - A↠B ×-surjection C↠D = record - { to = LeftInverse.from inv - ; surjective = record - { from = LeftInverse.to inv - ; right-inverse-of = LeftInverse.left-inverse-of inv - } - } - where - open Surjection - inv = right-inverse A↠B ×-left-inverse right-inverse C↠D - - _×-inverse_ : Inverse A B → Inverse C D → - Inverse (A ×ₛ C) (B ×ₛ D) - A↔B ×-inverse C↔D = record - { to = Surjection.to surj - ; from = Surjection.from surj - ; inverse-of = record - { left-inverse-of = LeftInverse.left-inverse-of inv - ; right-inverse-of = Surjection.right-inverse-of surj - } - } - where - open Inverse - surj = Inverse.surjection A↔B ×-surjection - Inverse.surjection C↔D - inv = Inverse.left-inverse A↔B ×-left-inverse - Inverse.left-inverse C↔D +open import Data.Product.Base as Prod +open import Data.Product.Relation.Binary.Pointwise.NonDependent +open import Level using (Level) +open import Relation.Binary +open import Function + +private + variable + a₁ a₂ b₁ b₂ c₁ c₂ d₁ d₂ : Level + a ℓ : Level + A B C D : Setoid a ℓ + +------------------------------------------------------------------------ +-- Combinators for equality preserving functions + +proj₁ₛ : Func (A ×ₛ B) A +proj₁ₛ = record { to = proj₁ ; cong = proj₁ } + +proj₂ₛ : Func (A ×ₛ B) B +proj₂ₛ = record { to = proj₂ ; cong = proj₂ } + +<_,_>ₛ : Func A B → Func A C → Func A (B ×ₛ C) +< f , g >ₛ = record + { to = < to f , to g > + ; cong = < cong f , cong g > + } where open Func + +swapₛ : Func (A ×ₛ B) (B ×ₛ A) +swapₛ = < proj₂ₛ , proj₁ₛ >ₛ + +------------------------------------------------------------------------ +-- Function bundles + +_×-function_ : Func A B → Func C D → Func (A ×ₛ C) (B ×ₛ D) +f ×-function g = record + { to = Prod.map (to f) (to g) + ; cong = Prod.map (cong f) (cong g) + } where open Func + +infixr 2 _×-equivalence_ _×-injection_ _×-left-inverse_ + +_×-equivalence_ : Equivalence A B → Equivalence C D → + Equivalence (A ×ₛ C) (B ×ₛ D) +_×-equivalence_ f g = record + { to = Prod.map (to f) (to g) + ; from = Prod.map (from f) (from g) + ; to-cong = Prod.map (to-cong f) (to-cong g) + ; from-cong = Prod.map (from-cong f) (from-cong g) + } where open Equivalence + +_×-injection_ : Injection A B → Injection C D → + Injection (A ×ₛ C) (B ×ₛ D) +f ×-injection g = record + { to = Prod.map (to f) (to g) + ; cong = Prod.map (cong f) (cong g) + ; injective = Prod.map (injective f) (injective g) + } where open Injection + +_×-surjection_ : Surjection A B → Surjection C D → + Surjection (A ×ₛ C) (B ×ₛ D) +f ×-surjection g = record + { to = Prod.map (to f) (to g) + ; cong = Prod.map (cong f) (cong g) + ; surjective = λ y → Prod.zip _,_ (λ ff gg x₂ → (ff (proj₁ x₂)) , (gg (proj₂ x₂))) (surjective f (proj₁ y)) (surjective g (proj₂ y)) + } where open Surjection + +_×-bijection_ : Bijection A B → Bijection C D → + Bijection (A ×ₛ C) (B ×ₛ D) +f ×-bijection g = record + { to = Prod.map (to f) (to g) + ; cong = Prod.map (cong f) (cong g) + ; bijective = Prod.map (injective f) (injective g) , + λ { (y₀ , y₁) → Prod.zip _,_ (λ {ff gg (x₀ , x₁) → ff x₀ , gg x₁}) (surjective f y₀) (surjective g y₁)} + } where open Bijection + +_×-leftInverse_ : LeftInverse A B → LeftInverse C D → + LeftInverse (A ×ₛ C) (B ×ₛ D) +f ×-leftInverse g = record + { to = Prod.map (to f) (to g) + ; from = Prod.map (from f) (from g) + ; to-cong = Prod.map (to-cong f) (to-cong g) + ; from-cong = Prod.map (from-cong f) (from-cong g) + ; inverseˡ = λ x → inverseˡ f (proj₁ x) , inverseˡ g (proj₂ x) + } where open LeftInverse + +_×-rightInverse_ : RightInverse A B → RightInverse C D → + RightInverse (A ×ₛ C) (B ×ₛ D) +f ×-rightInverse g = record + { to = Prod.map (to f) (to g) + ; from = Prod.map (from f) (from g) + ; to-cong = Prod.map (to-cong f) (to-cong g) + ; from-cong = Prod.map (from-cong f) (from-cong g) + ; inverseʳ = λ x → inverseʳ f (proj₁ x) , inverseʳ g (proj₂ x) + } where open RightInverse + +infixr 2 _×-surjection_ _×-inverse_ + +_×-inverse_ : Inverse A B → Inverse C D → + Inverse (A ×ₛ C) (B ×ₛ D) +f ×-inverse g = record + { to = Prod.map (to f) (to g) + ; from = Prod.map (from f) (from g) + ; to-cong = Prod.map (to-cong f) (to-cong g) + ; from-cong = Prod.map (from-cong f) (from-cong g) + ; inverse = (λ x → inverseˡ f (proj₁ x) , inverseˡ g (proj₂ x)) , + (λ x → inverseʳ f (proj₁ x) , inverseʳ g (proj₂ x)) + } where open Inverse + + + +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 2.0 + +_×-left-inverse_ = _×-leftInverse_ +{-# WARNING_ON_USAGE _×-left-inverse_ +"Warning: _×-left-inverse_ was deprecated in v2.0. +Please use _×-leftInverse_ instead." +#-} \ No newline at end of file diff --git a/Data.Product.Properties.html b/Data.Product.Properties.html index 4b80b1f1..0bd367ef 100644 --- a/Data.Product.Properties.html +++ b/Data.Product.Properties.html @@ -10,104 +10,105 @@ module Data.Product.Properties where open import Axiom.UniquenessOfIdentityProofs -open import Data.Product -open import Function -open import Level using (Level) -open import Relation.Binary using (DecidableEquality) -open import Relation.Binary.PropositionalEquality -open import Relation.Nullary.Decidable as Dec using (Dec; yes; no) +open import Data.Product.Base +open import Function.Base using (_∋_; _∘_; id) +open import Function.Bundles using (_↔_; mk↔ₛ′) +open import Level using (Level) +open import Relation.Binary.Definitions using (DecidableEquality) +open import Relation.Binary.PropositionalEquality +open import Relation.Nullary.Decidable as Dec using (Dec; yes; no) -private - variable - a b c d ℓ : Level - A : Set a - B : Set b - C : Set c - D : Set d +private + variable + a b c d ℓ : Level + A : Set a + B : Set b + C : Set c + D : Set d ------------------------------------------------------------------------- --- Equality (dependent) +------------------------------------------------------------------------ +-- Equality (dependent) -module _ {B : A → Set b} where +module _ {B : A → Set b} where - ,-injectiveˡ : ∀ {a c} {b : B a} {d : B c} → (a , b) ≡ (c , d) → a ≡ c - ,-injectiveˡ refl = refl + ,-injectiveˡ : ∀ {a c} {b : B a} {d : B c} → (a , b) ≡ (c , d) → a ≡ c + ,-injectiveˡ refl = refl - ,-injectiveʳ-≡ : ∀ {a b} {c : B a} {d : B b} → UIP A → (a , c) ≡ (b , d) → (q : a ≡ b) → subst B q c ≡ d - ,-injectiveʳ-≡ {c = c} u refl q = cong (λ x → subst B x c) (u q refl) + ,-injectiveʳ-≡ : ∀ {a b} {c : B a} {d : B b} → UIP A → (a , c) ≡ (b , d) → (q : a ≡ b) → subst B q c ≡ d + ,-injectiveʳ-≡ {c = c} u refl q = cong (λ x → subst B x c) (u q refl) - ,-injectiveʳ-UIP : ∀ {a} {b c : B a} → UIP A → (Σ A B ∋ (a , b)) ≡ (a , c) → b ≡ c - ,-injectiveʳ-UIP u p = ,-injectiveʳ-≡ u p refl + ,-injectiveʳ-UIP : ∀ {a} {b c : B a} → UIP A → (Σ A B ∋ (a , b)) ≡ (a , c) → b ≡ c + ,-injectiveʳ-UIP u p = ,-injectiveʳ-≡ u p refl - ≡-dec : DecidableEquality A → (∀ {a} → DecidableEquality (B a)) → - DecidableEquality (Σ A B) - ≡-dec dec₁ dec₂ (a , x) (b , y) with dec₁ a b - ... | no [a≢b] = no ([a≢b] ∘ ,-injectiveˡ) - ... | yes refl = Dec.map′ (cong (a ,_)) (,-injectiveʳ-UIP (Decidable⇒UIP.≡-irrelevant dec₁)) (dec₂ x y) + ≡-dec : DecidableEquality A → (∀ {a} → DecidableEquality (B a)) → + DecidableEquality (Σ A B) + ≡-dec dec₁ dec₂ (a , x) (b , y) with dec₁ a b + ... | no [a≢b] = no ([a≢b] ∘ ,-injectiveˡ) + ... | yes refl = Dec.map′ (cong (a ,_)) (,-injectiveʳ-UIP (Decidable⇒UIP.≡-irrelevant dec₁)) (dec₂ x y) ------------------------------------------------------------------------- --- Equality (non-dependent) +------------------------------------------------------------------------ +-- Equality (non-dependent) -,-injectiveʳ : ∀ {a c : A} {b d : B} → (a , b) ≡ (c , d) → b ≡ d -,-injectiveʳ refl = refl +,-injectiveʳ : ∀ {a c : A} {b d : B} → (a , b) ≡ (c , d) → b ≡ d +,-injectiveʳ refl = refl -,-injective : ∀ {a c : A} {b d : B} → (a , b) ≡ (c , d) → a ≡ c × b ≡ d -,-injective refl = refl , refl +,-injective : ∀ {a c : A} {b d : B} → (a , b) ≡ (c , d) → a ≡ c × b ≡ d +,-injective refl = refl , refl -map-cong : ∀ {f g : A → C} {h i : B → D} → f ≗ g → h ≗ i → map f h ≗ map g i -map-cong f≗g h≗i (x , y) = cong₂ _,_ (f≗g x) (h≗i y) +map-cong : ∀ {f g : A → C} {h i : B → D} → f ≗ g → h ≗ i → map f h ≗ map g i +map-cong f≗g h≗i (x , y) = cong₂ _,_ (f≗g x) (h≗i y) --- The following properties are definitionally true (because of η) --- but for symmetry with ⊎ it is convenient to define and name them. +-- The following properties are definitionally true (because of η) +-- but for symmetry with ⊎ it is convenient to define and name them. -swap-involutive : swap {A = A} {B = B} ∘ swap ≗ id -swap-involutive _ = refl +swap-involutive : swap {A = A} {B = B} ∘ swap ≗ id +swap-involutive _ = refl ------------------------------------------------------------------------- --- Equality between pairs can be expressed as a pair of equalities +------------------------------------------------------------------------ +-- Equality between pairs can be expressed as a pair of equalities -module _ {A : Set a} {B : A → Set b} {p₁@(a₁ , b₁) p₂@(a₂ , b₂) : Σ A B} where - Σ-≡,≡→≡ : Σ (a₁ ≡ a₂) (λ p → subst B p b₁ ≡ b₂) → p₁ ≡ p₂ - Σ-≡,≡→≡ (refl , refl) = refl +module _ {A : Set a} {B : A → Set b} {p₁@(a₁ , b₁) p₂@(a₂ , b₂) : Σ A B} where + Σ-≡,≡→≡ : Σ (a₁ ≡ a₂) (λ p → subst B p b₁ ≡ b₂) → p₁ ≡ p₂ + Σ-≡,≡→≡ (refl , refl) = refl - Σ-≡,≡←≡ : p₁ ≡ p₂ → Σ (a₁ ≡ a₂) (λ p → subst B p b₁ ≡ b₂) - Σ-≡,≡←≡ refl = refl , refl + Σ-≡,≡←≡ : p₁ ≡ p₂ → Σ (a₁ ≡ a₂) (λ p → subst B p b₁ ≡ b₂) + Σ-≡,≡←≡ refl = refl , refl - private - left-inverse-of : (p : Σ (a₁ ≡ a₂) (λ x → subst B x b₁ ≡ b₂)) → - Σ-≡,≡←≡ (Σ-≡,≡→≡ p) ≡ p - left-inverse-of (refl , refl) = refl + private + left-inverse-of : (p : Σ (a₁ ≡ a₂) (λ x → subst B x b₁ ≡ b₂)) → + Σ-≡,≡←≡ (Σ-≡,≡→≡ p) ≡ p + left-inverse-of (refl , refl) = refl - right-inverse-of : (p : p₁ ≡ p₂) → Σ-≡,≡→≡ (Σ-≡,≡←≡ p) ≡ p - right-inverse-of refl = refl + right-inverse-of : (p : p₁ ≡ p₂) → Σ-≡,≡→≡ (Σ-≡,≡←≡ p) ≡ p + right-inverse-of refl = refl - Σ-≡,≡↔≡ : (∃ λ (p : a₁ ≡ a₂) → subst B p b₁ ≡ b₂) ↔ p₁ ≡ p₂ - Σ-≡,≡↔≡ = mk↔′ Σ-≡,≡→≡ Σ-≡,≡←≡ right-inverse-of left-inverse-of + Σ-≡,≡↔≡ : (∃ λ (p : a₁ ≡ a₂) → subst B p b₁ ≡ b₂) ↔ p₁ ≡ p₂ + Σ-≡,≡↔≡ = mk↔ₛ′ Σ-≡,≡→≡ Σ-≡,≡←≡ right-inverse-of left-inverse-of --- the non-dependent case. Proofs are exactly as above, and straightforward. -module _ {p₁@(a₁ , b₁) p₂@(a₂ , b₂) : A × B} where - ×-≡,≡→≡ : (a₁ ≡ a₂ × b₁ ≡ b₂) → p₁ ≡ p₂ - ×-≡,≡→≡ (refl , refl) = refl +-- the non-dependent case. Proofs are exactly as above, and straightforward. +module _ {p₁@(a₁ , b₁) p₂@(a₂ , b₂) : A × B} where + ×-≡,≡→≡ : (a₁ ≡ a₂ × b₁ ≡ b₂) → p₁ ≡ p₂ + ×-≡,≡→≡ (refl , refl) = refl - ×-≡,≡←≡ : p₁ ≡ p₂ → (a₁ ≡ a₂ × b₁ ≡ b₂) - ×-≡,≡←≡ refl = refl , refl + ×-≡,≡←≡ : p₁ ≡ p₂ → (a₁ ≡ a₂ × b₁ ≡ b₂) + ×-≡,≡←≡ refl = refl , refl - ×-≡,≡↔≡ : (a₁ ≡ a₂ × b₁ ≡ b₂) ↔ p₁ ≡ p₂ - ×-≡,≡↔≡ = mk↔′ - ×-≡,≡→≡ - ×-≡,≡←≡ - (λ { refl → refl }) - (λ { (refl , refl) → refl }) + ×-≡,≡↔≡ : (a₁ ≡ a₂ × b₁ ≡ b₂) ↔ p₁ ≡ p₂ + ×-≡,≡↔≡ = mk↔ₛ′ + ×-≡,≡→≡ + ×-≡,≡←≡ + (λ { refl → refl }) + (λ { (refl , refl) → refl }) ------------------------------------------------------------------------- --- The order of ∃₂ can be swapped +------------------------------------------------------------------------ +-- The order of ∃₂ can be swapped -∃∃↔∃∃ : (R : A → B → Set ℓ) → (∃₂ λ x y → R x y) ↔ (∃₂ λ y x → R x y) -∃∃↔∃∃ R = mk↔′ to from cong′ cong′ - where - to : (∃₂ λ x y → R x y) → (∃₂ λ y x → R x y) - to (x , y , Rxy) = (y , x , Rxy) +∃∃↔∃∃ : (R : A → B → Set ℓ) → (∃₂ λ x y → R x y) ↔ (∃₂ λ y x → R x y) +∃∃↔∃∃ R = mk↔ₛ′ to from cong′ cong′ + where + to : (∃₂ λ x y → R x y) → (∃₂ λ y x → R x y) + to (x , y , Rxy) = (y , x , Rxy) - from : (∃₂ λ y x → R x y) → (∃₂ λ x y → R x y) - from (y , x , Rxy) = (x , y , Rxy) + from : (∃₂ λ y x → R x y) → (∃₂ λ x y → R x y) + from (y , x , Rxy) = (x , y , Rxy) \ No newline at end of file diff --git a/Data.Product.Relation.Binary.Pointwise.NonDependent.html b/Data.Product.Relation.Binary.Pointwise.NonDependent.html index 66f08c0d..31cf32b2 100644 --- a/Data.Product.Relation.Binary.Pointwise.NonDependent.html +++ b/Data.Product.Relation.Binary.Pointwise.NonDependent.html @@ -9,239 +9,197 @@ module Data.Product.Relation.Binary.Pointwise.NonDependent where -open import Data.Product as Prod -open import Data.Product.Properties using (≡-dec) -open import Data.Sum.Base -open import Data.Unit.Base using (⊤) -open import Function.Base -open import Function.Equality as F using (_⟶_; _⟨$⟩_) -open import Function.Equivalence as Eq - using (Equivalence; _⇔_; module Equivalence) -open import Function.Injection as Inj - using (Injection; _↣_; module Injection) -open import Function.Inverse as Inv - using (Inverse; _↔_; module Inverse) -open import Function.LeftInverse as LeftInv - using (LeftInverse; _↞_; _LeftInverseOf_; module LeftInverse) -open import Function.Related -open import Function.Surjection as Surj - using (Surjection; _↠_; module Surjection) -open import Relation.Nullary.Decidable using (_×-dec_) -open import Relation.Binary -open import Relation.Binary.PropositionalEquality as P using (_≡_) - -module _ {a₁ a₂ ℓ₁ ℓ₂} {A₁ : Set a₁} {A₂ : Set a₂} where - ------------------------------------------------------------------------- --- Pointwise lifting - - Pointwise : Rel A₁ ℓ₁ → Rel A₂ ℓ₂ → Rel (A₁ × A₂) _ - Pointwise _∼₁_ _∼₂_ = (_∼₁_ on proj₁) -×- (_∼₂_ on proj₂) - ------------------------------------------------------------------------- --- Pointwise preserves many relational properties - - ×-reflexive : ∀ {_≈₁_ _∼₁_ _≈₂_ _∼₂_} → - _≈₁_ ⇒ _∼₁_ → _≈₂_ ⇒ _∼₂_ → - (Pointwise _≈₁_ _≈₂_) ⇒ (Pointwise _∼₁_ _∼₂_) - ×-reflexive refl₁ refl₂ (x∼y₁ , x∼y₂) = refl₁ x∼y₁ , refl₂ x∼y₂ - - ×-refl : ∀ {_∼₁_ _∼₂_} → - Reflexive _∼₁_ → Reflexive _∼₂_ → - Reflexive (Pointwise _∼₁_ _∼₂_) - ×-refl refl₁ refl₂ = refl₁ , refl₂ - - ×-irreflexive₁ : ∀ {_≈₁_ _<₁_ _≈₂_ _<₂_} → - Irreflexive _≈₁_ _<₁_ → - Irreflexive (Pointwise _≈₁_ _≈₂_) (Pointwise _<₁_ _<₂_) - ×-irreflexive₁ ir x≈y x<y = ir (proj₁ x≈y) (proj₁ x<y) - - ×-irreflexive₂ : ∀ {_≈₁_ _<₁_ _≈₂_ _<₂_} → - Irreflexive _≈₂_ _<₂_ → - Irreflexive (Pointwise _≈₁_ _≈₂_) (Pointwise _<₁_ _<₂_) - ×-irreflexive₂ ir x≈y x<y = ir (proj₂ x≈y) (proj₂ x<y) - - ×-symmetric : ∀ {_∼₁_ _∼₂_} → Symmetric _∼₁_ → Symmetric _∼₂_ → - Symmetric (Pointwise _∼₁_ _∼₂_) - ×-symmetric sym₁ sym₂ (x∼y₁ , x∼y₂) = sym₁ x∼y₁ , sym₂ x∼y₂ - - ×-transitive : ∀ {_∼₁_ _∼₂_} → Transitive _∼₁_ → Transitive _∼₂_ → - Transitive (Pointwise _∼₁_ _∼₂_) - ×-transitive trans₁ trans₂ x∼y y∼z = - trans₁ (proj₁ x∼y) (proj₁ y∼z) , - trans₂ (proj₂ x∼y) (proj₂ y∼z) - - ×-antisymmetric : ∀ {_≈₁_ _≤₁_ _≈₂_ _≤₂_} → - Antisymmetric _≈₁_ _≤₁_ → Antisymmetric _≈₂_ _≤₂_ → - Antisymmetric (Pointwise _≈₁_ _≈₂_) (Pointwise _≤₁_ _≤₂_) - ×-antisymmetric antisym₁ antisym₂ (x≤y₁ , x≤y₂) (y≤x₁ , y≤x₂) = - (antisym₁ x≤y₁ y≤x₁ , antisym₂ x≤y₂ y≤x₂) - - ×-asymmetric₁ : ∀ {_<₁_ _∼₂_} → Asymmetric _<₁_ → - Asymmetric (Pointwise _<₁_ _∼₂_) - ×-asymmetric₁ asym₁ x<y y<x = asym₁ (proj₁ x<y) (proj₁ y<x) - - ×-asymmetric₂ : ∀ {_∼₁_ _<₂_} → Asymmetric _<₂_ → - Asymmetric (Pointwise _∼₁_ _<₂_) - ×-asymmetric₂ asym₂ x<y y<x = asym₂ (proj₂ x<y) (proj₂ y<x) - - ×-respects₂ : ∀ {_≈₁_ _∼₁_ _≈₂_ _∼₂_} → - _∼₁_ Respects₂ _≈₁_ → _∼₂_ Respects₂ _≈₂_ → - (Pointwise _∼₁_ _∼₂_) Respects₂ (Pointwise _≈₁_ _≈₂_) - ×-respects₂ {_≈₁_} {_∼₁_} {_≈₂_} {_∼₂_} resp₁ resp₂ = resp¹ , resp² - where - _∼_ = Pointwise _∼₁_ _∼₂_ - _≈_ = Pointwise _≈₁_ _≈₂_ - - resp¹ : ∀ {x} → (x ∼_) Respects _≈_ - resp¹ y≈y′ x∼y = proj₁ resp₁ (proj₁ y≈y′) (proj₁ x∼y) , - proj₁ resp₂ (proj₂ y≈y′) (proj₂ x∼y) - - resp² : ∀ {y} → (_∼ y) Respects _≈_ - resp² x≈x′ x∼y = proj₂ resp₁ (proj₁ x≈x′) (proj₁ x∼y) , - proj₂ resp₂ (proj₂ x≈x′) (proj₂ x∼y) - - ×-total : ∀ {_∼₁_ _∼₂_} → Symmetric _∼₁_ → - Total _∼₁_ → Total _∼₂_ → - Total (Pointwise _∼₁_ _∼₂_) - ×-total sym₁ total₁ total₂ (x₁ , x₂) (y₁ , y₂) - with total₁ x₁ y₁ | total₂ x₂ y₂ - ... | inj₁ x₁∼y₁ | inj₁ x₂∼y₂ = inj₁ ( x₁∼y₁ , x₂∼y₂) - ... | inj₁ x₁∼y₁ | inj₂ y₂∼x₂ = inj₂ (sym₁ x₁∼y₁ , y₂∼x₂) - ... | inj₂ y₁∼x₁ | inj₂ y₂∼x₂ = inj₂ ( y₁∼x₁ , y₂∼x₂) - ... | inj₂ y₁∼x₁ | inj₁ x₂∼y₂ = inj₁ (sym₁ y₁∼x₁ , x₂∼y₂) - - ×-decidable : ∀ {_∼₁_ _∼₂_} → - Decidable _∼₁_ → Decidable _∼₂_ → - Decidable (Pointwise _∼₁_ _∼₂_) - ×-decidable _≟₁_ _≟₂_ (x₁ , x₂) (y₁ , y₂) = - (x₁ ≟₁ y₁) ×-dec (x₂ ≟₂ y₂) - - -- Some collections of properties which are preserved by ×-Rel. - - ×-isEquivalence : ∀ {_≈₁_ _≈₂_} → - IsEquivalence _≈₁_ → IsEquivalence _≈₂_ → - IsEquivalence (Pointwise _≈₁_ _≈₂_) - ×-isEquivalence {_≈₁_ = _≈₁_} {_≈₂_ = _≈₂_} eq₁ eq₂ = record - { refl = ×-refl {_∼₁_ = _≈₁_} {_∼₂_ = _≈₂_} - (refl eq₁) (refl eq₂) - ; sym = ×-symmetric {_∼₁_ = _≈₁_} {_∼₂_ = _≈₂_} - (sym eq₁) (sym eq₂) - ; trans = ×-transitive {_∼₁_ = _≈₁_} {_∼₂_ = _≈₂_} - (trans eq₁) (trans eq₂) - } - where open IsEquivalence - - ×-isDecEquivalence : ∀ {_≈₁_ _≈₂_} → - IsDecEquivalence _≈₁_ → IsDecEquivalence _≈₂_ → - IsDecEquivalence (Pointwise _≈₁_ _≈₂_) - ×-isDecEquivalence eq₁ eq₂ = record - { isEquivalence = ×-isEquivalence - (isEquivalence eq₁) (isEquivalence eq₂) - ; _≟_ = ×-decidable (_≟_ eq₁) (_≟_ eq₂) - } - where open IsDecEquivalence - - ×-isPreorder : ∀ {_≈₁_ _∼₁_ _≈₂_ _∼₂_} → - IsPreorder _≈₁_ _∼₁_ → IsPreorder _≈₂_ _∼₂_ → - IsPreorder (Pointwise _≈₁_ _≈₂_) (Pointwise _∼₁_ _∼₂_) - ×-isPreorder {_∼₁_ = _∼₁_} {_∼₂_ = _∼₂_} pre₁ pre₂ = record - { isEquivalence = ×-isEquivalence - (isEquivalence pre₁) (isEquivalence pre₂) - ; reflexive = ×-reflexive {_∼₁_ = _∼₁_} {_∼₂_ = _∼₂_} - (reflexive pre₁) (reflexive pre₂) - ; trans = ×-transitive {_∼₁_ = _∼₁_} {_∼₂_ = _∼₂_} - (trans pre₁) (trans pre₂) - } - where open IsPreorder - - ×-isPartialOrder : ∀ {_≈₁_ _≤₁_ _≈₂_ _≤₂_} → - IsPartialOrder _≈₁_ _≤₁_ → IsPartialOrder _≈₂_ _≤₂_ → - IsPartialOrder (Pointwise _≈₁_ _≈₂_) (Pointwise _≤₁_ _≤₂_) - ×-isPartialOrder {_≤₁_ = _≤₁_} {_≤₂_ = _≤₂_} po₁ po₂ = record - { isPreorder = ×-isPreorder (isPreorder po₁) (isPreorder po₂) - ; antisym = ×-antisymmetric {_≤₁_ = _≤₁_} {_≤₂_ = _≤₂_} - (antisym po₁) (antisym po₂) - } - where open IsPartialOrder - - ×-isStrictPartialOrder : ∀ {_≈₁_ _<₁_ _≈₂_ _<₂_} → - IsStrictPartialOrder _≈₁_ _<₁_ → IsStrictPartialOrder _≈₂_ _<₂_ → - IsStrictPartialOrder (Pointwise _≈₁_ _≈₂_) (Pointwise _<₁_ _<₂_) - ×-isStrictPartialOrder {_<₁_ = _<₁_} {_≈₂_ = _≈₂_} {_<₂_ = _<₂_} - spo₁ spo₂ = - record - { isEquivalence = ×-isEquivalence - (isEquivalence spo₁) (isEquivalence spo₂) - ; irrefl = ×-irreflexive₁ {_<₁_ = _<₁_} {_≈₂_} {_<₂_} - (irrefl spo₁) - ; trans = ×-transitive {_∼₁_ = _<₁_} {_<₂_} - (trans spo₁) (trans spo₂) - ; <-resp-≈ = ×-respects₂ (<-resp-≈ spo₁) (<-resp-≈ spo₂) - } - where open IsStrictPartialOrder - ------------------------------------------------------------------------- --- "Bundles" can also be combined. - -module _ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} where - - ×-preorder : Preorder ℓ₁ ℓ₂ _ → Preorder ℓ₃ ℓ₄ _ → Preorder _ _ _ - ×-preorder p₁ p₂ = record - { isPreorder = ×-isPreorder (isPreorder p₁) (isPreorder p₂) - } where open Preorder - - ×-setoid : Setoid ℓ₁ ℓ₂ → Setoid ℓ₃ ℓ₄ → Setoid _ _ - ×-setoid s₁ s₂ = record - { isEquivalence = - ×-isEquivalence (isEquivalence s₁) (isEquivalence s₂) - } where open Setoid - - ×-decSetoid : DecSetoid ℓ₁ ℓ₂ → DecSetoid ℓ₃ ℓ₄ → DecSetoid _ _ - ×-decSetoid s₁ s₂ = record - { isDecEquivalence = - ×-isDecEquivalence (isDecEquivalence s₁) (isDecEquivalence s₂) - } where open DecSetoid - - ×-poset : Poset ℓ₁ ℓ₂ _ → Poset ℓ₃ ℓ₄ _ → Poset _ _ _ - ×-poset s₁ s₂ = record - { isPartialOrder = ×-isPartialOrder (isPartialOrder s₁) - (isPartialOrder s₂) - } where open Poset - - ×-strictPartialOrder : - StrictPartialOrder ℓ₁ ℓ₂ _ → StrictPartialOrder ℓ₃ ℓ₄ _ → - StrictPartialOrder _ _ _ - ×-strictPartialOrder s₁ s₂ = record - { isStrictPartialOrder = ×-isStrictPartialOrder - (isStrictPartialOrder s₁) - (isStrictPartialOrder s₂) - } where open StrictPartialOrder - - -- A piece of infix notation for combining setoids - infix 4 _×ₛ_ - _×ₛ_ : Setoid ℓ₁ ℓ₂ → Setoid ℓ₃ ℓ₄ → Setoid _ _ - _×ₛ_ = ×-setoid - ------------------------------------------------------------------------- --- The propositional equality setoid over products can be --- decomposed using ×-Rel - -module _ {a b} {A : Set a} {B : Set b} where - - ≡×≡⇒≡ : Pointwise _≡_ _≡_ ⇒ _≡_ {A = A × B} - ≡×≡⇒≡ (P.refl , P.refl) = P.refl - - ≡⇒≡×≡ : _≡_ {A = A × B} ⇒ Pointwise _≡_ _≡_ - ≡⇒≡×≡ P.refl = (P.refl , P.refl) - - Pointwise-≡↔≡ : Inverse (P.setoid A ×ₛ P.setoid B) (P.setoid (A × B)) - Pointwise-≡↔≡ = record - { to = record { _⟨$⟩_ = id; cong = ≡×≡⇒≡ } - ; from = record { _⟨$⟩_ = id; cong = ≡⇒≡×≡ } - ; inverse-of = record - { left-inverse-of = λ _ → (P.refl , P.refl) - ; right-inverse-of = λ _ → P.refl - } - } +open import Data.Product.Base as Prod +open import Data.Product.Properties using (≡-dec) +open import Data.Sum.Base +open import Data.Unit.Base using (⊤) +open import Level using (Level; _⊔_; 0ℓ) +open import Function +open import Relation.Nullary.Decidable using (_×-dec_) +open import Relation.Binary +open import Relation.Binary.PropositionalEquality.Core as P using (_≡_) +import Relation.Binary.PropositionalEquality.Properties as P + +private + variable + a b ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Level + A B : Set a + R S ≈₁ ≈₂ : Rel A ℓ₁ + +------------------------------------------------------------------------ +-- Definition + +Pointwise : Rel A ℓ₁ → Rel B ℓ₂ → Rel (A × B) (ℓ₁ ⊔ ℓ₂) +Pointwise R S = (R on proj₁) -×- (S on proj₂) + +------------------------------------------------------------------------ +-- Pointwise preserves many relational properties + +×-reflexive : ≈₁ ⇒ R → ≈₂ ⇒ S → Pointwise ≈₁ ≈₂ ⇒ Pointwise R S +×-reflexive refl₁ refl₂ = Prod.map refl₁ refl₂ + +×-refl : Reflexive R → Reflexive S → Reflexive (Pointwise R S) +×-refl refl₁ refl₂ = refl₁ , refl₂ + +×-irreflexive₁ : Irreflexive ≈₁ R → + Irreflexive (Pointwise ≈₁ ≈₂) (Pointwise R S) +×-irreflexive₁ ir x≈y x<y = ir (proj₁ x≈y) (proj₁ x<y) + +×-irreflexive₂ : Irreflexive ≈₂ S → + Irreflexive (Pointwise ≈₁ ≈₂) (Pointwise R S) +×-irreflexive₂ ir x≈y x<y = ir (proj₂ x≈y) (proj₂ x<y) + +×-symmetric : Symmetric R → Symmetric S → Symmetric (Pointwise R S) +×-symmetric sym₁ sym₂ = Prod.map sym₁ sym₂ + +×-transitive : Transitive R → Transitive S → Transitive (Pointwise R S) +×-transitive trans₁ trans₂ = Prod.zip trans₁ trans₂ + +×-antisymmetric : Antisymmetric ≈₁ R → Antisymmetric ≈₂ S → + Antisymmetric (Pointwise ≈₁ ≈₂) (Pointwise R S) +×-antisymmetric antisym₁ antisym₂ = Prod.zip antisym₁ antisym₂ + +×-asymmetric₁ : Asymmetric R → Asymmetric (Pointwise R S) +×-asymmetric₁ asym₁ x<y y<x = asym₁ (proj₁ x<y) (proj₁ y<x) + +×-asymmetric₂ : Asymmetric S → Asymmetric (Pointwise R S) +×-asymmetric₂ asym₂ x<y y<x = asym₂ (proj₂ x<y) (proj₂ y<x) + +×-respectsʳ : R Respectsʳ ≈₁ → S Respectsʳ ≈₂ → + (Pointwise R S) Respectsʳ (Pointwise ≈₁ ≈₂) +×-respectsʳ resp₁ resp₂ = Prod.zip resp₁ resp₂ + +×-respectsˡ : R Respectsˡ ≈₁ → S Respectsˡ ≈₂ → + (Pointwise R S) Respectsˡ (Pointwise ≈₁ ≈₂) +×-respectsˡ resp₁ resp₂ = Prod.zip resp₁ resp₂ + +×-respects₂ : R Respects₂ ≈₁ → S Respects₂ ≈₂ → + (Pointwise R S) Respects₂ (Pointwise ≈₁ ≈₂) +×-respects₂ = Prod.zip ×-respectsʳ ×-respectsˡ + +×-total : Symmetric R → Total R → Total S → Total (Pointwise R S) +×-total sym₁ total₁ total₂ (x₁ , x₂) (y₁ , y₂) + with total₁ x₁ y₁ | total₂ x₂ y₂ +... | inj₁ x₁∼y₁ | inj₁ x₂∼y₂ = inj₁ ( x₁∼y₁ , x₂∼y₂) +... | inj₁ x₁∼y₁ | inj₂ y₂∼x₂ = inj₂ (sym₁ x₁∼y₁ , y₂∼x₂) +... | inj₂ y₁∼x₁ | inj₂ y₂∼x₂ = inj₂ ( y₁∼x₁ , y₂∼x₂) +... | inj₂ y₁∼x₁ | inj₁ x₂∼y₂ = inj₁ (sym₁ y₁∼x₁ , x₂∼y₂) + +×-decidable : Decidable R → Decidable S → Decidable (Pointwise R S) +×-decidable _≟₁_ _≟₂_ (x₁ , x₂) (y₁ , y₂) = (x₁ ≟₁ y₁) ×-dec (x₂ ≟₂ y₂) + +------------------------------------------------------------------------ +-- Structures can also be combined. + +-- Some collections of properties which are preserved by ×-Rel. + +×-isEquivalence : IsEquivalence R → IsEquivalence S → + IsEquivalence (Pointwise R S) +×-isEquivalence {R = R} {S = S} eq₁ eq₂ = record + { refl = ×-refl {R = R} {S = S} (refl eq₁) (refl eq₂) + ; sym = ×-symmetric {R = R} {S = S} (sym eq₁) (sym eq₂) + ; trans = ×-transitive {R = R} {S = S} (trans eq₁) (trans eq₂) + } where open IsEquivalence + +×-isDecEquivalence : IsDecEquivalence R → IsDecEquivalence S → + IsDecEquivalence (Pointwise R S) +×-isDecEquivalence eq₁ eq₂ = record + { isEquivalence = ×-isEquivalence + (isEquivalence eq₁) (isEquivalence eq₂) + ; _≟_ = ×-decidable (_≟_ eq₁) (_≟_ eq₂) + } where open IsDecEquivalence + +×-isPreorder : IsPreorder ≈₁ R → IsPreorder ≈₂ S → + IsPreorder (Pointwise ≈₁ ≈₂) (Pointwise R S) +×-isPreorder {R = R} {S = S} pre₁ pre₂ = record + { isEquivalence = ×-isEquivalence + (isEquivalence pre₁) (isEquivalence pre₂) + ; reflexive = ×-reflexive {R = R} {S = S} + (reflexive pre₁) (reflexive pre₂) + ; trans = ×-transitive {R = R} {S = S} + (trans pre₁) (trans pre₂) + } where open IsPreorder + +×-isPartialOrder : IsPartialOrder ≈₁ R → IsPartialOrder ≈₂ S → + IsPartialOrder (Pointwise ≈₁ ≈₂) (Pointwise R S) +×-isPartialOrder {R = R} {S = S} po₁ po₂ = record + { isPreorder = ×-isPreorder (isPreorder po₁) (isPreorder po₂) + ; antisym = ×-antisymmetric {R = R} {S = S} + (antisym po₁) (antisym po₂) + } where open IsPartialOrder + +×-isStrictPartialOrder : IsStrictPartialOrder ≈₁ R → + IsStrictPartialOrder ≈₂ S → + IsStrictPartialOrder (Pointwise ≈₁ ≈₂) (Pointwise R S) +×-isStrictPartialOrder {R = R} {≈₂ = ≈₂} {S = S} spo₁ spo₂ = record + { isEquivalence = ×-isEquivalence + (isEquivalence spo₁) (isEquivalence spo₂) + ; irrefl = ×-irreflexive₁ {R = R} {≈₂ = ≈₂} {S = S} + (irrefl spo₁) + ; trans = ×-transitive {R = R} {S = S} + (trans spo₁) (trans spo₂) + ; <-resp-≈ = ×-respects₂ (<-resp-≈ spo₁) (<-resp-≈ spo₂) + } where open IsStrictPartialOrder + +------------------------------------------------------------------------ +-- Bundles + +×-setoid : Setoid a ℓ₁ → Setoid b ℓ₂ → Setoid _ _ +×-setoid s₁ s₂ = record + { isEquivalence = + ×-isEquivalence (isEquivalence s₁) (isEquivalence s₂) + } where open Setoid + +×-decSetoid : DecSetoid a ℓ₁ → DecSetoid b ℓ₂ → DecSetoid _ _ +×-decSetoid s₁ s₂ = record + { isDecEquivalence = + ×-isDecEquivalence (isDecEquivalence s₁) (isDecEquivalence s₂) + } where open DecSetoid + +×-preorder : Preorder a ℓ₁ ℓ₂ → Preorder b ℓ₃ ℓ₄ → Preorder _ _ _ +×-preorder p₁ p₂ = record + { isPreorder = ×-isPreorder (isPreorder p₁) (isPreorder p₂) + } where open Preorder + +×-poset : Poset a ℓ₁ ℓ₂ → Poset b ℓ₃ ℓ₄ → Poset _ _ _ +×-poset s₁ s₂ = record + { isPartialOrder = ×-isPartialOrder (isPartialOrder s₁) + (isPartialOrder s₂) + } where open Poset + +×-strictPartialOrder : StrictPartialOrder a ℓ₁ ℓ₂ → + StrictPartialOrder b ℓ₃ ℓ₄ → + StrictPartialOrder _ _ _ +×-strictPartialOrder s₁ s₂ = record + { isStrictPartialOrder = ×-isStrictPartialOrder + (isStrictPartialOrder s₁) + (isStrictPartialOrder s₂) + } where open StrictPartialOrder + +------------------------------------------------------------------------ +-- Additional notation + +-- Infix combining setoids +infix 4 _×ₛ_ +_×ₛ_ : Setoid a ℓ₁ → Setoid b ℓ₂ → Setoid _ _ +_×ₛ_ = ×-setoid + +------------------------------------------------------------------------ +-- The propositional equality setoid over products can be +-- decomposed using ×-Rel + +≡×≡⇒≡ : Pointwise _≡_ _≡_ ⇒ _≡_ {A = A × B} +≡×≡⇒≡ (P.refl , P.refl) = P.refl + +≡⇒≡×≡ : _≡_ {A = A × B} ⇒ Pointwise _≡_ _≡_ +≡⇒≡×≡ P.refl = (P.refl , P.refl) + +Pointwise-≡↔≡ : Inverse (P.setoid A ×ₛ P.setoid B) (P.setoid (A × B)) +Pointwise-≡↔≡ = record + { to = id + ; from = id + ; to-cong = ≡×≡⇒≡ + ; from-cong = ≡⇒≡×≡ + ; inverse = ≡×≡⇒≡ , ≡⇒≡×≡ + } \ No newline at end of file diff --git a/Data.Product.Relation.Unary.All.html b/Data.Product.Relation.Unary.All.html index 01eaddc2..9cb8a1c7 100644 --- a/Data.Product.Relation.Unary.All.html +++ b/Data.Product.Relation.Unary.All.html @@ -9,17 +9,15 @@ module Data.Product.Relation.Unary.All where -open import Level -open import Data.Product -open import Function.Base -open import Relation.Unary +open import Level using (Level; _⊔_) +open import Data.Product.Base using (_×_; _,_) -private - variable - a b p q : Level - A : Set a - B : Set b +private + variable + a b p q : Level + A : Set a + B : Set b -All : (A → Set p) → (B → Set q) → (A × B → Set (p ⊔ q)) -All P Q (a , b) = P a × Q b +All : (A → Set p) → (B → Set q) → (A × B → Set (p ⊔ q)) +All P Q (a , b) = P a × Q b \ No newline at end of file diff --git a/Data.Product.html b/Data.Product.html index 754f32ad..6737a45b 100644 --- a/Data.Product.html +++ b/Data.Product.html @@ -24,36 +24,22 @@ open import Data.Product.Base public ------------------------------------------------------------------------ --- Existential quantifiers +-- Negation of existential quantifier -∃ : ∀ {A : Set a} → (A → Set b) → Set (a ⊔ b) -∃ = Σ _ +∄ : ∀ {A : Set a} → (A → Set b) → Set (a ⊔ b) +∄ P = ¬ ∃ P -∄ : ∀ {A : Set a} → (A → Set b) → Set (a ⊔ b) -∄ P = ¬ ∃ P +-- Unique existence (parametrised by an underlying equality). -∃₂ : ∀ {A : Set a} {B : A → Set b} - (C : (x : A) → B x → Set c) → Set (a ⊔ b ⊔ c) -∃₂ C = ∃ λ a → ∃ λ b → C a b +∃! : {A : Set a} → (A → A → Set ℓ) → (A → Set b) → Set (a ⊔ b ⊔ ℓ) +∃! _≈_ B = ∃ λ x → B x × (∀ {y} → B y → x ≈ y) --- Unique existence (parametrised by an underlying equality). +-- Syntax -∃! : {A : Set a} → (A → A → Set ℓ) → (A → Set b) → Set (a ⊔ b ⊔ ℓ) -∃! _≈_ B = ∃ λ x → B x × (∀ {y} → B y → x ≈ y) +infix 2 ∄-syntax --- Syntax +∄-syntax : ∀ {A : Set a} → (A → Set b) → Set (a ⊔ b) +∄-syntax = ∄ -infix 2 ∃-syntax - -∃-syntax : ∀ {A : Set a} → (A → Set b) → Set (a ⊔ b) -∃-syntax = ∃ - -syntax ∃-syntax (λ x → B) = ∃[ x ] B - -infix 2 ∄-syntax - -∄-syntax : ∀ {A : Set a} → (A → Set b) → Set (a ⊔ b) -∄-syntax = ∄ - -syntax ∄-syntax (λ x → B) = ∄[ x ] B +syntax ∄-syntax (λ x → B) = ∄[ x ] B \ No newline at end of file diff --git a/Data.Rational.Base.html b/Data.Rational.Base.html index 098182ff..1476a0f7 100644 --- a/Data.Rational.Base.html +++ b/Data.Rational.Base.html @@ -10,355 +10,366 @@ module Data.Rational.Base where open import Algebra.Bundles.Raw -open import Data.Bool.Base using (Bool; true; false; if_then_else_) -open import Data.Integer.Base as ℤ using (ℤ; +_; +0; +[1+_]; -[1+_]) -open import Data.Nat.GCD -open import Data.Nat.Coprimality as C - using (Coprime; Bézout-coprime; coprime-/gcd; coprime?; ¬0-coprimeTo-2+) -open import Data.Nat.Base as ℕ using (ℕ; zero; suc) hiding (module ℕ) -open import Data.Rational.Unnormalised.Base as ℚᵘ using (ℚᵘ; mkℚᵘ) -open import Data.Sum.Base using (inj₂) -open import Function.Base using (id) -open import Level using (0ℓ) -open import Relation.Nullary using (¬_; recompute) -open import Relation.Nullary.Negation using (contradiction) -open import Relation.Unary using (Pred) -open import Relation.Binary.Core using (Rel) -open import Relation.Binary.PropositionalEquality.Core - using (_≡_; _≢_; refl) +open import Data.Bool.Base using (Bool; true; false; if_then_else_) +open import Data.Integer.Base as ℤ + using (ℤ; +_; +0; +[1+_]; -[1+_]) + hiding (module ℤ) +open import Data.Nat.GCD +open import Data.Nat.Coprimality as C + using (Coprime; Bézout-coprime; coprime-/gcd; coprime?; ¬0-coprimeTo-2+) +open import Data.Nat.Base as ℕ using (ℕ; zero; suc; 2+) hiding (module ℕ) +open import Data.Rational.Unnormalised.Base as ℚᵘ using (ℚᵘ; mkℚᵘ) +open import Data.Sum.Base using (inj₂) +open import Function.Base using (id) +open import Level using (0ℓ) +open import Relation.Nullary.Decidable.Core using (recompute) +open import Relation.Nullary.Negation.Core using (¬_; contradiction) +open import Relation.Unary using (Pred) +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.PropositionalEquality.Core + using (_≡_; _≢_; refl) ------------------------------------------------------------------------- --- Rational numbers in reduced form. Note that there is exactly one --- way to represent every rational number. +------------------------------------------------------------------------ +-- Rational numbers in reduced form. Note that there is exactly one +-- way to represent every rational number. -record ℚ : Set where - -- We add "no-eta-equality; pattern" to the record to stop Agda - -- automatically unfolding rationals when arithmetic operations are - -- applied to them (see definition of operators below and Issue #1753 - -- for details). - no-eta-equality; pattern +record ℚ : Set where + -- We add "no-eta-equality; pattern" to the record to stop Agda + -- automatically unfolding rationals when arithmetic operations are + -- applied to them (see definition of operators below and Issue #1753 + -- for details). + no-eta-equality; pattern - constructor mkℚ - field - numerator : ℤ - denominator-1 : ℕ - .isCoprime : Coprime ℤ.∣ numerator ∣ (suc denominator-1) + constructor mkℚ + field + numerator : ℤ + denominator-1 : ℕ + .isCoprime : Coprime ℤ.∣ numerator ∣ (suc denominator-1) - denominatorℕ : ℕ - denominatorℕ = suc denominator-1 + denominatorℕ : ℕ + denominatorℕ = suc denominator-1 - denominator : ℤ - denominator = + denominatorℕ + denominator : ℤ + denominator = + denominatorℕ -open ℚ public using () - renaming - ( numerator to ↥_ - ; denominator to ↧_ - ; denominatorℕ to ↧ₙ_ - ) +open ℚ public using () + renaming + ( numerator to ↥_ + ; denominator to ↧_ + ; denominatorℕ to ↧ₙ_ + ) -mkℚ+ : ∀ n d → .{{_ : ℕ.NonZero d}} → .(Coprime n d) → ℚ -mkℚ+ n (suc d) coprime = mkℚ (+ n) d coprime +mkℚ+ : ∀ n d → .{{_ : ℕ.NonZero d}} → .(Coprime n d) → ℚ +mkℚ+ n (suc d) coprime = mkℚ (+ n) d coprime ------------------------------------------------------------------------- --- Equality of rational numbers (coincides with _≡_) +------------------------------------------------------------------------ +-- Equality of rational numbers (coincides with _≡_) -infix 4 _≃_ +infix 4 _≃_ -_≃_ : Rel ℚ 0ℓ -p ≃ q = (↥ p ℤ.* ↧ q) ≡ (↥ q ℤ.* ↧ p) +data _≃_ : Rel ℚ 0ℓ where + *≡* : ∀ {p q} → (↥ p ℤ.* ↧ q) ≡ (↥ q ℤ.* ↧ p) → p ≃ q ------------------------------------------------------------------------- --- Ordering of rationals +_≄_ : Rel ℚ 0ℓ +p ≄ q = ¬ (p ≃ q) -infix 4 _≤_ _<_ _≥_ _>_ _≰_ _≱_ _≮_ _≯_ +------------------------------------------------------------------------ +-- Ordering of rationals -data _≤_ : Rel ℚ 0ℓ where - *≤* : ∀ {p q} → (↥ p ℤ.* ↧ q) ℤ.≤ (↥ q ℤ.* ↧ p) → p ≤ q +infix 4 _≤_ _<_ _≥_ _>_ _≰_ _≱_ _≮_ _≯_ -data _<_ : Rel ℚ 0ℓ where - *<* : ∀ {p q} → (↥ p ℤ.* ↧ q) ℤ.< (↥ q ℤ.* ↧ p) → p < q +data _≤_ : Rel ℚ 0ℓ where + *≤* : ∀ {p q} → (↥ p ℤ.* ↧ q) ℤ.≤ (↥ q ℤ.* ↧ p) → p ≤ q -_≥_ : Rel ℚ 0ℓ -x ≥ y = y ≤ x +data _<_ : Rel ℚ 0ℓ where + *<* : ∀ {p q} → (↥ p ℤ.* ↧ q) ℤ.< (↥ q ℤ.* ↧ p) → p < q -_>_ : Rel ℚ 0ℓ -x > y = y < x +_≥_ : Rel ℚ 0ℓ +x ≥ y = y ≤ x -_≰_ : Rel ℚ 0ℓ -x ≰ y = ¬ (x ≤ y) +_>_ : Rel ℚ 0ℓ +x > y = y < x -_≱_ : Rel ℚ 0ℓ -x ≱ y = ¬ (x ≥ y) +_≰_ : Rel ℚ 0ℓ +x ≰ y = ¬ (x ≤ y) -_≮_ : Rel ℚ 0ℓ -x ≮ y = ¬ (x < y) +_≱_ : Rel ℚ 0ℓ +x ≱ y = ¬ (x ≥ y) -_≯_ : Rel ℚ 0ℓ -x ≯ y = ¬ (x > y) +_≮_ : Rel ℚ 0ℓ +x ≮ y = ¬ (x < y) ------------------------------------------------------------------------- --- Boolean ordering +_≯_ : Rel ℚ 0ℓ +x ≯ y = ¬ (x > y) -infix 4 _≤ᵇ_ +------------------------------------------------------------------------ +-- Boolean ordering -_≤ᵇ_ : ℚ → ℚ → Bool -p ≤ᵇ q = (↥ p ℤ.* ↧ q) ℤ.≤ᵇ (↥ q ℤ.* ↧ p) +infix 4 _≤ᵇ_ ------------------------------------------------------------------------- --- Negation +_≤ᵇ_ : ℚ → ℚ → Bool +p ≤ᵇ q = (↥ p ℤ.* ↧ q) ℤ.≤ᵇ (↥ q ℤ.* ↧ p) --_ : ℚ → ℚ -- mkℚ -[1+ n ] d prf = mkℚ +[1+ n ] d prf -- mkℚ +0 d prf = mkℚ +0 d prf -- mkℚ +[1+ n ] d prf = mkℚ -[1+ n ] d prf +------------------------------------------------------------------------ +-- Negation ------------------------------------------------------------------------- --- Constructing rationals +-_ : ℚ → ℚ +- mkℚ -[1+ n ] d prf = mkℚ +[1+ n ] d prf +- mkℚ +0 d prf = mkℚ +0 d prf +- mkℚ +[1+ n ] d prf = mkℚ -[1+ n ] d prf --- A constructor for ℚ that takes two natural numbers, say 6 and 21, --- and returns them in a normalized form, e.g. say 2 and 7 +------------------------------------------------------------------------ +-- Constructing rationals -normalize : ∀ (m n : ℕ) .{{_ : ℕ.NonZero n}} → ℚ -normalize m n = mkℚ+ (m ℕ./ gcd m n) (n ℕ./ gcd m n) (coprime-/gcd m n) - where - instance - g≢0 = ℕ.≢-nonZero (gcd[m,n]≢0 m n (inj₂ (ℕ.≢-nonZero⁻¹ n))) - n/g≢0 = ℕ.≢-nonZero (n/gcd[m,n]≢0 m n {{gcd≢0 = g≢0}}) +-- A constructor for ℚ that takes two natural numbers, say 6 and 21, +-- and returns them in a normalized form, e.g. say 2 and 7 --- A constructor for ℚ that (unlike mkℚ) automatically normalises it's --- arguments. See the constants section below for how to use this operator. +normalize : ∀ (m n : ℕ) .{{_ : ℕ.NonZero n}} → ℚ +normalize m n = mkℚ+ (m ℕ./ gcd m n) (n ℕ./ gcd m n) (coprime-/gcd m n) + where + instance + g≢0 = ℕ.≢-nonZero (gcd[m,n]≢0 m n (inj₂ (ℕ.≢-nonZero⁻¹ n))) + n/g≢0 = ℕ.≢-nonZero (n/gcd[m,n]≢0 m n {{gcd≢0 = g≢0}}) -infixl 7 _/_ +-- A constructor for ℚ that (unlike mkℚ) automatically normalises it's +-- arguments. See the constants section below for how to use this operator. -_/_ : (n : ℤ) (d : ℕ) → .{{_ : ℕ.NonZero d}} → ℚ -(+ n / d) = normalize n d -(-[1+ n ] / d) = - normalize (suc n) d +infixl 7 _/_ ------------------------------------------------------------------------- --- Conversion to and from unnormalized rationals +_/_ : (n : ℤ) (d : ℕ) → .{{_ : ℕ.NonZero d}} → ℚ +(+ n / d) = normalize n d +(-[1+ n ] / d) = - normalize (suc n) d -toℚᵘ : ℚ → ℚᵘ -toℚᵘ (mkℚ n d-1 _) = mkℚᵘ n d-1 +------------------------------------------------------------------------ +-- Conversion to and from unnormalized rationals -fromℚᵘ : ℚᵘ → ℚ -fromℚᵘ (mkℚᵘ n d-1) = n / suc d-1 +toℚᵘ : ℚ → ℚᵘ +toℚᵘ (mkℚ n d-1 _) = mkℚᵘ n d-1 ------------------------------------------------------------------------------- --- Some constants +fromℚᵘ : ℚᵘ → ℚ +fromℚᵘ (mkℚᵘ n d-1) = n / suc d-1 -0ℚ : ℚ -0ℚ = + 0 / 1 +------------------------------------------------------------------------ +-- Some constants -1ℚ : ℚ -1ℚ = + 1 / 1 +0ℚ : ℚ +0ℚ = + 0 / 1 -½ : ℚ -½ = + 1 / 2 +1ℚ : ℚ +1ℚ = + 1 / 1 --½ : ℚ --½ = - ½ +½ : ℚ +½ = + 1 / 2 ------------------------------------------------------------------------- --- Simple predicates +-½ : ℚ +-½ = - ½ -NonZero : Pred ℚ 0ℓ -NonZero p = ℚᵘ.NonZero (toℚᵘ p) +------------------------------------------------------------------------ +-- Simple predicates -Positive : Pred ℚ 0ℓ -Positive p = ℚᵘ.Positive (toℚᵘ p) +NonZero : Pred ℚ 0ℓ +NonZero p = ℚᵘ.NonZero (toℚᵘ p) -Negative : Pred ℚ 0ℓ -Negative p = ℚᵘ.Negative (toℚᵘ p) +Positive : Pred ℚ 0ℓ +Positive p = ℚᵘ.Positive (toℚᵘ p) -NonPositive : Pred ℚ 0ℓ -NonPositive p = ℚᵘ.NonPositive (toℚᵘ p) +Negative : Pred ℚ 0ℓ +Negative p = ℚᵘ.Negative (toℚᵘ p) -NonNegative : Pred ℚ 0ℓ -NonNegative p = ℚᵘ.NonNegative (toℚᵘ p) +NonPositive : Pred ℚ 0ℓ +NonPositive p = ℚᵘ.NonPositive (toℚᵘ p) --- Constructors +NonNegative : Pred ℚ 0ℓ +NonNegative p = ℚᵘ.NonNegative (toℚᵘ p) -≢-nonZero : ∀ {p} → p ≢ 0ℚ → NonZero p -≢-nonZero {mkℚ -[1+ _ ] _ _} _ = _ -≢-nonZero {mkℚ +[1+ _ ] _ _} _ = _ -≢-nonZero {mkℚ +0 zero _} p≢0 = contradiction refl p≢0 -≢-nonZero {mkℚ +0 (suc d) c} p≢0 = contradiction (λ {i} → C.recompute c {i}) ¬0-coprimeTo-2+ +-- Instances ->-nonZero : ∀ {p} → p > 0ℚ → NonZero p ->-nonZero {p@(mkℚ _ _ _)} (*<* p<q) = ℚᵘ.>-nonZero {toℚᵘ p} (ℚᵘ.*<* p<q) +open ℤ public + using (nonZero; pos; nonNeg; nonPos0; nonPos; neg) -<-nonZero : ∀ {p} → p < 0ℚ → NonZero p -<-nonZero {p@(mkℚ _ _ _)} (*<* p<q) = ℚᵘ.<-nonZero {toℚᵘ p} (ℚᵘ.*<* p<q) +-- Constructors -positive : ∀ {p} → p > 0ℚ → Positive p -positive {p@(mkℚ _ _ _)} (*<* p<q) = ℚᵘ.positive {toℚᵘ p} (ℚᵘ.*<* p<q) +≢-nonZero : ∀ {p} → p ≢ 0ℚ → NonZero p +≢-nonZero {mkℚ -[1+ _ ] _ _} _ = _ +≢-nonZero {mkℚ +[1+ _ ] _ _} _ = _ +≢-nonZero {mkℚ +0 zero _} p≢0 = contradiction refl p≢0 +≢-nonZero {mkℚ +0 d@(suc m) c} p≢0 = + contradiction (λ {d} → C.recompute c {d}) (¬0-coprimeTo-2+ {{ℕ.nonTrivial {m}}}) -negative : ∀ {p} → p < 0ℚ → Negative p -negative {p@(mkℚ _ _ _)} (*<* p<q) = ℚᵘ.negative {toℚᵘ p} (ℚᵘ.*<* p<q) +>-nonZero : ∀ {p} → p > 0ℚ → NonZero p +>-nonZero {p@(mkℚ _ _ _)} (*<* p<q) = ℚᵘ.>-nonZero {toℚᵘ p} (ℚᵘ.*<* p<q) -nonPositive : ∀ {p} → p ≤ 0ℚ → NonPositive p -nonPositive {p@(mkℚ _ _ _)} (*≤* p≤q) = ℚᵘ.nonPositive {toℚᵘ p} (ℚᵘ.*≤* p≤q) +<-nonZero : ∀ {p} → p < 0ℚ → NonZero p +<-nonZero {p@(mkℚ _ _ _)} (*<* p<q) = ℚᵘ.<-nonZero {toℚᵘ p} (ℚᵘ.*<* p<q) -nonNegative : ∀ {p} → p ≥ 0ℚ → NonNegative p -nonNegative {p@(mkℚ _ _ _)} (*≤* p≤q) = ℚᵘ.nonNegative {toℚᵘ p} (ℚᵘ.*≤* p≤q) +positive : ∀ {p} → p > 0ℚ → Positive p +positive {p@(mkℚ _ _ _)} (*<* p<q) = ℚᵘ.positive {toℚᵘ p} (ℚᵘ.*<* p<q) ------------------------------------------------------------------------------- --- Operations on rationals +negative : ∀ {p} → p < 0ℚ → Negative p +negative {p@(mkℚ _ _ _)} (*<* p<q) = ℚᵘ.negative {toℚᵘ p} (ℚᵘ.*<* p<q) --- For explanation of the `@record{}` annotations see notes in the equivalent --- place in `Data.Rational.Unnormalised.Base`. +nonPositive : ∀ {p} → p ≤ 0ℚ → NonPositive p +nonPositive {p@(mkℚ _ _ _)} (*≤* p≤q) = ℚᵘ.nonPositive {toℚᵘ p} (ℚᵘ.*≤* p≤q) -infix 8 -_ 1/_ -infixl 7 _*_ _÷_ _⊓_ -infixl 6 _-_ _+_ _⊔_ +nonNegative : ∀ {p} → p ≥ 0ℚ → NonNegative p +nonNegative {p@(mkℚ _ _ _)} (*≤* p≤q) = ℚᵘ.nonNegative {toℚᵘ p} (ℚᵘ.*≤* p≤q) --- addition -_+_ : ℚ → ℚ → ℚ -p@record{} + q@record{} = (↥ p ℤ.* ↧ q ℤ.+ ↥ q ℤ.* ↧ p) / (↧ₙ p ℕ.* ↧ₙ q) +------------------------------------------------------------------------ +-- Operations on rationals --- multiplication -_*_ : ℚ → ℚ → ℚ -p@record{} * q@record{} = (↥ p ℤ.* ↥ q) / (↧ₙ p ℕ.* ↧ₙ q) +-- For explanation of the `@record{}` annotations see notes in the +-- equivalent place in `Data.Rational.Unnormalised.Base`. --- subtraction -_-_ : ℚ → ℚ → ℚ -p - q = p + (- q) +infix 8 -_ 1/_ +infixl 7 _*_ _÷_ _⊓_ +infixl 6 _-_ _+_ _⊔_ --- reciprocal: requires a proof that the numerator is not zero -1/_ : (p : ℚ) → .{{_ : NonZero p}} → ℚ -1/ mkℚ +[1+ n ] d prf = mkℚ +[1+ d ] n (C.sym prf) -1/ mkℚ -[1+ n ] d prf = mkℚ -[1+ d ] n (C.sym prf) +-- addition +_+_ : ℚ → ℚ → ℚ +p@record{} + q@record{} = (↥ p ℤ.* ↧ q ℤ.+ ↥ q ℤ.* ↧ p) / (↧ₙ p ℕ.* ↧ₙ q) --- division: requires a proof that the denominator is not zero -_÷_ : (p q : ℚ) → .{{_ : NonZero q}} → ℚ -p ÷ q = p * (1/ q) +-- multiplication +_*_ : ℚ → ℚ → ℚ +p@record{} * q@record{} = (↥ p ℤ.* ↥ q) / (↧ₙ p ℕ.* ↧ₙ q) --- max -_⊔_ : (p q : ℚ) → ℚ -p@record{} ⊔ q@record{} = if p ≤ᵇ q then q else p +-- subtraction +_-_ : ℚ → ℚ → ℚ +p - q = p + (- q) --- min -_⊓_ : (p q : ℚ) → ℚ -p@record{} ⊓ q@record{} = if p ≤ᵇ q then p else q +-- reciprocal: requires a proof that the numerator is not zero +1/_ : (p : ℚ) → .{{_ : NonZero p}} → ℚ +1/ mkℚ +[1+ n ] d prf = mkℚ +[1+ d ] n (C.sym prf) +1/ mkℚ -[1+ n ] d prf = mkℚ -[1+ d ] n (C.sym prf) --- absolute value -∣_∣ : ℚ → ℚ -∣ mkℚ n d c ∣ = mkℚ (+ ℤ.∣ n ∣) d c +-- division: requires a proof that the denominator is not zero +_÷_ : (p q : ℚ) → .{{_ : NonZero q}} → ℚ +p ÷ q = p * (1/ q) ------------------------------------------------------------------------- --- Rounding functions +-- max +_⊔_ : (p q : ℚ) → ℚ +p@record{} ⊔ q@record{} = if p ≤ᵇ q then q else p --- Floor (round towards -∞) -floor : ℚ → ℤ -floor p@record{} = ↥ p ℤ./ ↧ p +-- min +_⊓_ : (p q : ℚ) → ℚ +p@record{} ⊓ q@record{} = if p ≤ᵇ q then p else q --- Ceiling (round towards +∞) -ceiling : ℚ → ℤ -ceiling p@record{} = ℤ.- floor (- p) +-- absolute value +∣_∣ : ℚ → ℚ +∣ mkℚ n d c ∣ = mkℚ (+ ℤ.∣ n ∣) d c --- Truncate (round towards 0) -truncate : ℚ → ℤ -truncate p with p ≤ᵇ 0ℚ -... | true = ceiling p -... | false = floor p +------------------------------------------------------------------------ +-- Rounding functions --- Round (to nearest integer) -round : ℚ → ℤ -round p with p ≤ᵇ 0ℚ -... | true = ceiling (p - ½) -... | false = floor (p + ½) - --- Fractional part (remainder after floor) -fracPart : ℚ → ℚ -fracPart p@record{} = ∣ p - truncate p / 1 ∣ - --- Extra notations ⌊ ⌋ floor, ⌈ ⌉ ceiling, [ ] truncate -syntax floor p = ⌊ p ⌋ -syntax ceiling p = ⌈ p ⌉ -syntax truncate p = [ p ] - ------------------------------------------------------------------------- --- Raw bundles - -+-rawMagma : RawMagma 0ℓ 0ℓ -+-rawMagma = record - { _≈_ = _≡_ - ; _∙_ = _+_ - } - -+-0-rawMonoid : RawMonoid 0ℓ 0ℓ -+-0-rawMonoid = record - { _≈_ = _≡_ - ; _∙_ = _+_ - ; ε = 0ℚ - } - -+-0-rawGroup : RawGroup 0ℓ 0ℓ -+-0-rawGroup = record - { _≈_ = _≡_ - ; _∙_ = _+_ - ; ε = 0ℚ - ; _⁻¹ = -_ +-- Floor (round towards -∞) +floor : ℚ → ℤ +floor p@record{} = ↥ p ℤ./ ↧ p + +-- Ceiling (round towards +∞) +ceiling : ℚ → ℤ +ceiling p@record{} = ℤ.- floor (- p) + +-- Truncate (round towards 0) +truncate : ℚ → ℤ +truncate p with p ≤ᵇ 0ℚ +... | true = ceiling p +... | false = floor p + +-- Round (to nearest integer) +round : ℚ → ℤ +round p with p ≤ᵇ 0ℚ +... | true = ceiling (p - ½) +... | false = floor (p + ½) + +-- Fractional part (remainder after floor) +fracPart : ℚ → ℚ +fracPart p@record{} = ∣ p - truncate p / 1 ∣ + +-- Extra notations ⌊ ⌋ floor, ⌈ ⌉ ceiling, [ ] truncate +syntax floor p = ⌊ p ⌋ +syntax ceiling p = ⌈ p ⌉ +syntax truncate p = [ p ] + +------------------------------------------------------------------------ +-- Raw bundles + ++-rawMagma : RawMagma 0ℓ 0ℓ ++-rawMagma = record + { _≈_ = _≡_ + ; _∙_ = _+_ } -+-*-rawNearSemiring : RawNearSemiring 0ℓ 0ℓ -+-*-rawNearSemiring = record - { _≈_ = _≡_ - ; _+_ = _+_ - ; _*_ = _*_ - ; 0# = 0ℚ - } - -+-*-rawSemiring : RawSemiring 0ℓ 0ℓ -+-*-rawSemiring = record - { _≈_ = _≡_ - ; _+_ = _+_ - ; _*_ = _*_ - ; 0# = 0ℚ - ; 1# = 1ℚ - } - -+-*-rawRing : RawRing 0ℓ 0ℓ -+-*-rawRing = record - { _≈_ = _≡_ - ; _+_ = _+_ - ; _*_ = _*_ - ; -_ = -_ - ; 0# = 0ℚ - ; 1# = 1ℚ - } - -*-rawMagma : RawMagma 0ℓ 0ℓ -*-rawMagma = record - { _≈_ = _≡_ - ; _∙_ = _*_ - } - -*-1-rawMonoid : RawMonoid 0ℓ 0ℓ -*-1-rawMonoid = record - { _≈_ = _≡_ - ; _∙_ = _*_ - ; ε = 1ℚ - } - - ------------------------------------------------------------------------- --- DEPRECATED NAMES ------------------------------------------------------------------------- --- Please use the new names as continuing support for the old names is --- not guaranteed. - --- Version 2.0 - -+-rawMonoid = +-0-rawMonoid -{-# WARNING_ON_USAGE +-rawMonoid -"Warning: +-rawMonoid was deprecated in v2.0 ++-0-rawMonoid : RawMonoid 0ℓ 0ℓ ++-0-rawMonoid = record + { _≈_ = _≡_ + ; _∙_ = _+_ + ; ε = 0ℚ + } + ++-0-rawGroup : RawGroup 0ℓ 0ℓ ++-0-rawGroup = record + { _≈_ = _≡_ + ; _∙_ = _+_ + ; ε = 0ℚ + ; _⁻¹ = -_ + } + ++-*-rawNearSemiring : RawNearSemiring 0ℓ 0ℓ ++-*-rawNearSemiring = record + { _≈_ = _≡_ + ; _+_ = _+_ + ; _*_ = _*_ + ; 0# = 0ℚ + } + ++-*-rawSemiring : RawSemiring 0ℓ 0ℓ ++-*-rawSemiring = record + { _≈_ = _≡_ + ; _+_ = _+_ + ; _*_ = _*_ + ; 0# = 0ℚ + ; 1# = 1ℚ + } + ++-*-rawRing : RawRing 0ℓ 0ℓ ++-*-rawRing = record + { _≈_ = _≡_ + ; _+_ = _+_ + ; _*_ = _*_ + ; -_ = -_ + ; 0# = 0ℚ + ; 1# = 1ℚ + } + +*-rawMagma : RawMagma 0ℓ 0ℓ +*-rawMagma = record + { _≈_ = _≡_ + ; _∙_ = _*_ + } + +*-1-rawMonoid : RawMonoid 0ℓ 0ℓ +*-1-rawMonoid = record + { _≈_ = _≡_ + ; _∙_ = _*_ + ; ε = 1ℚ + } + + +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 2.0 + ++-rawMonoid = +-0-rawMonoid +{-# WARNING_ON_USAGE +-rawMonoid +"Warning: +-rawMonoid was deprecated in v2.0 Please use +-0-rawMonoid instead." -#-} -*-rawMonoid = *-1-rawMonoid -{-# WARNING_ON_USAGE *-rawMonoid -"Warning: *-rawMonoid was deprecated in v2.0 +#-} +*-rawMonoid = *-1-rawMonoid +{-# WARNING_ON_USAGE *-rawMonoid +"Warning: *-rawMonoid was deprecated in v2.0 Please use *-1-rawMonoid instead." -#-} +#-} \ No newline at end of file diff --git a/Data.Rational.Properties.html b/Data.Rational.Properties.html index 595a64e0..56900132 100644 --- a/Data.Rational.Properties.html +++ b/Data.Rational.Properties.html @@ -22,1681 +22,1714 @@ import Algebra.Morphism.RingMonomorphism as RingMonomorphisms import Algebra.Lattice.Morphism.LatticeMonomorphism as LatticeMonomorphisms import Algebra.Properties.CommutativeSemigroup as CommSemigroupProperties -open import Data.Bool.Base using (T; true; false) -open import Data.Integer.Base as ℤ using (ℤ; +_; -[1+_]; +[1+_]; +0; 0ℤ; 1ℤ; _◃_) -open import Data.Integer.Coprimality using (coprime-divisor) +open import Data.Bool.Base using (T; true; false) +open import Data.Integer.Base as ℤ using (ℤ; +_; -[1+_]; +[1+_]; +0; 0ℤ; 1ℤ; _◃_) +open import Data.Integer.Coprimality using (coprime-divisor) import Data.Integer.Properties as ℤ -open import Data.Integer.GCD using (gcd; gcd[i,j]≡0⇒i≡0; gcd[i,j]≡0⇒j≡0) +open import Data.Integer.GCD using (gcd; gcd[i,j]≡0⇒i≡0; gcd[i,j]≡0⇒j≡0) open import Data.Integer.Solver renaming (module +-*-Solver to ℤ-solver) open import Data.Nat.Base as ℕ using (ℕ; zero; suc) import Data.Nat.Properties as ℕ -open import Data.Nat.Coprimality as C using (Coprime; coprime?) +open import Data.Nat.Coprimality as C using (Coprime; coprime?) open import Data.Nat.Divisibility import Data.Nat.GCD as ℕ import Data.Nat.DivMod as ℕ -open import Data.Product using (proj₁; proj₂; _×_; _,_; uncurry) -open import Data.Rational.Base -open import Data.Rational.Unnormalised.Base as ℚᵘ - using (ℚᵘ; mkℚᵘ; *≡*; *≤*; *<*) - renaming - ( ↥_ to ↥ᵘ_; ↧_ to ↧ᵘ_; ↧ₙ_ to ↧ₙᵘ_ - ; _≃_ to _≃ᵘ_; _≤_ to _≤ᵘ_; _<_ to _<ᵘ_ - ; _+_ to _+ᵘ_ - ) -import Data.Rational.Unnormalised.Properties as ℚᵘ -open import Data.Sum.Base as Sum -open import Data.Unit using (tt) -import Data.Sign as S -open import Function.Base using (_∘_; _∘′_; _∘₂_; _$_; flip) -open import Function.Definitions using (Injective) -open import Level using (0ℓ) -open import Relation.Binary -open import Relation.Binary.PropositionalEquality -open import Relation.Binary.Morphism.Structures -import Relation.Binary.Morphism.OrderMonomorphism as OrderMonomorphisms -open import Relation.Nullary.Decidable as Dec - using (True; False; fromWitness; fromWitnessFalse; toWitnessFalse; yes; no; recompute; map′; _×-dec_) -open import Relation.Nullary.Negation using (¬_; contradiction; contraposition) - -open import Algebra.Definitions {A = ℚ} _≡_ -open import Algebra.Structures {A = ℚ} _≡_ - -private - variable - p q r : ℚ - ------------------------------------------------------------------------- --- Propositional equality ------------------------------------------------------------------------- - -mkℚ-cong : ∀ {n₁ n₂ d₁ d₂} - .{c₁ : Coprime ℤ.∣ n₁ ∣ (suc d₁)} - .{c₂ : Coprime ℤ.∣ n₂ ∣ (suc d₂)} → - n₁ ≡ n₂ → d₁ ≡ d₂ → mkℚ n₁ d₁ c₁ ≡ mkℚ n₂ d₂ c₂ -mkℚ-cong refl refl = refl - -mkℚ-injective : ∀ {n₁ n₂ d₁ d₂} - .{c₁ : Coprime ℤ.∣ n₁ ∣ (suc d₁)} - .{c₂ : Coprime ℤ.∣ n₂ ∣ (suc d₂)} → - mkℚ n₁ d₁ c₁ ≡ mkℚ n₂ d₂ c₂ → n₁ ≡ n₂ × d₁ ≡ d₂ -mkℚ-injective refl = refl , refl - -infix 4 _≟_ - -_≟_ : DecidableEquality ℚ -mkℚ n₁ d₁ _ ≟ mkℚ n₂ d₂ _ = map′ - (uncurry mkℚ-cong) - mkℚ-injective - (n₁ ℤ.≟ n₂ ×-dec d₁ ℕ.≟ d₂) - -≡-setoid : Setoid 0ℓ 0ℓ -≡-setoid = setoid ℚ - -≡-decSetoid : DecSetoid 0ℓ 0ℓ -≡-decSetoid = decSetoid _≟_ - ------------------------------------------------------------------------- --- mkℚ+ ------------------------------------------------------------------------- - -mkℚ+-cong : ∀ {n₁ n₂ d₁ d₂} .{{_ : ℕ.NonZero d₁}} .{{_ : ℕ.NonZero d₂}} - .{c₁ : Coprime n₁ d₁} - .{c₂ : Coprime n₂ d₂} → - n₁ ≡ n₂ → d₁ ≡ d₂ → - mkℚ+ n₁ d₁ c₁ ≡ mkℚ+ n₂ d₂ c₂ -mkℚ+-cong refl refl = refl - -mkℚ+-injective : ∀ {n₁ n₂ d₁ d₂} .{{_ : ℕ.NonZero d₁}} .{{_ : ℕ.NonZero d₂}} - .{c₁ : Coprime n₁ d₁} - .{c₂ : Coprime n₂ d₂} → - mkℚ+ n₁ d₁ c₁ ≡ mkℚ+ n₂ d₂ c₂ → - n₁ ≡ n₂ × d₁ ≡ d₂ -mkℚ+-injective {d₁ = suc _} {suc _} refl = refl , refl - -↥-mkℚ+ : ∀ n d .{{_ : ℕ.NonZero d}} .{c : Coprime n d} → ↥ (mkℚ+ n d c) ≡ + n -↥-mkℚ+ n (suc d) = refl - -↧-mkℚ+ : ∀ n d .{{_ : ℕ.NonZero d}} .{c : Coprime n d} → ↧ (mkℚ+ n d c) ≡ + d -↧-mkℚ+ n (suc d) = refl - -mkℚ+-nonNeg : ∀ n d .{{_ : ℕ.NonZero d}} .{c : Coprime n d} → - NonNegative (mkℚ+ n d c) -mkℚ+-nonNeg n (suc d) = _ - -mkℚ+-pos : ∀ n d .{{_ : ℕ.NonZero n}} .{{_ : ℕ.NonZero d}} - .{c : Coprime n d} → Positive (mkℚ+ n d c) -mkℚ+-pos (suc n) (suc d) = _ - ------------------------------------------------------------------------- --- Numerator and denominator equality ------------------------------------------------------------------------- - -≡⇒≃ : _≡_ ⇒ _≃_ -≡⇒≃ refl = refl - -≃⇒≡ : _≃_ ⇒ _≡_ -≃⇒≡ {x = mkℚ n₁ d₁ c₁} {y = mkℚ n₂ d₂ c₂} eq = helper - where - open ≡-Reasoning - - 1+d₁∣1+d₂ : suc d₁ ∣ suc d₂ - 1+d₁∣1+d₂ = coprime-divisor (+ suc d₁) n₁ (+ suc d₂) - (C.sym (C.recompute c₁)) $ - divides ℤ.∣ n₂ ∣ $ begin - ℤ.∣ n₁ ℤ.* + suc d₂ ∣ ≡⟨ cong ℤ.∣_∣ eq ⟩ - ℤ.∣ n₂ ℤ.* + suc d₁ ∣ ≡⟨ ℤ.abs-* n₂ (+ suc d₁) ⟩ - ℤ.∣ n₂ ∣ ℕ.* suc d₁ ∎ - - 1+d₂∣1+d₁ : suc d₂ ∣ suc d₁ - 1+d₂∣1+d₁ = coprime-divisor (+ suc d₂) n₂ (+ suc d₁) - (C.sym (C.recompute c₂)) $ - divides ℤ.∣ n₁ ∣ (begin - ℤ.∣ n₂ ℤ.* + suc d₁ ∣ ≡⟨ cong ℤ.∣_∣ (sym eq) ⟩ - ℤ.∣ n₁ ℤ.* + suc d₂ ∣ ≡⟨ ℤ.abs-* n₁ (+ suc d₂) ⟩ - ℤ.∣ n₁ ∣ ℕ.* suc d₂ ∎) - - helper : mkℚ n₁ d₁ c₁ ≡ mkℚ n₂ d₂ c₂ - helper with ∣-antisym 1+d₁∣1+d₂ 1+d₂∣1+d₁ - ... | refl with ℤ.*-cancelʳ-≡ n₁ n₂ (+ suc d₁) eq - ... | refl = refl - ------------------------------------------------------------------------- --- Properties of ↥ ------------------------------------------------------------------------- - -↥p≡0⇒p≡0 : ∀ p → ↥ p ≡ 0ℤ → p ≡ 0ℚ -↥p≡0⇒p≡0 (mkℚ +0 d-1 0-coprime-d) ↥p≡0 = mkℚ-cong refl d-1≡0 - where d-1≡0 = ℕ.suc-injective (C.0-coprimeTo-m⇒m≡1 (C.recompute 0-coprime-d)) - -p≡0⇒↥p≡0 : ∀ p → p ≡ 0ℚ → ↥ p ≡ 0ℤ -p≡0⇒↥p≡0 p refl = refl - ------------------------------------------------------------------------- --- Basic properties of sign predicates ------------------------------------------------------------------------- - -nonNeg≢neg : ∀ p q → .{{NonNegative p}} → .{{Negative q}} → p ≢ q -nonNeg≢neg (mkℚ (+ _) _ _) (mkℚ -[1+ _ ] _ _) () - -pos⇒nonNeg : ∀ p → .{{Positive p}} → NonNegative p -pos⇒nonNeg p = ℚᵘ.pos⇒nonNeg (toℚᵘ p) - -neg⇒nonPos : ∀ p → .{{Negative p}} → NonPositive p -neg⇒nonPos p = ℚᵘ.neg⇒nonPos (toℚᵘ p) - -nonNeg∧nonZero⇒pos : ∀ p → .{{NonNegative p}} → .{{NonZero p}} → Positive p -nonNeg∧nonZero⇒pos (mkℚ +[1+ _ ] _ _) = _ - -pos⇒nonZero : ∀ p → .{{Positive p}} → NonZero p -pos⇒nonZero (mkℚ +[1+ _ ] _ _) = _ - -neg⇒nonZero : ∀ p → .{{Negative p}} → NonZero p -neg⇒nonZero (mkℚ -[1+ _ ] _ _) = _ - ------------------------------------------------------------------------- --- Properties of -_ ------------------------------------------------------------------------- - -↥-neg : ∀ p → ↥ (- p) ≡ ℤ.- (↥ p) -↥-neg (mkℚ -[1+ _ ] _ _) = refl -↥-neg (mkℚ +0 _ _) = refl -↥-neg (mkℚ +[1+ _ ] _ _) = refl - -↧-neg : ∀ p → ↧ (- p) ≡ ↧ p -↧-neg (mkℚ -[1+ _ ] _ _) = refl -↧-neg (mkℚ +0 _ _) = refl -↧-neg (mkℚ +[1+ _ ] _ _) = refl - -neg-injective : - p ≡ - q → p ≡ q -neg-injective {mkℚ +[1+ m ] _ _} {mkℚ +[1+ n ] _ _} refl = refl -neg-injective {mkℚ +0 _ _} {mkℚ +0 _ _} refl = refl -neg-injective {mkℚ -[1+ m ] _ _} {mkℚ -[1+ n ] _ _} refl = refl -neg-injective {mkℚ +[1+ m ] _ _} {mkℚ -[1+ n ] _ _} () -neg-injective {mkℚ +0 _ _} {mkℚ -[1+ n ] _ _} () -neg-injective {mkℚ -[1+ m ] _ _} {mkℚ +[1+ n ] _ _} () -neg-injective {mkℚ -[1+ m ] _ _} {mkℚ +0 _ _} () - -neg-pos : Positive p → Negative (- p) -neg-pos {mkℚ +[1+ _ ] _ _} _ = _ - ------------------------------------------------------------------------- --- Properties of normalize ------------------------------------------------------------------------- - -normalize-coprime : ∀ {n d-1} .(c : Coprime n (suc d-1)) → - normalize n (suc d-1) ≡ mkℚ (+ n) d-1 c -normalize-coprime {n} {d-1} c = begin - normalize n d ≡⟨⟩ - mkℚ+ ((n ℕ./ g) {{g≢0}}) ((d ℕ./ g) {{g≢0}}) _ ≡⟨ mkℚ+-cong {c₂ = c₂} (ℕ./-congʳ {{g≢0}} g≡1) (ℕ./-congʳ {{g≢0}} g≡1) ⟩ - mkℚ+ (n ℕ./ 1) (d ℕ./ 1) _ ≡⟨ mkℚ+-cong {c₂ = c} (ℕ.n/1≡n n) (ℕ.n/1≡n d) ⟩ - mkℚ+ n d _ ≡⟨⟩ - mkℚ (+ n) d-1 _ ∎ - where - open ≡-Reasoning; d = suc d-1; g = ℕ.gcd n d - c′ = C.recompute c - c₂ : Coprime (n ℕ./ 1) (d ℕ./ 1) - c₂ = subst₂ Coprime (sym (ℕ.n/1≡n n)) (sym (ℕ.n/1≡n d)) c′ - g≡1 = C.coprime⇒gcd≡1 c′ - instance - g≢0 = ℕ.≢-nonZero (ℕ.gcd[m,n]≢0 n d (inj₂ λ())) - n/g≢0 = ℕ.≢-nonZero (ℕ.n/gcd[m,n]≢0 n d {{_}} {{g≢0}}) - d/1≢0 = ℕ.≢-nonZero (subst (_≢ 0) (sym (ℕ.n/1≡n d)) λ()) - -↥-normalize : ∀ i n .{{_ : ℕ.NonZero n}} → ↥ (normalize i n) ℤ.* gcd (+ i) (+ n) ≡ + i -↥-normalize i n = begin - ↥ (normalize i n) ℤ.* + g ≡⟨ cong (ℤ._* + g) (↥-mkℚ+ _ (n ℕ./ g)) ⟩ - + i/g ℤ.* + g ≡⟨⟩ - S.+ ◃ i/g ℕ.* g ≡⟨ cong (S.+ ◃_) (ℕ.m/n*n≡m (ℕ.gcd[m,n]∣m i n)) ⟩ - S.+ ◃ i ≡⟨ ℤ.+◃n≡+n i ⟩ - + i ∎ - where - open ≡-Reasoning - g = ℕ.gcd i n - instance g≢0 = ℕ.≢-nonZero (ℕ.gcd[m,n]≢0 i n (inj₂ (ℕ.≢-nonZero⁻¹ n))) - instance n/g≢0 = ℕ.≢-nonZero (ℕ.n/gcd[m,n]≢0 i n {{gcd≢0 = g≢0}}) - i/g = (i ℕ./ g) {{g≢0}} - -↧-normalize : ∀ i n .{{_ : ℕ.NonZero n}} → ↧ (normalize i n) ℤ.* gcd (+ i) (+ n) ≡ + n -↧-normalize i n = begin - ↧ (normalize i n) ℤ.* + g ≡⟨ cong (ℤ._* + g) (↧-mkℚ+ _ (n ℕ./ g)) ⟩ - + (n ℕ./ g) ℤ.* + g ≡⟨⟩ - S.+ ◃ n ℕ./ g ℕ.* g ≡⟨ cong (S.+ ◃_) (ℕ.m/n*n≡m (ℕ.gcd[m,n]∣n i n)) ⟩ - S.+ ◃ n ≡⟨ ℤ.+◃n≡+n n ⟩ - + n ∎ - where - open ≡-Reasoning - g = ℕ.gcd i n - instance g≢0 = ℕ.≢-nonZero (ℕ.gcd[m,n]≢0 i n (inj₂ (ℕ.≢-nonZero⁻¹ n))) - instance n/g≢0 = ℕ.≢-nonZero (ℕ.n/gcd[m,n]≢0 i n {{gcd≢0 = g≢0}}) - -normalize-cong : ∀ {m₁ n₁ m₂ n₂} .{{_ : ℕ.NonZero n₁}} .{{_ : ℕ.NonZero n₂}} → - m₁ ≡ m₂ → n₁ ≡ n₂ → normalize m₁ n₁ ≡ normalize m₂ n₂ -normalize-cong {m} {n} refl refl = - mkℚ+-cong (ℕ./-congʳ {n = g} refl) (ℕ./-congʳ {n = g} refl) - where - g = ℕ.gcd m n - instance - g≢0 = ℕ.≢-nonZero (ℕ.gcd[m,n]≢0 m n (inj₂ (ℕ.≢-nonZero⁻¹ n))) - n/g≢0 = ℕ.≢-nonZero (ℕ.n/gcd[m,n]≢0 m n {{gcd≢0 = g≢0}}) - -normalize-nonNeg : ∀ m n .{{_ : ℕ.NonZero n}} → NonNegative (normalize m n) -normalize-nonNeg m n = mkℚ+-nonNeg (m ℕ./ g) (n ℕ./ g) - where - g = ℕ.gcd m n - instance - g≢0 = ℕ.≢-nonZero (ℕ.gcd[m,n]≢0 m n (inj₂ (ℕ.≢-nonZero⁻¹ n))) - n/g≢0 = ℕ.≢-nonZero (ℕ.n/gcd[m,n]≢0 m n {{gcd≢0 = g≢0}}) - -normalize-pos : ∀ m n .{{_ : ℕ.NonZero n}} .{{_ : ℕ.NonZero m}} → Positive (normalize m n) -normalize-pos m n = mkℚ+-pos (m ℕ./ ℕ.gcd m n) (n ℕ./ ℕ.gcd m n) - where - g = ℕ.gcd m n - instance - g≢0 = ℕ.≢-nonZero (ℕ.gcd[m,n]≢0 m n (inj₂ (ℕ.≢-nonZero⁻¹ n))) - n/g≢0 = ℕ.≢-nonZero (ℕ.n/gcd[m,n]≢0 m n {{gcd≢0 = g≢0}}) - m/g≢0 = ℕ.≢-nonZero (ℕ.m/gcd[m,n]≢0 m n {{gcd≢0 = g≢0}}) - -normalize-injective-≃ : ∀ m n c d {{_ : ℕ.NonZero c}} {{_ : ℕ.NonZero d}} → - normalize m c ≡ normalize n d → - m ℕ.* d ≡ n ℕ.* c -normalize-injective-≃ m n c d eq = ℕ./-cancelʳ-≡ - md∣gcd[m,c]gcd[n,d] - nc∣gcd[m,c]gcd[n,d] - (begin - (m ℕ.* d) ℕ./ (gcd[m,c] ℕ.* gcd[n,d]) ≡⟨ ℕ./-*-interchange gcd[m,c]∣m gcd[n,d]∣d ⟩ - (m ℕ./ gcd[m,c]) ℕ.* (d ℕ./ gcd[n,d]) ≡⟨ cong₂ ℕ._*_ m/gcd[m,c]≡n/gcd[n,d] (sym c/gcd[m,c]≡d/gcd[n,d]) ⟩ - (n ℕ./ gcd[n,d]) ℕ.* (c ℕ./ gcd[m,c]) ≡˘⟨ ℕ./-*-interchange gcd[n,d]∣n gcd[m,c]∣c ⟩ - (n ℕ.* c) ℕ./ (gcd[n,d] ℕ.* gcd[m,c]) ≡⟨ ℕ./-congʳ (ℕ.*-comm gcd[n,d] gcd[m,c]) ⟩ - (n ℕ.* c) ℕ./ (gcd[m,c] ℕ.* gcd[n,d]) ∎) - where - open ≡-Reasoning - gcd[m,c] = ℕ.gcd m c - gcd[n,d] = ℕ.gcd n d - gcd[m,c]∣m = ℕ.gcd[m,n]∣m m c - gcd[m,c]∣c = ℕ.gcd[m,n]∣n m c - gcd[n,d]∣n = ℕ.gcd[m,n]∣m n d - gcd[n,d]∣d = ℕ.gcd[m,n]∣n n d - md∣gcd[m,c]gcd[n,d] = *-pres-∣ gcd[m,c]∣m gcd[n,d]∣d - nc∣gcd[n,d]gcd[m,c] = *-pres-∣ gcd[n,d]∣n gcd[m,c]∣c - nc∣gcd[m,c]gcd[n,d] = subst (_∣ n ℕ.* c) (ℕ.*-comm gcd[n,d] gcd[m,c]) nc∣gcd[n,d]gcd[m,c] - - gcd[m,c]≢0′ = ℕ.gcd[m,n]≢0 m c (inj₂ (ℕ.≢-nonZero⁻¹ c)) - gcd[n,d]≢0′ = ℕ.gcd[m,n]≢0 n d (inj₂ (ℕ.≢-nonZero⁻¹ d)) - gcd[m,c]*gcd[n,d]≢0′ = Sum.[ gcd[m,c]≢0′ , gcd[n,d]≢0′ ] ∘ ℕ.m*n≡0⇒m≡0∨n≡0 _ - instance - gcd[m,c]≢0 = ℕ.≢-nonZero gcd[m,c]≢0′ - gcd[n,d]≢0 = ℕ.≢-nonZero gcd[n,d]≢0′ - c/gcd[m,c]≢0 = ℕ.≢-nonZero (ℕ.n/gcd[m,n]≢0 m c {{gcd≢0 = gcd[m,c]≢0}}) - d/gcd[n,d]≢0 = ℕ.≢-nonZero (ℕ.n/gcd[m,n]≢0 n d {{gcd≢0 = gcd[n,d]≢0}}) - gcd[m,c]*gcd[n,d]≢0 = ℕ.≢-nonZero gcd[m,c]*gcd[n,d]≢0′ - gcd[n,d]*gcd[m,c]≢0 = ℕ.≢-nonZero (subst (_≢ 0) (ℕ.*-comm gcd[m,c] gcd[n,d]) gcd[m,c]*gcd[n,d]≢0′) - - div = mkℚ+-injective eq - m/gcd[m,c]≡n/gcd[n,d] = proj₁ div - c/gcd[m,c]≡d/gcd[n,d] = proj₂ div - ------------------------------------------------------------------------- --- Properties of _/_ ------------------------------------------------------------------------- - -↥-/ : ∀ i n .{{_ : ℕ.NonZero n}} → ↥ (i / n) ℤ.* gcd i (+ n) ≡ i -↥-/ (+ m) n = ↥-normalize m n -↥-/ -[1+ m ] n = begin-equality - ↥ (- norm) ℤ.* + g ≡⟨ cong (ℤ._* + g) (↥-neg norm) ⟩ - ℤ.- (↥ norm) ℤ.* + g ≡⟨ sym (ℤ.neg-distribˡ-* (↥ norm) (+ g)) ⟩ - ℤ.- (↥ norm ℤ.* + g) ≡⟨ cong (ℤ.-_) (↥-normalize (suc m) n) ⟩ - S.- ◃ suc m ≡⟨⟩ - -[1+ m ] ∎ - where - open ℤ.≤-Reasoning - g = ℕ.gcd (suc m) n - norm = normalize (suc m) n - -↧-/ : ∀ i n .{{_ : ℕ.NonZero n}} → ↧ (i / n) ℤ.* gcd i (+ n) ≡ + n -↧-/ (+ m) n = ↧-normalize m n -↧-/ -[1+ m ] n = begin-equality - ↧ (- norm) ℤ.* + g ≡⟨ cong (ℤ._* + g) (↧-neg norm) ⟩ - ↧ norm ℤ.* + g ≡⟨ ↧-normalize (suc m) n ⟩ - + n ∎ - where - open ℤ.≤-Reasoning - g = ℕ.gcd (suc m) n - norm = normalize (suc m) n - -↥p/↧p≡p : ∀ p → ↥ p / ↧ₙ p ≡ p -↥p/↧p≡p (mkℚ (+ n) d-1 prf) = normalize-coprime prf -↥p/↧p≡p (mkℚ -[1+ n ] d-1 prf) = cong (-_) (normalize-coprime prf) - -0/n≡0 : ∀ n .{{_ : ℕ.NonZero n}} → 0ℤ / n ≡ 0ℚ -0/n≡0 n@(suc n-1) {{n≢0}} = mkℚ+-cong {{n/n≢0}} {c₂ = 0-cop-1} (ℕ.0/n≡0 (ℕ.gcd 0 n)) (ℕ.n/n≡1 n) - where - 0-cop-1 = C.sym (C.1-coprimeTo 0) - n/n≢0 = ℕ.>-nonZero (subst (ℕ._> 0) (sym (ℕ.n/n≡1 n)) (ℕ.z<s)) - -/-cong : ∀ {p₁ q₁ p₂ q₂} .{{_ : ℕ.NonZero q₁}} .{{_ : ℕ.NonZero q₂}} → - p₁ ≡ p₂ → q₁ ≡ q₂ → p₁ / q₁ ≡ p₂ / q₂ -/-cong {+ n} refl = normalize-cong {n} refl -/-cong { -[1+ n ]} refl = cong -_ ∘′ normalize-cong {suc n} refl - -private - /-injective-≃-helper : ∀ {m n c d} .{{_ : ℕ.NonZero c}} .{{_ : ℕ.NonZero d}} → - - normalize (suc m) c ≡ normalize n d → - mkℚᵘ -[1+ m ] (ℕ.pred c) ≃ᵘ mkℚᵘ (+ n) (ℕ.pred d) - /-injective-≃-helper {m} {n} {c} {d} -norm≡norm = contradiction - (sym -norm≡norm) - (nonNeg≢neg (normalize n d) (- normalize (suc m) c)) - where instance - _ : NonNegative (normalize n d) - _ = normalize-nonNeg n d - - _ : Negative (- normalize (suc m) c) - _ = neg-pos {normalize (suc m) c} (normalize-pos (suc m) c) - -/-injective-≃ : ∀ p q → ↥ᵘ p / ↧ₙᵘ p ≡ ↥ᵘ q / ↧ₙᵘ q → p ≃ᵘ q -/-injective-≃ (mkℚᵘ (+ m) c-1) (mkℚᵘ (+ n) d-1) eq = - *≡* (cong (S.+ ◃_) (normalize-injective-≃ m n _ _ eq)) -/-injective-≃ (mkℚᵘ (+ m) c-1) (mkℚᵘ -[1+ n ] d-1) eq = - ℚᵘ.≃-sym (/-injective-≃-helper (sym eq)) -/-injective-≃ (mkℚᵘ -[1+ m ] c-1) (mkℚᵘ (+ n) d-1) eq = - /-injective-≃-helper eq -/-injective-≃ (mkℚᵘ -[1+ m ] c-1) (mkℚᵘ -[1+ n ] d-1) eq = - *≡* (cong (S.- ◃_) (normalize-injective-≃ (suc m) (suc n) _ _ (neg-injective eq))) - ------------------------------------------------------------------------- --- Properties of toℚ/fromℚ ------------------------------------------------------------------------- - -↥ᵘ-toℚᵘ : ∀ p → ↥ᵘ (toℚᵘ p) ≡ ↥ p -↥ᵘ-toℚᵘ p@record{} = refl - -↧ᵘ-toℚᵘ : ∀ p → ↧ᵘ (toℚᵘ p) ≡ ↧ p -↧ᵘ-toℚᵘ p@record{} = refl - -toℚᵘ-injective : Injective _≡_ _≃ᵘ_ toℚᵘ -toℚᵘ-injective {x@record{}} {y@record{}} (*≡* eq) = ≃⇒≡ eq - -fromℚᵘ-injective : Injective _≃ᵘ_ _≡_ fromℚᵘ -fromℚᵘ-injective {p@record{}} {q@record{}} = /-injective-≃ p q - -fromℚᵘ-toℚᵘ : ∀ p → fromℚᵘ (toℚᵘ p) ≡ p -fromℚᵘ-toℚᵘ (mkℚ (+ n) d-1 c) = normalize-coprime c -fromℚᵘ-toℚᵘ (mkℚ (-[1+ n ]) d-1 c) = cong (-_) (normalize-coprime c) - -toℚᵘ-fromℚᵘ : ∀ p → toℚᵘ (fromℚᵘ p) ≃ᵘ p -toℚᵘ-fromℚᵘ p = fromℚᵘ-injective (fromℚᵘ-toℚᵘ (fromℚᵘ p)) - -toℚᵘ-cong : toℚᵘ Preserves _≡_ ⟶ _≃ᵘ_ -toℚᵘ-cong refl = *≡* refl - -fromℚᵘ-cong : fromℚᵘ Preserves _≃ᵘ_ ⟶ _≡_ -fromℚᵘ-cong {p} {q} p≃q = toℚᵘ-injective (begin-equality - toℚᵘ (fromℚᵘ p) ≃⟨ toℚᵘ-fromℚᵘ p ⟩ - p ≃⟨ p≃q ⟩ - q ≃˘⟨ toℚᵘ-fromℚᵘ q ⟩ - toℚᵘ (fromℚᵘ q) ∎) - where open ℚᵘ.≤-Reasoning - -toℚᵘ-isRelHomomorphism : IsRelHomomorphism _≡_ _≃ᵘ_ toℚᵘ -toℚᵘ-isRelHomomorphism = record - { cong = toℚᵘ-cong - } - -toℚᵘ-isRelMonomorphism : IsRelMonomorphism _≡_ _≃ᵘ_ toℚᵘ -toℚᵘ-isRelMonomorphism = record - { isHomomorphism = toℚᵘ-isRelHomomorphism - ; injective = toℚᵘ-injective - } - ------------------------------------------------------------------------- --- Properties of _≤_ ------------------------------------------------------------------------- - -drop-*≤* : p ≤ q → (↥ p ℤ.* ↧ q) ℤ.≤ (↥ q ℤ.* ↧ p) -drop-*≤* (*≤* pq≤qp) = pq≤qp - ------------------------------------------------------------------------- --- toℚᵘ is a isomorphism - -toℚᵘ-mono-≤ : p ≤ q → toℚᵘ p ≤ᵘ toℚᵘ q -toℚᵘ-mono-≤ {p@record{}} {q@record{}} (*≤* p≤q) = *≤* p≤q - -toℚᵘ-cancel-≤ : toℚᵘ p ≤ᵘ toℚᵘ q → p ≤ q -toℚᵘ-cancel-≤ {p@record{}} {q@record{}} (*≤* p≤q) = *≤* p≤q - -toℚᵘ-isOrderHomomorphism-≤ : IsOrderHomomorphism _≡_ _≃ᵘ_ _≤_ _≤ᵘ_ toℚᵘ -toℚᵘ-isOrderHomomorphism-≤ = record - { cong = toℚᵘ-cong - ; mono = toℚᵘ-mono-≤ - } - -toℚᵘ-isOrderMonomorphism-≤ : IsOrderMonomorphism _≡_ _≃ᵘ_ _≤_ _≤ᵘ_ toℚᵘ -toℚᵘ-isOrderMonomorphism-≤ = record - { isOrderHomomorphism = toℚᵘ-isOrderHomomorphism-≤ - ; injective = toℚᵘ-injective - ; cancel = toℚᵘ-cancel-≤ - } - ------------------------------------------------------------------------- --- Relational properties - -private - module ≤-Monomorphism = OrderMonomorphisms toℚᵘ-isOrderMonomorphism-≤ - -≤-reflexive : _≡_ ⇒ _≤_ -≤-reflexive refl = *≤* ℤ.≤-refl - -≤-refl : Reflexive _≤_ -≤-refl = ≤-reflexive refl - -≤-trans : Transitive _≤_ -≤-trans = ≤-Monomorphism.trans ℚᵘ.≤-trans - -≤-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) +open import Data.Product.Base using (proj₁; proj₂; _×_; _,_; uncurry) +open import Data.Rational.Base +open import Data.Rational.Unnormalised.Base as ℚᵘ + using (ℚᵘ; mkℚᵘ; *≡*; *≤*; *<*) + renaming + ( ↥_ to ↥ᵘ_; ↧_ to ↧ᵘ_; ↧ₙ_ to ↧ₙᵘ_ + ; _≃_ to _≃ᵘ_; _≤_ to _≤ᵘ_; _<_ to _<ᵘ_ + ; _+_ to _+ᵘ_ + ) +import Data.Rational.Unnormalised.Properties as ℚᵘ +open import Data.Sum.Base as Sum +open import Data.Unit using (tt) +import Data.Sign as S +open import Function.Base using (_∘_; _∘′_; _∘₂_; _$_; flip) +open import Function.Definitions using (Injective) +open import Level using (0ℓ) +open import Relation.Binary +open import Relation.Binary.PropositionalEquality +open import Relation.Binary.Morphism.Structures +import Relation.Binary.Morphism.OrderMonomorphism as OrderMonomorphisms +open import Relation.Nullary.Decidable.Core as Dec + using (yes; no; recompute; map′; _×-dec_) +open import Relation.Nullary.Negation.Core using (¬_; contradiction) +open import Relation.Binary.Reasoning.Syntax + +open import Algebra.Definitions {A = ℚ} _≡_ +open import Algebra.Structures {A = ℚ} _≡_ + +private + variable + p q r : ℚ + +------------------------------------------------------------------------ +-- Propositional equality +------------------------------------------------------------------------ + +mkℚ-cong : ∀ {n₁ n₂ d₁ d₂} + .{c₁ : Coprime ℤ.∣ n₁ ∣ (suc d₁)} + .{c₂ : Coprime ℤ.∣ n₂ ∣ (suc d₂)} → + n₁ ≡ n₂ → d₁ ≡ d₂ → mkℚ n₁ d₁ c₁ ≡ mkℚ n₂ d₂ c₂ +mkℚ-cong refl refl = refl + +mkℚ-injective : ∀ {n₁ n₂ d₁ d₂} + .{c₁ : Coprime ℤ.∣ n₁ ∣ (suc d₁)} + .{c₂ : Coprime ℤ.∣ n₂ ∣ (suc d₂)} → + mkℚ n₁ d₁ c₁ ≡ mkℚ n₂ d₂ c₂ → n₁ ≡ n₂ × d₁ ≡ d₂ +mkℚ-injective refl = refl , refl + +infix 4 _≟_ + +_≟_ : DecidableEquality ℚ +mkℚ n₁ d₁ _ ≟ mkℚ n₂ d₂ _ = map′ + (uncurry mkℚ-cong) + mkℚ-injective + (n₁ ℤ.≟ n₂ ×-dec d₁ ℕ.≟ d₂) + +≡-setoid : Setoid 0ℓ 0ℓ +≡-setoid = setoid ℚ + +≡-decSetoid : DecSetoid 0ℓ 0ℓ +≡-decSetoid = decSetoid _≟_ + +------------------------------------------------------------------------ +-- mkℚ+ +------------------------------------------------------------------------ + +mkℚ+-cong : ∀ {n₁ n₂ d₁ d₂} .{{_ : ℕ.NonZero d₁}} .{{_ : ℕ.NonZero d₂}} + .{c₁ : Coprime n₁ d₁} + .{c₂ : Coprime n₂ d₂} → + n₁ ≡ n₂ → d₁ ≡ d₂ → + mkℚ+ n₁ d₁ c₁ ≡ mkℚ+ n₂ d₂ c₂ +mkℚ+-cong refl refl = refl + +mkℚ+-injective : ∀ {n₁ n₂ d₁ d₂} .{{_ : ℕ.NonZero d₁}} .{{_ : ℕ.NonZero d₂}} + .{c₁ : Coprime n₁ d₁} + .{c₂ : Coprime n₂ d₂} → + mkℚ+ n₁ d₁ c₁ ≡ mkℚ+ n₂ d₂ c₂ → + n₁ ≡ n₂ × d₁ ≡ d₂ +mkℚ+-injective {d₁ = suc _} {suc _} refl = refl , refl + +↥-mkℚ+ : ∀ n d .{{_ : ℕ.NonZero d}} .{c : Coprime n d} → ↥ (mkℚ+ n d c) ≡ + n +↥-mkℚ+ n (suc d) = refl + +↧-mkℚ+ : ∀ n d .{{_ : ℕ.NonZero d}} .{c : Coprime n d} → ↧ (mkℚ+ n d c) ≡ + d +↧-mkℚ+ n (suc d) = refl + +mkℚ+-nonNeg : ∀ n d .{{_ : ℕ.NonZero d}} .{c : Coprime n d} → + NonNegative (mkℚ+ n d c) +mkℚ+-nonNeg n (suc d) = _ + +mkℚ+-pos : ∀ n d .{{_ : ℕ.NonZero n}} .{{_ : ℕ.NonZero d}} + .{c : Coprime n d} → Positive (mkℚ+ n d c) +mkℚ+-pos (suc n) (suc d) = _ + +------------------------------------------------------------------------ +-- Numerator and denominator equality +------------------------------------------------------------------------ + +drop-*≡* : p ≃ q → ↥ p ℤ.* ↧ q ≡ ↥ q ℤ.* ↧ p +drop-*≡* (*≡* eq) = eq + +≡⇒≃ : _≡_ ⇒ _≃_ +≡⇒≃ refl = *≡* refl + +≃⇒≡ : _≃_ ⇒ _≡_ +≃⇒≡ {x = mkℚ n₁ d₁ c₁} {y = mkℚ n₂ d₂ c₂} (*≡* eq) = helper + where + open ≡-Reasoning + + 1+d₁∣1+d₂ : suc d₁ ∣ suc d₂ + 1+d₁∣1+d₂ = coprime-divisor (+ suc d₁) n₁ (+ suc d₂) + (C.sym (C.recompute c₁)) $ + divides ℤ.∣ n₂ ∣ $ begin + ℤ.∣ n₁ ℤ.* + suc d₂ ∣ ≡⟨ cong ℤ.∣_∣ eq ⟩ + ℤ.∣ n₂ ℤ.* + suc d₁ ∣ ≡⟨ ℤ.abs-* n₂ (+ suc d₁) ⟩ + ℤ.∣ n₂ ∣ ℕ.* suc d₁ ∎ + + 1+d₂∣1+d₁ : suc d₂ ∣ suc d₁ + 1+d₂∣1+d₁ = coprime-divisor (+ suc d₂) n₂ (+ suc d₁) + (C.sym (C.recompute c₂)) $ + divides ℤ.∣ n₁ ∣ (begin + ℤ.∣ n₂ ℤ.* + suc d₁ ∣ ≡⟨ cong ℤ.∣_∣ (sym eq) ⟩ + ℤ.∣ n₁ ℤ.* + suc d₂ ∣ ≡⟨ ℤ.abs-* n₁ (+ suc d₂) ⟩ + ℤ.∣ n₁ ∣ ℕ.* suc d₂ ∎) + + helper : mkℚ n₁ d₁ c₁ ≡ mkℚ n₂ d₂ c₂ + helper with ∣-antisym 1+d₁∣1+d₂ 1+d₂∣1+d₁ + ... | refl with ℤ.*-cancelʳ-≡ n₁ n₂ (+ suc d₁) eq + ... | refl = refl + +≃-sym : Symmetric _≃_ +≃-sym = ≡⇒≃ ∘′ sym ∘′ ≃⇒≡ + +------------------------------------------------------------------------ +-- Properties of ↥ +------------------------------------------------------------------------ + +↥p≡0⇒p≡0 : ∀ p → ↥ p ≡ 0ℤ → p ≡ 0ℚ +↥p≡0⇒p≡0 (mkℚ +0 d-1 0-coprime-d) ↥p≡0 = mkℚ-cong refl d-1≡0 + where d-1≡0 = ℕ.suc-injective (C.0-coprimeTo-m⇒m≡1 (C.recompute 0-coprime-d)) + +p≡0⇒↥p≡0 : ∀ p → p ≡ 0ℚ → ↥ p ≡ 0ℤ +p≡0⇒↥p≡0 p refl = refl + +↥p≡↥q≡0⇒p≡q : ∀ p q → ↥ p ≡ 0ℤ → ↥ q ≡ 0ℤ → p ≡ q +↥p≡↥q≡0⇒p≡q p q ↥p≡0 ↥q≡0 = trans (↥p≡0⇒p≡0 p ↥p≡0) (sym (↥p≡0⇒p≡0 q ↥q≡0)) + +------------------------------------------------------------------------ +-- Basic properties of sign predicates +------------------------------------------------------------------------ + +nonNeg≢neg : ∀ p q → .{{NonNegative p}} → .{{Negative q}} → p ≢ q +nonNeg≢neg (mkℚ (+ _) _ _) (mkℚ -[1+ _ ] _ _) () + +pos⇒nonNeg : ∀ p → .{{Positive p}} → NonNegative p +pos⇒nonNeg p = ℚᵘ.pos⇒nonNeg (toℚᵘ p) + +neg⇒nonPos : ∀ p → .{{Negative p}} → NonPositive p +neg⇒nonPos p = ℚᵘ.neg⇒nonPos (toℚᵘ p) + +nonNeg∧nonZero⇒pos : ∀ p → .{{NonNegative p}} → .{{NonZero p}} → Positive p +nonNeg∧nonZero⇒pos (mkℚ +[1+ _ ] _ _) = _ + +pos⇒nonZero : ∀ p → .{{Positive p}} → NonZero p +pos⇒nonZero (mkℚ +[1+ _ ] _ _) = _ + +neg⇒nonZero : ∀ p → .{{Negative p}} → NonZero p +neg⇒nonZero (mkℚ -[1+ _ ] _ _) = _ + +------------------------------------------------------------------------ +-- Properties of -_ +------------------------------------------------------------------------ + +↥-neg : ∀ p → ↥ (- p) ≡ ℤ.- (↥ p) +↥-neg (mkℚ -[1+ _ ] _ _) = refl +↥-neg (mkℚ +0 _ _) = refl +↥-neg (mkℚ +[1+ _ ] _ _) = refl + +↧-neg : ∀ p → ↧ (- p) ≡ ↧ p +↧-neg (mkℚ -[1+ _ ] _ _) = refl +↧-neg (mkℚ +0 _ _) = refl +↧-neg (mkℚ +[1+ _ ] _ _) = refl + +neg-injective : - p ≡ - q → p ≡ q +neg-injective {mkℚ +[1+ m ] _ _} {mkℚ +[1+ n ] _ _} refl = refl +neg-injective {mkℚ +0 _ _} {mkℚ +0 _ _} refl = refl +neg-injective {mkℚ -[1+ m ] _ _} {mkℚ -[1+ n ] _ _} refl = refl +neg-injective {mkℚ +[1+ m ] _ _} {mkℚ -[1+ n ] _ _} () +neg-injective {mkℚ +0 _ _} {mkℚ -[1+ n ] _ _} () +neg-injective {mkℚ -[1+ m ] _ _} {mkℚ +[1+ n ] _ _} () +neg-injective {mkℚ -[1+ m ] _ _} {mkℚ +0 _ _} () + +neg-pos : Positive p → Negative (- p) +neg-pos {mkℚ +[1+ _ ] _ _} _ = _ + +------------------------------------------------------------------------ +-- Properties of normalize +------------------------------------------------------------------------ + +normalize-coprime : ∀ {n d-1} .(c : Coprime n (suc d-1)) → + normalize n (suc d-1) ≡ mkℚ (+ n) d-1 c +normalize-coprime {n} {d-1} c = begin + normalize n d ≡⟨⟩ + mkℚ+ ((n ℕ./ g) {{g≢0}}) ((d ℕ./ g) {{g≢0}}) _ ≡⟨ mkℚ+-cong {c₂ = c₂} (ℕ./-congʳ {{g≢0}} g≡1) (ℕ./-congʳ {{g≢0}} g≡1) ⟩ + mkℚ+ (n ℕ./ 1) (d ℕ./ 1) _ ≡⟨ mkℚ+-cong {c₂ = c} (ℕ.n/1≡n n) (ℕ.n/1≡n d) ⟩ + mkℚ+ n d _ ≡⟨⟩ + mkℚ (+ n) d-1 _ ∎ + where + open ≡-Reasoning; d = suc d-1; g = ℕ.gcd n d + c′ = C.recompute c + c₂ : Coprime (n ℕ./ 1) (d ℕ./ 1) + c₂ = subst₂ Coprime (sym (ℕ.n/1≡n n)) (sym (ℕ.n/1≡n d)) c′ + g≡1 = C.coprime⇒gcd≡1 c′ + instance + g≢0 = ℕ.≢-nonZero (ℕ.gcd[m,n]≢0 n d (inj₂ λ())) + n/g≢0 = ℕ.≢-nonZero (ℕ.n/gcd[m,n]≢0 n d {{_}} {{g≢0}}) + d/1≢0 = ℕ.≢-nonZero (subst (_≢ 0) (sym (ℕ.n/1≡n d)) λ()) + +↥-normalize : ∀ i n .{{_ : ℕ.NonZero n}} → ↥ (normalize i n) ℤ.* gcd (+ i) (+ n) ≡ + i +↥-normalize i n = begin + ↥ (normalize i n) ℤ.* + g ≡⟨ cong (ℤ._* + g) (↥-mkℚ+ _ (n ℕ./ g)) ⟩ + + i/g ℤ.* + g ≡⟨⟩ + S.+ ◃ i/g ℕ.* g ≡⟨ cong (S.+ ◃_) (ℕ.m/n*n≡m (ℕ.gcd[m,n]∣m i n)) ⟩ + S.+ ◃ i ≡⟨ ℤ.+◃n≡+n i ⟩ + + i ∎ + where + open ≡-Reasoning + g = ℕ.gcd i n + instance g≢0 = ℕ.≢-nonZero (ℕ.gcd[m,n]≢0 i n (inj₂ (ℕ.≢-nonZero⁻¹ n))) + instance n/g≢0 = ℕ.≢-nonZero (ℕ.n/gcd[m,n]≢0 i n {{gcd≢0 = g≢0}}) + i/g = (i ℕ./ g) {{g≢0}} + +↧-normalize : ∀ i n .{{_ : ℕ.NonZero n}} → ↧ (normalize i n) ℤ.* gcd (+ i) (+ n) ≡ + n +↧-normalize i n = begin + ↧ (normalize i n) ℤ.* + g ≡⟨ cong (ℤ._* + g) (↧-mkℚ+ _ (n ℕ./ g)) ⟩ + + (n ℕ./ g) ℤ.* + g ≡⟨⟩ + S.+ ◃ n ℕ./ g ℕ.* g ≡⟨ cong (S.+ ◃_) (ℕ.m/n*n≡m (ℕ.gcd[m,n]∣n i n)) ⟩ + S.+ ◃ n ≡⟨ ℤ.+◃n≡+n n ⟩ + + n ∎ + where + open ≡-Reasoning + g = ℕ.gcd i n + instance g≢0 = ℕ.≢-nonZero (ℕ.gcd[m,n]≢0 i n (inj₂ (ℕ.≢-nonZero⁻¹ n))) + instance n/g≢0 = ℕ.≢-nonZero (ℕ.n/gcd[m,n]≢0 i n {{gcd≢0 = g≢0}}) + +normalize-cong : ∀ {m₁ n₁ m₂ n₂} .{{_ : ℕ.NonZero n₁}} .{{_ : ℕ.NonZero n₂}} → + m₁ ≡ m₂ → n₁ ≡ n₂ → normalize m₁ n₁ ≡ normalize m₂ n₂ +normalize-cong {m} {n} refl refl = + mkℚ+-cong (ℕ./-congʳ {n = g} refl) (ℕ./-congʳ {n = g} refl) + where + g = ℕ.gcd m n + instance + g≢0 = ℕ.≢-nonZero (ℕ.gcd[m,n]≢0 m n (inj₂ (ℕ.≢-nonZero⁻¹ n))) + n/g≢0 = ℕ.≢-nonZero (ℕ.n/gcd[m,n]≢0 m n {{gcd≢0 = g≢0}}) + +normalize-nonNeg : ∀ m n .{{_ : ℕ.NonZero n}} → NonNegative (normalize m n) +normalize-nonNeg m n = mkℚ+-nonNeg (m ℕ./ g) (n ℕ./ g) + where + g = ℕ.gcd m n + instance + g≢0 = ℕ.≢-nonZero (ℕ.gcd[m,n]≢0 m n (inj₂ (ℕ.≢-nonZero⁻¹ n))) + n/g≢0 = ℕ.≢-nonZero (ℕ.n/gcd[m,n]≢0 m n {{gcd≢0 = g≢0}}) + +normalize-pos : ∀ m n .{{_ : ℕ.NonZero n}} .{{_ : ℕ.NonZero m}} → Positive (normalize m n) +normalize-pos m n = mkℚ+-pos (m ℕ./ ℕ.gcd m n) (n ℕ./ ℕ.gcd m n) + where + g = ℕ.gcd m n + instance + g≢0 = ℕ.≢-nonZero (ℕ.gcd[m,n]≢0 m n (inj₂ (ℕ.≢-nonZero⁻¹ n))) + n/g≢0 = ℕ.≢-nonZero (ℕ.n/gcd[m,n]≢0 m n {{gcd≢0 = g≢0}}) + m/g≢0 = ℕ.≢-nonZero (ℕ.m/gcd[m,n]≢0 m n {{gcd≢0 = g≢0}}) + +normalize-injective-≃ : ∀ m n c d {{_ : ℕ.NonZero c}} {{_ : ℕ.NonZero d}} → + normalize m c ≡ normalize n d → + m ℕ.* d ≡ n ℕ.* c +normalize-injective-≃ m n c d eq = ℕ./-cancelʳ-≡ + md∣gcd[m,c]gcd[n,d] + nc∣gcd[m,c]gcd[n,d] + (begin + (m ℕ.* d) ℕ./ (gcd[m,c] ℕ.* gcd[n,d]) ≡⟨ ℕ./-*-interchange gcd[m,c]∣m gcd[n,d]∣d ⟩ + (m ℕ./ gcd[m,c]) ℕ.* (d ℕ./ gcd[n,d]) ≡⟨ cong₂ ℕ._*_ m/gcd[m,c]≡n/gcd[n,d] (sym c/gcd[m,c]≡d/gcd[n,d]) ⟩ + (n ℕ./ gcd[n,d]) ℕ.* (c ℕ./ gcd[m,c]) ≡⟨ ℕ./-*-interchange gcd[n,d]∣n gcd[m,c]∣c ⟨ + (n ℕ.* c) ℕ./ (gcd[n,d] ℕ.* gcd[m,c]) ≡⟨ ℕ./-congʳ (ℕ.*-comm gcd[n,d] gcd[m,c]) ⟩ + (n ℕ.* c) ℕ./ (gcd[m,c] ℕ.* gcd[n,d]) ∎) + where + open ≡-Reasoning + gcd[m,c] = ℕ.gcd m c + gcd[n,d] = ℕ.gcd n d + gcd[m,c]∣m = ℕ.gcd[m,n]∣m m c + gcd[m,c]∣c = ℕ.gcd[m,n]∣n m c + gcd[n,d]∣n = ℕ.gcd[m,n]∣m n d + gcd[n,d]∣d = ℕ.gcd[m,n]∣n n d + md∣gcd[m,c]gcd[n,d] = *-pres-∣ gcd[m,c]∣m gcd[n,d]∣d + nc∣gcd[n,d]gcd[m,c] = *-pres-∣ gcd[n,d]∣n gcd[m,c]∣c + nc∣gcd[m,c]gcd[n,d] = subst (_∣ n ℕ.* c) (ℕ.*-comm gcd[n,d] gcd[m,c]) nc∣gcd[n,d]gcd[m,c] + + gcd[m,c]≢0′ = ℕ.gcd[m,n]≢0 m c (inj₂ (ℕ.≢-nonZero⁻¹ c)) + gcd[n,d]≢0′ = ℕ.gcd[m,n]≢0 n d (inj₂ (ℕ.≢-nonZero⁻¹ d)) + gcd[m,c]*gcd[n,d]≢0′ = Sum.[ gcd[m,c]≢0′ , gcd[n,d]≢0′ ] ∘ ℕ.m*n≡0⇒m≡0∨n≡0 _ + instance + gcd[m,c]≢0 = ℕ.≢-nonZero gcd[m,c]≢0′ + gcd[n,d]≢0 = ℕ.≢-nonZero gcd[n,d]≢0′ + c/gcd[m,c]≢0 = ℕ.≢-nonZero (ℕ.n/gcd[m,n]≢0 m c {{gcd≢0 = gcd[m,c]≢0}}) + d/gcd[n,d]≢0 = ℕ.≢-nonZero (ℕ.n/gcd[m,n]≢0 n d {{gcd≢0 = gcd[n,d]≢0}}) + gcd[m,c]*gcd[n,d]≢0 = ℕ.≢-nonZero gcd[m,c]*gcd[n,d]≢0′ + gcd[n,d]*gcd[m,c]≢0 = ℕ.≢-nonZero (subst (_≢ 0) (ℕ.*-comm gcd[m,c] gcd[n,d]) gcd[m,c]*gcd[n,d]≢0′) + + div = mkℚ+-injective eq + m/gcd[m,c]≡n/gcd[n,d] = proj₁ div + c/gcd[m,c]≡d/gcd[n,d] = proj₂ div + +------------------------------------------------------------------------ +-- Properties of _/_ +------------------------------------------------------------------------ + +↥-/ : ∀ i n .{{_ : ℕ.NonZero n}} → ↥ (i / n) ℤ.* gcd i (+ n) ≡ i +↥-/ (+ m) n = ↥-normalize m n +↥-/ -[1+ m ] n = begin-equality + ↥ (- norm) ℤ.* + g ≡⟨ cong (ℤ._* + g) (↥-neg norm) ⟩ + ℤ.- (↥ norm) ℤ.* + g ≡⟨ sym (ℤ.neg-distribˡ-* (↥ norm) (+ g)) ⟩ + ℤ.- (↥ norm ℤ.* + g) ≡⟨ cong (ℤ.-_) (↥-normalize (suc m) n) ⟩ + S.- ◃ suc m ≡⟨⟩ + -[1+ m ] ∎ + where + open ℤ.≤-Reasoning + g = ℕ.gcd (suc m) n + norm = normalize (suc m) n + +↧-/ : ∀ i n .{{_ : ℕ.NonZero n}} → ↧ (i / n) ℤ.* gcd i (+ n) ≡ + n +↧-/ (+ m) n = ↧-normalize m n +↧-/ -[1+ m ] n = begin-equality + ↧ (- norm) ℤ.* + g ≡⟨ cong (ℤ._* + g) (↧-neg norm) ⟩ + ↧ norm ℤ.* + g ≡⟨ ↧-normalize (suc m) n ⟩ + + n ∎ + where + open ℤ.≤-Reasoning + g = ℕ.gcd (suc m) n + norm = normalize (suc m) n + +↥p/↧p≡p : ∀ p → ↥ p / ↧ₙ p ≡ p +↥p/↧p≡p (mkℚ (+ n) d-1 prf) = normalize-coprime prf +↥p/↧p≡p (mkℚ -[1+ n ] d-1 prf) = cong (-_) (normalize-coprime prf) + +0/n≡0 : ∀ n .{{_ : ℕ.NonZero n}} → 0ℤ / n ≡ 0ℚ +0/n≡0 n@(suc n-1) {{n≢0}} = mkℚ+-cong {{n/n≢0}} {c₂ = 0-cop-1} (ℕ.0/n≡0 (ℕ.gcd 0 n)) (ℕ.n/n≡1 n) + where + 0-cop-1 = C.sym (C.1-coprimeTo 0) + n/n≢0 = ℕ.>-nonZero (subst (ℕ._> 0) (sym (ℕ.n/n≡1 n)) (ℕ.z<s)) + +/-cong : ∀ {p₁ q₁ p₂ q₂} .{{_ : ℕ.NonZero q₁}} .{{_ : ℕ.NonZero q₂}} → + p₁ ≡ p₂ → q₁ ≡ q₂ → p₁ / q₁ ≡ p₂ / q₂ +/-cong {+ n} refl = normalize-cong {n} refl +/-cong { -[1+ n ]} refl = cong -_ ∘′ normalize-cong {suc n} refl + +private + /-injective-≃-helper : ∀ {m n c d} .{{_ : ℕ.NonZero c}} .{{_ : ℕ.NonZero d}} → + - normalize (suc m) c ≡ normalize n d → + mkℚᵘ -[1+ m ] (ℕ.pred c) ≃ᵘ mkℚᵘ (+ n) (ℕ.pred d) + /-injective-≃-helper {m} {n} {c} {d} -norm≡norm = contradiction + (sym -norm≡norm) + (nonNeg≢neg (normalize n d) (- normalize (suc m) c)) + where instance + _ : NonNegative (normalize n d) + _ = normalize-nonNeg n d + + _ : Negative (- normalize (suc m) c) + _ = neg-pos {normalize (suc m) c} (normalize-pos (suc m) c) + +/-injective-≃ : ∀ p q → ↥ᵘ p / ↧ₙᵘ p ≡ ↥ᵘ q / ↧ₙᵘ q → p ≃ᵘ q +/-injective-≃ (mkℚᵘ (+ m) c-1) (mkℚᵘ (+ n) d-1) eq = + *≡* (cong (S.+ ◃_) (normalize-injective-≃ m n _ _ eq)) +/-injective-≃ (mkℚᵘ (+ m) c-1) (mkℚᵘ -[1+ n ] d-1) eq = + ℚᵘ.≃-sym (/-injective-≃-helper (sym eq)) +/-injective-≃ (mkℚᵘ -[1+ m ] c-1) (mkℚᵘ (+ n) d-1) eq = + /-injective-≃-helper eq +/-injective-≃ (mkℚᵘ -[1+ m ] c-1) (mkℚᵘ -[1+ n ] d-1) eq = + *≡* (cong (S.- ◃_) (normalize-injective-≃ (suc m) (suc n) _ _ (neg-injective eq))) + +------------------------------------------------------------------------ +-- Properties of toℚ/fromℚ +------------------------------------------------------------------------ + +↥ᵘ-toℚᵘ : ∀ p → ↥ᵘ (toℚᵘ p) ≡ ↥ p +↥ᵘ-toℚᵘ p@record{} = refl + +↧ᵘ-toℚᵘ : ∀ p → ↧ᵘ (toℚᵘ p) ≡ ↧ p +↧ᵘ-toℚᵘ p@record{} = refl + +toℚᵘ-injective : Injective _≡_ _≃ᵘ_ toℚᵘ +toℚᵘ-injective {x@record{}} {y@record{}} (*≡* eq) = ≃⇒≡ (*≡* eq) + +fromℚᵘ-injective : Injective _≃ᵘ_ _≡_ fromℚᵘ +fromℚᵘ-injective {p@record{}} {q@record{}} = /-injective-≃ p q + +fromℚᵘ-toℚᵘ : ∀ p → fromℚᵘ (toℚᵘ p) ≡ p +fromℚᵘ-toℚᵘ (mkℚ (+ n) d-1 c) = normalize-coprime c +fromℚᵘ-toℚᵘ (mkℚ (-[1+ n ]) d-1 c) = cong (-_) (normalize-coprime c) + +toℚᵘ-fromℚᵘ : ∀ p → toℚᵘ (fromℚᵘ p) ≃ᵘ p +toℚᵘ-fromℚᵘ p = fromℚᵘ-injective (fromℚᵘ-toℚᵘ (fromℚᵘ p)) + +toℚᵘ-cong : toℚᵘ Preserves _≡_ ⟶ _≃ᵘ_ +toℚᵘ-cong refl = *≡* refl + +fromℚᵘ-cong : fromℚᵘ Preserves _≃ᵘ_ ⟶ _≡_ +fromℚᵘ-cong {p} {q} p≃q = toℚᵘ-injective (begin-equality + toℚᵘ (fromℚᵘ p) ≃⟨ toℚᵘ-fromℚᵘ p ⟩ + p ≃⟨ p≃q ⟩ + q ≃⟨ toℚᵘ-fromℚᵘ q ⟨ + toℚᵘ (fromℚᵘ q) ∎) + where open ℚᵘ.≤-Reasoning + +toℚᵘ-isRelHomomorphism : IsRelHomomorphism _≡_ _≃ᵘ_ toℚᵘ +toℚᵘ-isRelHomomorphism = record + { cong = toℚᵘ-cong + } + +toℚᵘ-isRelMonomorphism : IsRelMonomorphism _≡_ _≃ᵘ_ toℚᵘ +toℚᵘ-isRelMonomorphism = record + { isHomomorphism = toℚᵘ-isRelHomomorphism + ; injective = toℚᵘ-injective + } + +------------------------------------------------------------------------ +-- Properties of _≤_ +------------------------------------------------------------------------ + +drop-*≤* : p ≤ q → (↥ p ℤ.* ↧ q) ℤ.≤ (↥ q ℤ.* ↧ p) +drop-*≤* (*≤* pq≤qp) = pq≤qp + +------------------------------------------------------------------------ +-- toℚᵘ is a isomorphism + +toℚᵘ-mono-≤ : p ≤ q → toℚᵘ p ≤ᵘ toℚᵘ q +toℚᵘ-mono-≤ {p@record{}} {q@record{}} (*≤* p≤q) = *≤* p≤q + +toℚᵘ-cancel-≤ : toℚᵘ p ≤ᵘ toℚᵘ q → p ≤ q +toℚᵘ-cancel-≤ {p@record{}} {q@record{}} (*≤* p≤q) = *≤* p≤q + +toℚᵘ-isOrderHomomorphism-≤ : IsOrderHomomorphism _≡_ _≃ᵘ_ _≤_ _≤ᵘ_ toℚᵘ +toℚᵘ-isOrderHomomorphism-≤ = record + { cong = toℚᵘ-cong + ; mono = toℚᵘ-mono-≤ + } + +toℚᵘ-isOrderMonomorphism-≤ : IsOrderMonomorphism _≡_ _≃ᵘ_ _≤_ _≤ᵘ_ toℚᵘ +toℚᵘ-isOrderMonomorphism-≤ = record + { isOrderHomomorphism = toℚᵘ-isOrderHomomorphism-≤ + ; injective = toℚᵘ-injective + ; cancel = toℚᵘ-cancel-≤ + } + +------------------------------------------------------------------------ +-- Relational properties + +private + module ≤-Monomorphism = OrderMonomorphisms toℚᵘ-isOrderMonomorphism-≤ + +≤-reflexive : _≡_ ⇒ _≤_ +≤-reflexive refl = *≤* ℤ.≤-refl + +≤-refl : Reflexive _≤_ +≤-refl = ≤-reflexive refl + +≤-trans : Transitive _≤_ +≤-trans = ≤-Monomorphism.trans ℚᵘ.≤-trans + +≤-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) -_≥?_ : Decidable _≥_ -_≥?_ = flip _≤?_ +_≥?_ : Decidable _≥_ +_≥?_ = flip _≤?_ -≤-irrelevant : Irrelevant _≤_ -≤-irrelevant (*≤* p≤q₁) (*≤* p≤q₂) = cong *≤* (ℤ.≤-irrelevant p≤q₁ p≤q₂) +≤-irrelevant : Irrelevant _≤_ +≤-irrelevant (*≤* p≤q₁) (*≤* p≤q₂) = cong *≤* (ℤ.≤-irrelevant p≤q₁ p≤q₂) + +------------------------------------------------------------------------ +-- Structures + +≤-isPreorder : IsPreorder _≡_ _≤_ +≤-isPreorder = record + { isEquivalence = isEquivalence + ; reflexive = ≤-reflexive + ; trans = ≤-trans + } + +≤-isTotalPreorder : IsTotalPreorder _≡_ _≤_ +≤-isTotalPreorder = record + { isPreorder = ≤-isPreorder + ; total = ≤-total + } + +≤-isPartialOrder : IsPartialOrder _≡_ _≤_ +≤-isPartialOrder = record + { isPreorder = ≤-isPreorder + ; antisym = ≤-antisym + } + +≤-isTotalOrder : IsTotalOrder _≡_ _≤_ +≤-isTotalOrder = record + { isPartialOrder = ≤-isPartialOrder + ; total = ≤-total + } + +≤-isDecTotalOrder : IsDecTotalOrder _≡_ _≤_ +≤-isDecTotalOrder = record + { isTotalOrder = ≤-isTotalOrder + ; _≟_ = _≟_ + ; _≤?_ = _≤?_ + } + +------------------------------------------------------------------------ +-- Bundles ------------------------------------------------------------------------- --- Structures - -≤-isPreorder : IsPreorder _≡_ _≤_ -≤-isPreorder = record - { isEquivalence = isEquivalence - ; reflexive = ≤-reflexive - ; trans = ≤-trans - } - -≤-isTotalPreorder : IsTotalPreorder _≡_ _≤_ -≤-isTotalPreorder = record - { isPreorder = ≤-isPreorder - ; total = ≤-total - } - -≤-isPartialOrder : IsPartialOrder _≡_ _≤_ -≤-isPartialOrder = record - { isPreorder = ≤-isPreorder - ; antisym = ≤-antisym - } - -≤-isTotalOrder : IsTotalOrder _≡_ _≤_ -≤-isTotalOrder = record - { isPartialOrder = ≤-isPartialOrder - ; total = ≤-total - } +≤-totalPreorder : TotalPreorder 0ℓ 0ℓ 0ℓ +≤-totalPreorder = record + { isTotalPreorder = ≤-isTotalPreorder + } -≤-isDecTotalOrder : IsDecTotalOrder _≡_ _≤_ -≤-isDecTotalOrder = record - { isTotalOrder = ≤-isTotalOrder - ; _≟_ = _≟_ - ; _≤?_ = _≤?_ - } - ------------------------------------------------------------------------- --- Bundles - -≤-totalPreorder : TotalPreorder 0ℓ 0ℓ 0ℓ -≤-totalPreorder = record - { isTotalPreorder = ≤-isTotalPreorder - } - -≤-decTotalOrder : DecTotalOrder _ _ _ -≤-decTotalOrder = record - { Carrier = ℚ - ; _≈_ = _≡_ - ; _≤_ = _≤_ - ; isDecTotalOrder = ≤-isDecTotalOrder - } - ------------------------------------------------------------------------- --- Properties of _<_ ------------------------------------------------------------------------- - -drop-*<* : p < q → (↥ p ℤ.* ↧ q) ℤ.< (↥ q ℤ.* ↧ p) -drop-*<* (*<* pq<qp) = pq<qp +≤-decTotalOrder : DecTotalOrder _ _ _ +≤-decTotalOrder = record + { Carrier = ℚ + ; _≈_ = _≡_ + ; _≤_ = _≤_ + ; isDecTotalOrder = ≤-isDecTotalOrder + } ------------------------------------------------------------------------ --- toℚᵘ is a isomorphism - -toℚᵘ-mono-< : p < q → toℚᵘ p <ᵘ toℚᵘ q -toℚᵘ-mono-< {p@record{}} {q@record{}} (*<* p<q) = *<* p<q - -toℚᵘ-cancel-< : toℚᵘ p <ᵘ toℚᵘ q → p < q -toℚᵘ-cancel-< {p@record{}} {q@record{}} (*<* p<q) = *<* p<q - -toℚᵘ-isOrderHomomorphism-< : IsOrderHomomorphism _≡_ _≃ᵘ_ _<_ _<ᵘ_ toℚᵘ -toℚᵘ-isOrderHomomorphism-< = record - { cong = toℚᵘ-cong - ; mono = toℚᵘ-mono-< - } - -toℚᵘ-isOrderMonomorphism-< : IsOrderMonomorphism _≡_ _≃ᵘ_ _<_ _<ᵘ_ toℚᵘ -toℚᵘ-isOrderMonomorphism-< = record - { isOrderHomomorphism = toℚᵘ-isOrderHomomorphism-< - ; injective = toℚᵘ-injective - ; cancel = toℚᵘ-cancel-< - } - ------------------------------------------------------------------------- --- Relational properties - -<⇒≤ : _<_ ⇒ _≤_ -<⇒≤ (*<* p<q) = *≤* (ℤ.<⇒≤ p<q) - -≮⇒≥ : _≮_ ⇒ _≥_ -≮⇒≥ {p} {q} p≮q = *≤* (ℤ.≮⇒≥ (p≮q ∘ *<*)) - -≰⇒> : _≰_ ⇒ _>_ -≰⇒> {p} {q} p≰q = *<* (ℤ.≰⇒> (p≰q ∘ *≤*)) - -<⇒≢ : _<_ ⇒ _≢_ -<⇒≢ {p} {q} (*<* p<q) = ℤ.<⇒≢ p<q ∘ ≡⇒≃ - -<-irrefl : Irreflexive _≡_ _<_ -<-irrefl refl (*<* p<p) = ℤ.<-irrefl refl p<p - -<-asym : Asymmetric _<_ -<-asym (*<* p<q) (*<* q<p) = ℤ.<-asym p<q q<p - -<-≤-trans : Trans _<_ _≤_ _<_ -<-≤-trans {p} {q} {r} (*<* p<q) (*≤* q≤r) = *<* - (ℤ.*-cancelʳ-<-nonNeg _ (begin-strict - let n₁ = ↥ p; n₂ = ↥ q; n₃ = ↥ r; sd₁ = ↧ p; sd₂ = ↧ q; sd₃ = ↧ r in - (n₁ ℤ.* sd₃) ℤ.* sd₂ ≡⟨ ℤ.*-assoc n₁ sd₃ sd₂ ⟩ - n₁ ℤ.* (sd₃ ℤ.* sd₂) ≡⟨ cong (n₁ ℤ.*_) (ℤ.*-comm sd₃ sd₂) ⟩ - n₁ ℤ.* (sd₂ ℤ.* sd₃) ≡⟨ sym (ℤ.*-assoc n₁ sd₂ sd₃) ⟩ - (n₁ ℤ.* sd₂) ℤ.* sd₃ <⟨ ℤ.*-monoʳ-<-pos (↧ r) p<q ⟩ - (n₂ ℤ.* sd₁) ℤ.* sd₃ ≡⟨ cong (ℤ._* sd₃) (ℤ.*-comm n₂ sd₁) ⟩ - (sd₁ ℤ.* n₂) ℤ.* sd₃ ≡⟨ ℤ.*-assoc sd₁ n₂ sd₃ ⟩ - sd₁ ℤ.* (n₂ ℤ.* sd₃) ≤⟨ ℤ.*-monoˡ-≤-nonNeg (↧ p) q≤r ⟩ - sd₁ ℤ.* (n₃ ℤ.* sd₂) ≡⟨ sym (ℤ.*-assoc sd₁ n₃ sd₂) ⟩ - (sd₁ ℤ.* n₃) ℤ.* sd₂ ≡⟨ cong (ℤ._* sd₂) (ℤ.*-comm sd₁ n₃) ⟩ - (n₃ ℤ.* sd₁) ℤ.* sd₂ ∎)) - where open ℤ.≤-Reasoning - -≤-<-trans : Trans _≤_ _<_ _<_ -≤-<-trans {p} {q} {r} (*≤* p≤q) (*<* q<r) = *<* - (ℤ.*-cancelʳ-<-nonNeg _ (begin-strict - let n₁ = ↥ p; n₂ = ↥ q; n₃ = ↥ r; sd₁ = ↧ p; sd₂ = ↧ q; sd₃ = ↧ r in - (n₁ ℤ.* sd₃) ℤ.* sd₂ ≡⟨ ℤ.*-assoc n₁ sd₃ sd₂ ⟩ - n₁ ℤ.* (sd₃ ℤ.* sd₂) ≡⟨ cong (n₁ ℤ.*_) (ℤ.*-comm sd₃ sd₂) ⟩ - n₁ ℤ.* (sd₂ ℤ.* sd₃) ≡⟨ sym (ℤ.*-assoc n₁ sd₂ sd₃) ⟩ - (n₁ ℤ.* sd₂) ℤ.* sd₃ ≤⟨ ℤ.*-monoʳ-≤-nonNeg (↧ r) p≤q ⟩ - (n₂ ℤ.* sd₁) ℤ.* sd₃ ≡⟨ cong (ℤ._* sd₃) (ℤ.*-comm n₂ sd₁) ⟩ - (sd₁ ℤ.* n₂) ℤ.* sd₃ ≡⟨ ℤ.*-assoc sd₁ n₂ sd₃ ⟩ - sd₁ ℤ.* (n₂ ℤ.* sd₃) <⟨ ℤ.*-monoˡ-<-pos (↧ p) q<r ⟩ - sd₁ ℤ.* (n₃ ℤ.* sd₂) ≡⟨ sym (ℤ.*-assoc sd₁ n₃ sd₂) ⟩ - (sd₁ ℤ.* n₃) ℤ.* sd₂ ≡⟨ cong (ℤ._* sd₂) (ℤ.*-comm sd₁ n₃) ⟩ - (n₃ ℤ.* sd₁) ℤ.* sd₂ ∎)) - where open ℤ.≤-Reasoning - -<-trans : Transitive _<_ -<-trans p<q = ≤-<-trans (<⇒≤ p<q) - -infix 4 _<?_ _>?_ - -_<?_ : Decidable _<_ -p <? q = Dec.map′ *<* drop-*<* ((↥ p ℤ.* ↧ q) ℤ.<? (↥ q ℤ.* ↧ p)) - -_>?_ : Decidable _>_ -_>?_ = flip _<?_ - -<-cmp : Trichotomous _≡_ _<_ -<-cmp p q with ℤ.<-cmp (↥ p ℤ.* ↧ q) (↥ q ℤ.* ↧ p) -... | tri< < ≢ ≯ = tri< (*<* <) (≢ ∘ ≡⇒≃) (≯ ∘ drop-*<*) -... | tri≈ ≮ ≡ ≯ = tri≈ (≮ ∘ drop-*<*) (≃⇒≡ ≡) (≯ ∘ drop-*<*) -... | tri> ≮ ≢ > = tri> (≮ ∘ drop-*<*) (≢ ∘ ≡⇒≃) (*<* >) - -<-irrelevant : Irrelevant _<_ -<-irrelevant (*<* p<q₁) (*<* p<q₂) = cong *<* (ℤ.<-irrelevant p<q₁ p<q₂) - -<-respʳ-≡ : _<_ Respectsʳ _≡_ -<-respʳ-≡ = subst (_ <_) - -<-respˡ-≡ : _<_ Respectsˡ _≡_ -<-respˡ-≡ = subst (_< _) - -<-resp-≡ : _<_ Respects₂ _≡_ -<-resp-≡ = <-respʳ-≡ , <-respˡ-≡ - ------------------------------------------------------------------------- --- Structures - -<-isStrictPartialOrder : IsStrictPartialOrder _≡_ _<_ -<-isStrictPartialOrder = record - { isEquivalence = isEquivalence - ; irrefl = <-irrefl - ; trans = <-trans - ; <-resp-≈ = <-resp-≡ - } - -<-isStrictTotalOrder : IsStrictTotalOrder _≡_ _<_ -<-isStrictTotalOrder = record - { isEquivalence = isEquivalence - ; trans = <-trans - ; compare = <-cmp - } - ------------------------------------------------------------------------- --- Bundles - -<-strictPartialOrder : StrictPartialOrder 0ℓ 0ℓ 0ℓ -<-strictPartialOrder = record - { isStrictPartialOrder = <-isStrictPartialOrder - } - -<-strictTotalOrder : StrictTotalOrder 0ℓ 0ℓ 0ℓ -<-strictTotalOrder = record - { isStrictTotalOrder = <-isStrictTotalOrder - } - ------------------------------------------------------------------------- --- A specialised module for reasoning about the _≤_ and _<_ relations ------------------------------------------------------------------------- - -module ≤-Reasoning where - import Relation.Binary.Reasoning.Base.Triple - ≤-isPreorder - <-trans - (resp₂ _<_) - <⇒≤ - <-≤-trans - ≤-<-trans - as Triple - open Triple public hiding (step-≈; step-≈˘) - - infixr 2 step-≃ step-≃˘ - - step-≃ = Triple.step-≈ - step-≃˘ = Triple.step-≈˘ - - syntax step-≃ x y∼z x≃y = x ≃⟨ x≃y ⟩ y∼z - syntax step-≃˘ x y∼z y≃x = x ≃˘⟨ y≃x ⟩ y∼z - - ------------------------------------------------------------------------- --- Properties of Positive/NonPositive/Negative/NonNegative and _≤_/_<_ - -positive⁻¹ : ∀ p → .{{Positive p}} → p > 0ℚ -positive⁻¹ p = toℚᵘ-cancel-< (ℚᵘ.positive⁻¹ (toℚᵘ p)) - -nonNegative⁻¹ : ∀ p → .{{NonNegative p}} → p ≥ 0ℚ -nonNegative⁻¹ p = toℚᵘ-cancel-≤ (ℚᵘ.nonNegative⁻¹ (toℚᵘ p)) - -negative⁻¹ : ∀ p → .{{Negative p}} → p < 0ℚ -negative⁻¹ p = toℚᵘ-cancel-< (ℚᵘ.negative⁻¹ (toℚᵘ p)) - -nonPositive⁻¹ : ∀ p → .{{NonPositive p}} → p ≤ 0ℚ -nonPositive⁻¹ p = toℚᵘ-cancel-≤ (ℚᵘ.nonPositive⁻¹ (toℚᵘ p)) - -neg<pos : ∀ p q → .{{Negative p}} → .{{Positive q}} → p < q -neg<pos p q = toℚᵘ-cancel-< (ℚᵘ.neg<pos (toℚᵘ p) (toℚᵘ q)) - ------------------------------------------------------------------------- --- Properties of -_ and _≤_/_<_ - -neg-antimono-< : -_ Preserves _<_ ⟶ _>_ -neg-antimono-< {mkℚ -[1+ _ ] _ _} {mkℚ -[1+ _ ] _ _} (*<* (ℤ.-<- n<m)) = *<* (ℤ.+<+ (ℕ.s<s n<m)) -neg-antimono-< {mkℚ -[1+ _ ] _ _} {mkℚ +0 _ _} (*<* ℤ.-<+) = *<* (ℤ.+<+ ℕ.z<s) -neg-antimono-< {mkℚ -[1+ _ ] _ _} {mkℚ +[1+ _ ] _ _} (*<* ℤ.-<+) = *<* ℤ.-<+ -neg-antimono-< {mkℚ +0 _ _} {mkℚ +0 _ _} (*<* (ℤ.+<+ m<n)) = *<* (ℤ.+<+ m<n) -neg-antimono-< {mkℚ +0 _ _} {mkℚ +[1+ _ ] _ _} (*<* (ℤ.+<+ m<n)) = *<* ℤ.-<+ -neg-antimono-< {mkℚ +[1+ _ ] _ _} {mkℚ +0 _ _} (*<* (ℤ.+<+ ())) -neg-antimono-< {mkℚ +[1+ _ ] _ _} {mkℚ +[1+ _ ] _ _} (*<* (ℤ.+<+ (ℕ.s<s m<n))) = *<* (ℤ.-<- m<n) - -neg-antimono-≤ : -_ Preserves _≤_ ⟶ _≥_ -neg-antimono-≤ {mkℚ -[1+ _ ] _ _} {mkℚ -[1+ _ ] _ _} (*≤* (ℤ.-≤- n≤m)) = *≤* (ℤ.+≤+ (ℕ.s≤s n≤m)) -neg-antimono-≤ {mkℚ -[1+ _ ] _ _} {mkℚ +0 _ _} (*≤* ℤ.-≤+) = *≤* (ℤ.+≤+ ℕ.z≤n) -neg-antimono-≤ {mkℚ -[1+ _ ] _ _} {mkℚ +[1+ _ ] _ _} (*≤* ℤ.-≤+) = *≤* ℤ.-≤+ -neg-antimono-≤ {mkℚ +0 _ _} {mkℚ +0 _ _} (*≤* (ℤ.+≤+ m≤n)) = *≤* (ℤ.+≤+ m≤n) -neg-antimono-≤ {mkℚ +0 _ _} {mkℚ +[1+ _ ] _ _} (*≤* (ℤ.+≤+ m≤n)) = *≤* ℤ.-≤+ -neg-antimono-≤ {mkℚ +[1+ _ ] _ _} {mkℚ +0 _ _} (*≤* (ℤ.+≤+ ())) -neg-antimono-≤ {mkℚ +[1+ _ ] _ _} {mkℚ +[1+ _ ] _ _} (*≤* (ℤ.+≤+ (ℕ.s≤s m≤n))) = *≤* (ℤ.-≤- m≤n) - ------------------------------------------------------------------------- --- Properties of _≤ᵇ_ ------------------------------------------------------------------------- - -≤ᵇ⇒≤ : T (p ≤ᵇ q) → p ≤ q -≤ᵇ⇒≤ = *≤* ∘′ ℤ.≤ᵇ⇒≤ - -≤⇒≤ᵇ : p ≤ q → T (p ≤ᵇ q) -≤⇒≤ᵇ = ℤ.≤⇒≤ᵇ ∘′ drop-*≤* - ------------------------------------------------------------------------- --- Properties of _+_ ------------------------------------------------------------------------- - -private - ↥+ᵘ : ℚ → ℚ → ℤ - ↥+ᵘ p q = ↥ p ℤ.* ↧ q ℤ.+ ↥ q ℤ.* ↧ p - - ↧+ᵘ : ℚ → ℚ → ℤ - ↧+ᵘ p q = ↧ p ℤ.* ↧ q - - +-nf : ℚ → ℚ → ℤ - +-nf p q = gcd (↥+ᵘ p q) (↧+ᵘ p q) - -↥-+ : ∀ p q → ↥ (p + q) ℤ.* +-nf p q ≡ ↥+ᵘ p q -↥-+ p@record{} q@record{} = ↥-/ (↥+ᵘ p q) (↧ₙ p ℕ.* ↧ₙ q) - -↧-+ : ∀ p q → ↧ (p + q) ℤ.* +-nf p q ≡ ↧+ᵘ p q -↧-+ p@record{} q@record{} = ↧-/ (↥+ᵘ p q) (↧ₙ p ℕ.* ↧ₙ q) - - ------------------------------------------------------------------------- --- Monomorphic to unnormalised _+_ - -open Definitions ℚ ℚᵘ ℚᵘ._≃_ - -toℚᵘ-homo-+ : Homomorphic₂ toℚᵘ _+_ ℚᵘ._+_ -toℚᵘ-homo-+ p@record{} q@record{} with +-nf p q ℤ.≟ 0ℤ -... | yes nf[p,q]≡0 = *≡* $ begin - ↥ᵘ (toℚᵘ (p + q)) ℤ.* ↧+ᵘ p q ≡⟨ cong (ℤ._* ↧+ᵘ p q) (↥ᵘ-toℚᵘ (p + q)) ⟩ - ↥ (p + q) ℤ.* ↧+ᵘ p q ≡⟨ cong (ℤ._* ↧+ᵘ p q) eq ⟩ - 0ℤ ℤ.* ↧+ᵘ p q ≡⟨⟩ - 0ℤ ℤ.* ↧ (p + q) ≡⟨ cong (ℤ._* ↧ (p + q)) (sym eq2) ⟩ - ↥+ᵘ p q ℤ.* ↧ (p + q) ≡⟨ cong (↥+ᵘ p q ℤ.*_) (sym (↧ᵘ-toℚᵘ (p + q))) ⟩ - ↥+ᵘ p q ℤ.* ↧ᵘ (toℚᵘ (p + q)) ∎ - where - open ≡-Reasoning - eq2 : ↥+ᵘ p q ≡ 0ℤ - eq2 = gcd[i,j]≡0⇒i≡0 (↥+ᵘ p q) (↧+ᵘ p q) nf[p,q]≡0 +-- Properties of _<_ +------------------------------------------------------------------------ + +drop-*<* : p < q → (↥ p ℤ.* ↧ q) ℤ.< (↥ q ℤ.* ↧ p) +drop-*<* (*<* pq<qp) = pq<qp + +------------------------------------------------------------------------ +-- toℚᵘ is a isomorphism + +toℚᵘ-mono-< : p < q → toℚᵘ p <ᵘ toℚᵘ q +toℚᵘ-mono-< {p@record{}} {q@record{}} (*<* p<q) = *<* p<q + +toℚᵘ-cancel-< : toℚᵘ p <ᵘ toℚᵘ q → p < q +toℚᵘ-cancel-< {p@record{}} {q@record{}} (*<* p<q) = *<* p<q + +toℚᵘ-isOrderHomomorphism-< : IsOrderHomomorphism _≡_ _≃ᵘ_ _<_ _<ᵘ_ toℚᵘ +toℚᵘ-isOrderHomomorphism-< = record + { cong = toℚᵘ-cong + ; mono = toℚᵘ-mono-< + } + +toℚᵘ-isOrderMonomorphism-< : IsOrderMonomorphism _≡_ _≃ᵘ_ _<_ _<ᵘ_ toℚᵘ +toℚᵘ-isOrderMonomorphism-< = record + { isOrderHomomorphism = toℚᵘ-isOrderHomomorphism-< + ; injective = toℚᵘ-injective + ; cancel = toℚᵘ-cancel-< + } + +------------------------------------------------------------------------ +-- Relational properties + +<⇒≤ : _<_ ⇒ _≤_ +<⇒≤ (*<* p<q) = *≤* (ℤ.<⇒≤ p<q) + +≮⇒≥ : _≮_ ⇒ _≥_ +≮⇒≥ {p} {q} p≮q = *≤* (ℤ.≮⇒≥ (p≮q ∘ *<*)) + +≰⇒> : _≰_ ⇒ _>_ +≰⇒> {p} {q} p≰q = *<* (ℤ.≰⇒> (p≰q ∘ *≤*)) + +<⇒≢ : _<_ ⇒ _≢_ +<⇒≢ {p} {q} (*<* p<q) = ℤ.<⇒≢ p<q ∘ drop-*≡* ∘ ≡⇒≃ + +<-irrefl : Irreflexive _≡_ _<_ +<-irrefl refl (*<* p<p) = ℤ.<-irrefl refl p<p + +<-asym : Asymmetric _<_ +<-asym (*<* p<q) (*<* q<p) = ℤ.<-asym p<q q<p + +<-dense : Dense _<_ +<-dense {p} {q} p<q = let + m , p<ᵘm , m<ᵘq = ℚᵘ.<-dense (toℚᵘ-mono-< p<q) + + m≃m : m ≃ᵘ toℚᵘ (fromℚᵘ m) + m≃m = ℚᵘ.≃-sym (toℚᵘ-fromℚᵘ m) + + p<m : p < fromℚᵘ m + p<m = toℚᵘ-cancel-< (ℚᵘ.<-respʳ-≃ m≃m p<ᵘm) + + m<q : fromℚᵘ m < q + m<q = toℚᵘ-cancel-< (ℚᵘ.<-respˡ-≃ m≃m m<ᵘq) + in fromℚᵘ m , p<m , m<q + +<-≤-trans : Trans _<_ _≤_ _<_ +<-≤-trans {p} {q} {r} (*<* p<q) (*≤* q≤r) = *<* + (ℤ.*-cancelʳ-<-nonNeg _ (begin-strict + let n₁ = ↥ p; n₂ = ↥ q; n₃ = ↥ r; sd₁ = ↧ p; sd₂ = ↧ q; sd₃ = ↧ r in + (n₁ ℤ.* sd₃) ℤ.* sd₂ ≡⟨ ℤ.*-assoc n₁ sd₃ sd₂ ⟩ + n₁ ℤ.* (sd₃ ℤ.* sd₂) ≡⟨ cong (n₁ ℤ.*_) (ℤ.*-comm sd₃ sd₂) ⟩ + n₁ ℤ.* (sd₂ ℤ.* sd₃) ≡⟨ sym (ℤ.*-assoc n₁ sd₂ sd₃) ⟩ + (n₁ ℤ.* sd₂) ℤ.* sd₃ <⟨ ℤ.*-monoʳ-<-pos (↧ r) p<q ⟩ + (n₂ ℤ.* sd₁) ℤ.* sd₃ ≡⟨ cong (ℤ._* sd₃) (ℤ.*-comm n₂ sd₁) ⟩ + (sd₁ ℤ.* n₂) ℤ.* sd₃ ≡⟨ ℤ.*-assoc sd₁ n₂ sd₃ ⟩ + sd₁ ℤ.* (n₂ ℤ.* sd₃) ≤⟨ ℤ.*-monoˡ-≤-nonNeg (↧ p) q≤r ⟩ + sd₁ ℤ.* (n₃ ℤ.* sd₂) ≡⟨ sym (ℤ.*-assoc sd₁ n₃ sd₂) ⟩ + (sd₁ ℤ.* n₃) ℤ.* sd₂ ≡⟨ cong (ℤ._* sd₂) (ℤ.*-comm sd₁ n₃) ⟩ + (n₃ ℤ.* sd₁) ℤ.* sd₂ ∎)) + where open ℤ.≤-Reasoning + +≤-<-trans : Trans _≤_ _<_ _<_ +≤-<-trans {p} {q} {r} (*≤* p≤q) (*<* q<r) = *<* + (ℤ.*-cancelʳ-<-nonNeg _ (begin-strict + let n₁ = ↥ p; n₂ = ↥ q; n₃ = ↥ r; sd₁ = ↧ p; sd₂ = ↧ q; sd₃ = ↧ r in + (n₁ ℤ.* sd₃) ℤ.* sd₂ ≡⟨ ℤ.*-assoc n₁ sd₃ sd₂ ⟩ + n₁ ℤ.* (sd₃ ℤ.* sd₂) ≡⟨ cong (n₁ ℤ.*_) (ℤ.*-comm sd₃ sd₂) ⟩ + n₁ ℤ.* (sd₂ ℤ.* sd₃) ≡⟨ sym (ℤ.*-assoc n₁ sd₂ sd₃) ⟩ + (n₁ ℤ.* sd₂) ℤ.* sd₃ ≤⟨ ℤ.*-monoʳ-≤-nonNeg (↧ r) p≤q ⟩ + (n₂ ℤ.* sd₁) ℤ.* sd₃ ≡⟨ cong (ℤ._* sd₃) (ℤ.*-comm n₂ sd₁) ⟩ + (sd₁ ℤ.* n₂) ℤ.* sd₃ ≡⟨ ℤ.*-assoc sd₁ n₂ sd₃ ⟩ + sd₁ ℤ.* (n₂ ℤ.* sd₃) <⟨ ℤ.*-monoˡ-<-pos (↧ p) q<r ⟩ + sd₁ ℤ.* (n₃ ℤ.* sd₂) ≡⟨ sym (ℤ.*-assoc sd₁ n₃ sd₂) ⟩ + (sd₁ ℤ.* n₃) ℤ.* sd₂ ≡⟨ cong (ℤ._* sd₂) (ℤ.*-comm sd₁ n₃) ⟩ + (n₃ ℤ.* sd₁) ℤ.* sd₂ ∎)) + where open ℤ.≤-Reasoning + +<-trans : Transitive _<_ +<-trans p<q = ≤-<-trans (<⇒≤ p<q) + +infix 4 _<?_ _>?_ + +_<?_ : Decidable _<_ +p <? q = Dec.map′ *<* drop-*<* ((↥ p ℤ.* ↧ q) ℤ.<? (↥ q ℤ.* ↧ p)) + +_>?_ : Decidable _>_ +_>?_ = flip _<?_ + +<-cmp : Trichotomous _≡_ _<_ +<-cmp p q with ℤ.<-cmp (↥ p ℤ.* ↧ q) (↥ q ℤ.* ↧ p) +... | tri< < ≢ ≯ = tri< (*<* <) (≢ ∘ drop-*≡* ∘ ≡⇒≃) (≯ ∘ drop-*<*) +... | tri≈ ≮ ≡ ≯ = tri≈ (≮ ∘ drop-*<*) (≃⇒≡ (*≡* ≡)) (≯ ∘ drop-*<*) +... | tri> ≮ ≢ > = tri> (≮ ∘ drop-*<*) (≢ ∘ drop-*≡* ∘ ≡⇒≃) (*<* >) + +<-irrelevant : Irrelevant _<_ +<-irrelevant (*<* p<q₁) (*<* p<q₂) = cong *<* (ℤ.<-irrelevant p<q₁ p<q₂) + +<-respʳ-≡ : _<_ Respectsʳ _≡_ +<-respʳ-≡ = subst (_ <_) + +<-respˡ-≡ : _<_ Respectsˡ _≡_ +<-respˡ-≡ = subst (_< _) + +<-resp-≡ : _<_ Respects₂ _≡_ +<-resp-≡ = <-respʳ-≡ , <-respˡ-≡ + +------------------------------------------------------------------------ +-- Structures + +<-isStrictPartialOrder : IsStrictPartialOrder _≡_ _<_ +<-isStrictPartialOrder = record + { isEquivalence = isEquivalence + ; irrefl = <-irrefl + ; trans = <-trans + ; <-resp-≈ = <-resp-≡ + } + +<-isStrictTotalOrder : IsStrictTotalOrder _≡_ _<_ +<-isStrictTotalOrder = record + { isStrictPartialOrder = <-isStrictPartialOrder + ; compare = <-cmp + } + +<-isDenseLinearOrder : IsDenseLinearOrder _≡_ _<_ +<-isDenseLinearOrder = record + { isStrictTotalOrder = <-isStrictTotalOrder + ; dense = <-dense + } + +------------------------------------------------------------------------ +-- Bundles + +<-strictPartialOrder : StrictPartialOrder 0ℓ 0ℓ 0ℓ +<-strictPartialOrder = record + { isStrictPartialOrder = <-isStrictPartialOrder + } + +<-strictTotalOrder : StrictTotalOrder 0ℓ 0ℓ 0ℓ +<-strictTotalOrder = record + { isStrictTotalOrder = <-isStrictTotalOrder + } + +<-denseLinearOrder : DenseLinearOrder 0ℓ 0ℓ 0ℓ +<-denseLinearOrder = record + { isDenseLinearOrder = <-isDenseLinearOrder + } + +------------------------------------------------------------------------ +-- A specialised module for reasoning about the _≤_ and _<_ relations +------------------------------------------------------------------------ + +module ≤-Reasoning where + import Relation.Binary.Reasoning.Base.Triple + ≤-isPreorder + <-asym + <-trans + (resp₂ _<_) + <⇒≤ + <-≤-trans + ≤-<-trans + as Triple + + open Triple public + hiding (step-≈; step-≈˘; step-≈-⟩; step-≈-⟨) + + ≃-go : Trans _≃_ _IsRelatedTo_ _IsRelatedTo_ + ≃-go = Triple.≈-go ∘′ ≃⇒≡ + + open ≃-syntax _IsRelatedTo_ _IsRelatedTo_ ≃-go (λ {x y} → ≃-sym {x} {y}) public + +------------------------------------------------------------------------ +-- Properties of Positive/NonPositive/Negative/NonNegative and _≤_/_<_ + +positive⁻¹ : ∀ p → .{{Positive p}} → p > 0ℚ +positive⁻¹ p = toℚᵘ-cancel-< (ℚᵘ.positive⁻¹ (toℚᵘ p)) + +nonNegative⁻¹ : ∀ p → .{{NonNegative p}} → p ≥ 0ℚ +nonNegative⁻¹ p = toℚᵘ-cancel-≤ (ℚᵘ.nonNegative⁻¹ (toℚᵘ p)) + +negative⁻¹ : ∀ p → .{{Negative p}} → p < 0ℚ +negative⁻¹ p = toℚᵘ-cancel-< (ℚᵘ.negative⁻¹ (toℚᵘ p)) + +nonPositive⁻¹ : ∀ p → .{{NonPositive p}} → p ≤ 0ℚ +nonPositive⁻¹ p = toℚᵘ-cancel-≤ (ℚᵘ.nonPositive⁻¹ (toℚᵘ p)) + +neg<pos : ∀ p q → .{{Negative p}} → .{{Positive q}} → p < q +neg<pos p q = toℚᵘ-cancel-< (ℚᵘ.neg<pos (toℚᵘ p) (toℚᵘ q)) + +------------------------------------------------------------------------ +-- Properties of -_ and _≤_/_<_ + +neg-antimono-< : -_ Preserves _<_ ⟶ _>_ +neg-antimono-< {mkℚ -[1+ _ ] _ _} {mkℚ -[1+ _ ] _ _} (*<* (ℤ.-<- n<m)) = *<* (ℤ.+<+ (ℕ.s<s n<m)) +neg-antimono-< {mkℚ -[1+ _ ] _ _} {mkℚ +0 _ _} (*<* ℤ.-<+) = *<* (ℤ.+<+ ℕ.z<s) +neg-antimono-< {mkℚ -[1+ _ ] _ _} {mkℚ +[1+ _ ] _ _} (*<* ℤ.-<+) = *<* ℤ.-<+ +neg-antimono-< {mkℚ +0 _ _} {mkℚ +0 _ _} (*<* (ℤ.+<+ m<n)) = *<* (ℤ.+<+ m<n) +neg-antimono-< {mkℚ +0 _ _} {mkℚ +[1+ _ ] _ _} (*<* (ℤ.+<+ m<n)) = *<* ℤ.-<+ +neg-antimono-< {mkℚ +[1+ _ ] _ _} {mkℚ +0 _ _} (*<* (ℤ.+<+ ())) +neg-antimono-< {mkℚ +[1+ _ ] _ _} {mkℚ +[1+ _ ] _ _} (*<* (ℤ.+<+ (ℕ.s<s m<n))) = *<* (ℤ.-<- m<n) + +neg-antimono-≤ : -_ Preserves _≤_ ⟶ _≥_ +neg-antimono-≤ {mkℚ -[1+ _ ] _ _} {mkℚ -[1+ _ ] _ _} (*≤* (ℤ.-≤- n≤m)) = *≤* (ℤ.+≤+ (ℕ.s≤s n≤m)) +neg-antimono-≤ {mkℚ -[1+ _ ] _ _} {mkℚ +0 _ _} (*≤* ℤ.-≤+) = *≤* (ℤ.+≤+ ℕ.z≤n) +neg-antimono-≤ {mkℚ -[1+ _ ] _ _} {mkℚ +[1+ _ ] _ _} (*≤* ℤ.-≤+) = *≤* ℤ.-≤+ +neg-antimono-≤ {mkℚ +0 _ _} {mkℚ +0 _ _} (*≤* (ℤ.+≤+ m≤n)) = *≤* (ℤ.+≤+ m≤n) +neg-antimono-≤ {mkℚ +0 _ _} {mkℚ +[1+ _ ] _ _} (*≤* (ℤ.+≤+ m≤n)) = *≤* ℤ.-≤+ +neg-antimono-≤ {mkℚ +[1+ _ ] _ _} {mkℚ +0 _ _} (*≤* (ℤ.+≤+ ())) +neg-antimono-≤ {mkℚ +[1+ _ ] _ _} {mkℚ +[1+ _ ] _ _} (*≤* (ℤ.+≤+ (ℕ.s≤s m≤n))) = *≤* (ℤ.-≤- m≤n) + +------------------------------------------------------------------------ +-- Properties of _≤ᵇ_ +------------------------------------------------------------------------ + +≤ᵇ⇒≤ : T (p ≤ᵇ q) → p ≤ q +≤ᵇ⇒≤ = *≤* ∘′ ℤ.≤ᵇ⇒≤ + +≤⇒≤ᵇ : p ≤ q → T (p ≤ᵇ q) +≤⇒≤ᵇ = ℤ.≤⇒≤ᵇ ∘′ drop-*≤* + +------------------------------------------------------------------------ +-- Properties of _+_ +------------------------------------------------------------------------ + +private + ↥+ᵘ : ℚ → ℚ → ℤ + ↥+ᵘ p q = ↥ p ℤ.* ↧ q ℤ.+ ↥ q ℤ.* ↧ p + + ↧+ᵘ : ℚ → ℚ → ℤ + ↧+ᵘ p q = ↧ p ℤ.* ↧ q + + +-nf : ℚ → ℚ → ℤ + +-nf p q = gcd (↥+ᵘ p q) (↧+ᵘ p q) + +↥-+ : ∀ p q → ↥ (p + q) ℤ.* +-nf p q ≡ ↥+ᵘ p q +↥-+ p@record{} q@record{} = ↥-/ (↥+ᵘ p q) (↧ₙ p ℕ.* ↧ₙ q) + +↧-+ : ∀ p q → ↧ (p + q) ℤ.* +-nf p q ≡ ↧+ᵘ p q +↧-+ p@record{} q@record{} = ↧-/ (↥+ᵘ p q) (↧ₙ p ℕ.* ↧ₙ q) + + +------------------------------------------------------------------------ +-- Monomorphic to unnormalised _+_ + +open Definitions ℚ ℚᵘ ℚᵘ._≃_ + +toℚᵘ-homo-+ : Homomorphic₂ toℚᵘ _+_ ℚᵘ._+_ +toℚᵘ-homo-+ p@record{} q@record{} with +-nf p q ℤ.≟ 0ℤ +... | yes nf[p,q]≡0 = *≡* $ begin + ↥ᵘ (toℚᵘ (p + q)) ℤ.* ↧+ᵘ p q ≡⟨ cong (ℤ._* ↧+ᵘ p q) (↥ᵘ-toℚᵘ (p + q)) ⟩ + ↥ (p + q) ℤ.* ↧+ᵘ p q ≡⟨ cong (ℤ._* ↧+ᵘ p q) eq ⟩ + 0ℤ ℤ.* ↧+ᵘ p q ≡⟨⟩ + 0ℤ ℤ.* ↧ (p + q) ≡⟨ cong (ℤ._* ↧ (p + q)) (sym eq2) ⟩ + ↥+ᵘ p q ℤ.* ↧ (p + q) ≡⟨ cong (↥+ᵘ p q ℤ.*_) (sym (↧ᵘ-toℚᵘ (p + q))) ⟩ + ↥+ᵘ p q ℤ.* ↧ᵘ (toℚᵘ (p + q)) ∎ + where + open ≡-Reasoning + eq2 : ↥+ᵘ p q ≡ 0ℤ + eq2 = gcd[i,j]≡0⇒i≡0 (↥+ᵘ p q) (↧+ᵘ p q) nf[p,q]≡0 - eq : ↥ (p + q) ≡ 0ℤ - eq rewrite eq2 = cong ↥_ (0/n≡0 (↧ₙ p ℕ.* ↧ₙ q)) + eq : ↥ (p + q) ≡ 0ℤ + eq rewrite eq2 = cong ↥_ (0/n≡0 (↧ₙ p ℕ.* ↧ₙ q)) -... | no nf[p,q]≢0 = *≡* $ ℤ.*-cancelʳ-≡ _ _ (+-nf p q) {{ℤ.≢-nonZero nf[p,q]≢0}} $ begin - (↥ᵘ (toℚᵘ (p + q))) ℤ.* ↧+ᵘ p q ℤ.* +-nf p q ≡⟨ cong (λ v → v ℤ.* ↧+ᵘ p q ℤ.* +-nf p q) (↥ᵘ-toℚᵘ (p + q)) ⟩ - ↥ (p + q) ℤ.* ↧+ᵘ p q ℤ.* +-nf p q ≡⟨ xy∙z≈xz∙y (↥ (p + q)) _ _ ⟩ - ↥ (p + q) ℤ.* +-nf p q ℤ.* ↧+ᵘ p q ≡⟨ cong (ℤ._* ↧+ᵘ p q) (↥-+ p q) ⟩ - ↥+ᵘ p q ℤ.* ↧+ᵘ p q ≡⟨ cong (↥+ᵘ p q ℤ.*_) (sym (↧-+ p q)) ⟩ - ↥+ᵘ p q ℤ.* (↧ (p + q) ℤ.* +-nf p q) ≡⟨ x∙yz≈xy∙z (↥+ᵘ p q) _ _ ⟩ - ↥+ᵘ p q ℤ.* ↧ (p + q) ℤ.* +-nf p q ≡˘⟨ cong (λ v → ↥+ᵘ p q ℤ.* v ℤ.* +-nf p q) (↧ᵘ-toℚᵘ (p + q)) ⟩ - ↥+ᵘ p q ℤ.* ↧ᵘ (toℚᵘ (p + q)) ℤ.* +-nf p q ∎ - where open ≡-Reasoning; open CommSemigroupProperties ℤ.*-commutativeSemigroup +... | no nf[p,q]≢0 = *≡* (ℤ.*-cancelʳ-≡ _ _ (+-nf p q) {{ℤ.≢-nonZero nf[p,q]≢0}} $ begin + (↥ᵘ (toℚᵘ (p + q))) ℤ.* ↧+ᵘ p q ℤ.* +-nf p q ≡⟨ cong (λ v → v ℤ.* ↧+ᵘ p q ℤ.* +-nf p q) (↥ᵘ-toℚᵘ (p + q)) ⟩ + ↥ (p + q) ℤ.* ↧+ᵘ p q ℤ.* +-nf p q ≡⟨ xy∙z≈xz∙y (↥ (p + q)) _ _ ⟩ + ↥ (p + q) ℤ.* +-nf p q ℤ.* ↧+ᵘ p q ≡⟨ cong (ℤ._* ↧+ᵘ p q) (↥-+ p q) ⟩ + ↥+ᵘ p q ℤ.* ↧+ᵘ p q ≡⟨ cong (↥+ᵘ p q ℤ.*_) (sym (↧-+ p q)) ⟩ + ↥+ᵘ p q ℤ.* (↧ (p + q) ℤ.* +-nf p q) ≡⟨ x∙yz≈xy∙z (↥+ᵘ p q) _ _ ⟩ + ↥+ᵘ p q ℤ.* ↧ (p + q) ℤ.* +-nf p q ≡⟨ cong (λ v → ↥+ᵘ p q ℤ.* v ℤ.* +-nf p q) (↧ᵘ-toℚᵘ (p + q)) ⟨ + ↥+ᵘ p q ℤ.* ↧ᵘ (toℚᵘ (p + q)) ℤ.* +-nf p q ∎) + where open ≡-Reasoning; open CommSemigroupProperties ℤ.*-commutativeSemigroup -toℚᵘ-isMagmaHomomorphism-+ : IsMagmaHomomorphism +-rawMagma ℚᵘ.+-rawMagma toℚᵘ -toℚᵘ-isMagmaHomomorphism-+ = record - { isRelHomomorphism = toℚᵘ-isRelHomomorphism - ; homo = toℚᵘ-homo-+ - } +toℚᵘ-isMagmaHomomorphism-+ : IsMagmaHomomorphism +-rawMagma ℚᵘ.+-rawMagma toℚᵘ +toℚᵘ-isMagmaHomomorphism-+ = record + { isRelHomomorphism = toℚᵘ-isRelHomomorphism + ; homo = toℚᵘ-homo-+ + } -toℚᵘ-isMonoidHomomorphism-+ : IsMonoidHomomorphism +-0-rawMonoid ℚᵘ.+-0-rawMonoid toℚᵘ -toℚᵘ-isMonoidHomomorphism-+ = record - { isMagmaHomomorphism = toℚᵘ-isMagmaHomomorphism-+ - ; ε-homo = ℚᵘ.≃-refl - } - -toℚᵘ-isMonoidMonomorphism-+ : IsMonoidMonomorphism +-0-rawMonoid ℚᵘ.+-0-rawMonoid toℚᵘ -toℚᵘ-isMonoidMonomorphism-+ = record - { isMonoidHomomorphism = toℚᵘ-isMonoidHomomorphism-+ - ; injective = toℚᵘ-injective - } - ------------------------------------------------------------------------- --- Monomorphic to unnormalised -_ - -toℚᵘ-homo‿- : Homomorphic₁ toℚᵘ (-_) (ℚᵘ.-_) -toℚᵘ-homo‿- (mkℚ +0 _ _) = *≡* refl -toℚᵘ-homo‿- (mkℚ +[1+ _ ] _ _) = *≡* refl -toℚᵘ-homo‿- (mkℚ -[1+ _ ] _ _) = *≡* refl - -toℚᵘ-isGroupHomomorphism-+ : IsGroupHomomorphism +-0-rawGroup ℚᵘ.+-0-rawGroup toℚᵘ -toℚᵘ-isGroupHomomorphism-+ = record - { isMonoidHomomorphism = toℚᵘ-isMonoidHomomorphism-+ - ; ⁻¹-homo = toℚᵘ-homo‿- - } +toℚᵘ-isMonoidHomomorphism-+ : IsMonoidHomomorphism +-0-rawMonoid ℚᵘ.+-0-rawMonoid toℚᵘ +toℚᵘ-isMonoidHomomorphism-+ = record + { isMagmaHomomorphism = toℚᵘ-isMagmaHomomorphism-+ + ; ε-homo = ℚᵘ.≃-refl + } + +toℚᵘ-isMonoidMonomorphism-+ : IsMonoidMonomorphism +-0-rawMonoid ℚᵘ.+-0-rawMonoid toℚᵘ +toℚᵘ-isMonoidMonomorphism-+ = record + { isMonoidHomomorphism = toℚᵘ-isMonoidHomomorphism-+ + ; injective = toℚᵘ-injective + } + +------------------------------------------------------------------------ +-- Monomorphic to unnormalised -_ + +toℚᵘ-homo‿- : Homomorphic₁ toℚᵘ (-_) (ℚᵘ.-_) +toℚᵘ-homo‿- (mkℚ +0 _ _) = *≡* refl +toℚᵘ-homo‿- (mkℚ +[1+ _ ] _ _) = *≡* refl +toℚᵘ-homo‿- (mkℚ -[1+ _ ] _ _) = *≡* refl + +toℚᵘ-isGroupHomomorphism-+ : IsGroupHomomorphism +-0-rawGroup ℚᵘ.+-0-rawGroup toℚᵘ +toℚᵘ-isGroupHomomorphism-+ = record + { isMonoidHomomorphism = toℚᵘ-isMonoidHomomorphism-+ + ; ⁻¹-homo = toℚᵘ-homo‿- + } -toℚᵘ-isGroupMonomorphism-+ : IsGroupMonomorphism +-0-rawGroup ℚᵘ.+-0-rawGroup toℚᵘ -toℚᵘ-isGroupMonomorphism-+ = record - { isGroupHomomorphism = toℚᵘ-isGroupHomomorphism-+ - ; injective = toℚᵘ-injective - } - ------------------------------------------------------------------------- --- Algebraic properties +toℚᵘ-isGroupMonomorphism-+ : IsGroupMonomorphism +-0-rawGroup ℚᵘ.+-0-rawGroup toℚᵘ +toℚᵘ-isGroupMonomorphism-+ = record + { isGroupHomomorphism = toℚᵘ-isGroupHomomorphism-+ + ; injective = toℚᵘ-injective + } + +------------------------------------------------------------------------ +-- Algebraic properties -private - module +-Monomorphism = GroupMonomorphisms toℚᵘ-isGroupMonomorphism-+ +private + module +-Monomorphism = GroupMonomorphisms toℚᵘ-isGroupMonomorphism-+ -+-assoc : Associative _+_ -+-assoc = +-Monomorphism.assoc ℚᵘ.+-isMagma ℚᵘ.+-assoc ++-assoc : Associative _+_ ++-assoc = +-Monomorphism.assoc ℚᵘ.+-isMagma ℚᵘ.+-assoc -+-comm : Commutative _+_ -+-comm = +-Monomorphism.comm ℚᵘ.+-isMagma ℚᵘ.+-comm ++-comm : Commutative _+_ ++-comm = +-Monomorphism.comm ℚᵘ.+-isMagma ℚᵘ.+-comm -+-identityˡ : LeftIdentity 0ℚ _+_ -+-identityˡ = +-Monomorphism.identityˡ ℚᵘ.+-isMagma ℚᵘ.+-identityˡ - -+-identityʳ : RightIdentity 0ℚ _+_ -+-identityʳ = +-Monomorphism.identityʳ ℚᵘ.+-isMagma ℚᵘ.+-identityʳ - -+-identity : Identity 0ℚ _+_ -+-identity = +-identityˡ , +-identityʳ - -+-inverseˡ : LeftInverse 0ℚ -_ _+_ -+-inverseˡ = +-Monomorphism.inverseˡ ℚᵘ.+-isMagma ℚᵘ.+-inverseˡ - -+-inverseʳ : RightInverse 0ℚ -_ _+_ -+-inverseʳ = +-Monomorphism.inverseʳ ℚᵘ.+-isMagma ℚᵘ.+-inverseʳ - -+-inverse : Inverse 0ℚ -_ _+_ -+-inverse = +-Monomorphism.inverse ℚᵘ.+-isMagma ℚᵘ.+-inverse - --‿cong : Congruent₁ (-_) --‿cong = +-Monomorphism.⁻¹-cong ℚᵘ.+-isMagma ℚᵘ.-‿cong - -neg-distrib-+ : ∀ p q → - (p + q) ≡ (- p) + (- q) -neg-distrib-+ = +-Monomorphism.⁻¹-distrib-∙ ℚᵘ.+-0-isAbelianGroup (ℚᵘ.≃-reflexive ∘₂ ℚᵘ.neg-distrib-+) - ------------------------------------------------------------------------- --- Structures - -+-isMagma : IsMagma _+_ -+-isMagma = +-Monomorphism.isMagma ℚᵘ.+-isMagma - -+-isSemigroup : IsSemigroup _+_ -+-isSemigroup = +-Monomorphism.isSemigroup ℚᵘ.+-isSemigroup ++-identityˡ : LeftIdentity 0ℚ _+_ ++-identityˡ = +-Monomorphism.identityˡ ℚᵘ.+-isMagma ℚᵘ.+-identityˡ + ++-identityʳ : RightIdentity 0ℚ _+_ ++-identityʳ = +-Monomorphism.identityʳ ℚᵘ.+-isMagma ℚᵘ.+-identityʳ + ++-identity : Identity 0ℚ _+_ ++-identity = +-identityˡ , +-identityʳ + ++-inverseˡ : LeftInverse 0ℚ -_ _+_ ++-inverseˡ = +-Monomorphism.inverseˡ ℚᵘ.+-isMagma ℚᵘ.+-inverseˡ + ++-inverseʳ : RightInverse 0ℚ -_ _+_ ++-inverseʳ = +-Monomorphism.inverseʳ ℚᵘ.+-isMagma ℚᵘ.+-inverseʳ + ++-inverse : Inverse 0ℚ -_ _+_ ++-inverse = +-Monomorphism.inverse ℚᵘ.+-isMagma ℚᵘ.+-inverse + +-‿cong : Congruent₁ (-_) +-‿cong = +-Monomorphism.⁻¹-cong ℚᵘ.+-isMagma ℚᵘ.-‿cong + +neg-distrib-+ : ∀ p q → - (p + q) ≡ (- p) + (- q) +neg-distrib-+ = +-Monomorphism.⁻¹-distrib-∙ ℚᵘ.+-0-isAbelianGroup (ℚᵘ.≃-reflexive ∘₂ ℚᵘ.neg-distrib-+) + +------------------------------------------------------------------------ +-- Structures + ++-isMagma : IsMagma _+_ ++-isMagma = +-Monomorphism.isMagma ℚᵘ.+-isMagma + ++-isSemigroup : IsSemigroup _+_ ++-isSemigroup = +-Monomorphism.isSemigroup ℚᵘ.+-isSemigroup -+-0-isMonoid : IsMonoid _+_ 0ℚ -+-0-isMonoid = +-Monomorphism.isMonoid ℚᵘ.+-0-isMonoid ++-0-isMonoid : IsMonoid _+_ 0ℚ ++-0-isMonoid = +-Monomorphism.isMonoid ℚᵘ.+-0-isMonoid -+-0-isCommutativeMonoid : IsCommutativeMonoid _+_ 0ℚ -+-0-isCommutativeMonoid = +-Monomorphism.isCommutativeMonoid ℚᵘ.+-0-isCommutativeMonoid ++-0-isCommutativeMonoid : IsCommutativeMonoid _+_ 0ℚ ++-0-isCommutativeMonoid = +-Monomorphism.isCommutativeMonoid ℚᵘ.+-0-isCommutativeMonoid -+-0-isGroup : IsGroup _+_ 0ℚ (-_) -+-0-isGroup = +-Monomorphism.isGroup ℚᵘ.+-0-isGroup - -+-0-isAbelianGroup : IsAbelianGroup _+_ 0ℚ (-_) -+-0-isAbelianGroup = +-Monomorphism.isAbelianGroup ℚᵘ.+-0-isAbelianGroup - ------------------------------------------------------------------------- --- Packages - -+-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 _+_ and _≤_ - -+-mono-≤ : _+_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ -+-mono-≤ {p} {q} {r} {s} p≤q r≤s = toℚᵘ-cancel-≤ (begin - toℚᵘ(p + r) ≃⟨ toℚᵘ-homo-+ p r ⟩ - toℚᵘ(p) ℚᵘ.+ toℚᵘ(r) ≤⟨ ℚᵘ.+-mono-≤ (toℚᵘ-mono-≤ p≤q) (toℚᵘ-mono-≤ r≤s) ⟩ - toℚᵘ(q) ℚᵘ.+ toℚᵘ(s) ≃⟨ ℚᵘ.≃-sym (toℚᵘ-homo-+ q s) ⟩ - toℚᵘ(q + s) ∎) - where open ℚᵘ.≤-Reasoning - -+-monoˡ-≤ : ∀ r → (_+ r) Preserves _≤_ ⟶ _≤_ -+-monoˡ-≤ r p≤q = +-mono-≤ p≤q (≤-refl {r}) - -+-monoʳ-≤ : ∀ r → (_+_ r) Preserves _≤_ ⟶ _≤_ -+-monoʳ-≤ r p≤q = +-mono-≤ (≤-refl {r}) p≤q - ------------------------------------------------------------------------- --- Properties of _+_ and _<_ - -+-mono-<-≤ : _+_ Preserves₂ _<_ ⟶ _≤_ ⟶ _<_ -+-mono-<-≤ {p} {q} {r} {s} p<q r≤s = toℚᵘ-cancel-< (begin-strict - toℚᵘ(p + r) ≃⟨ toℚᵘ-homo-+ p r ⟩ - toℚᵘ(p) ℚᵘ.+ toℚᵘ(r) <⟨ ℚᵘ.+-mono-<-≤ (toℚᵘ-mono-< p<q) (toℚᵘ-mono-≤ r≤s) ⟩ - toℚᵘ(q) ℚᵘ.+ toℚᵘ(s) ≃⟨ ℚᵘ.≃-sym (toℚᵘ-homo-+ q s) ⟩ - toℚᵘ(q + s) ∎) - where open ℚᵘ.≤-Reasoning - -+-mono-≤-< : _+_ Preserves₂ _≤_ ⟶ _<_ ⟶ _<_ -+-mono-≤-< {p} {q} {r} {s} p≤q r<s rewrite +-comm p r | +-comm q s = +-mono-<-≤ r<s p≤q - -+-mono-< : _+_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_ -+-mono-< {p} {q} {r} {s} p<q r<s = <-trans (+-mono-<-≤ p<q (≤-refl {r})) (+-mono-≤-< (≤-refl {q}) r<s) - -+-monoˡ-< : ∀ r → (_+ r) Preserves _<_ ⟶ _<_ -+-monoˡ-< r p<q = +-mono-<-≤ p<q (≤-refl {r}) - -+-monoʳ-< : ∀ r → (_+_ r) Preserves _<_ ⟶ _<_ -+-monoʳ-< r p<q = +-mono-≤-< (≤-refl {r}) p<q - ------------------------------------------------------------------------- --- Properties of _*_ ------------------------------------------------------------------------- - -private - *-nf : ℚ → ℚ → ℤ - *-nf p q = gcd (↥ p ℤ.* ↥ q) (↧ p ℤ.* ↧ q) - -↥-* : ∀ p q → ↥ (p * q) ℤ.* *-nf p q ≡ ↥ p ℤ.* ↥ q -↥-* p@record{} q@record{} = ↥-/ (↥ p ℤ.* ↥ q) (↧ₙ p ℕ.* ↧ₙ q) - -↧-* : ∀ p q → ↧ (p * q) ℤ.* *-nf p q ≡ ↧ p ℤ.* ↧ q -↧-* p@record{} q@record{} = ↧-/ (↥ p ℤ.* ↥ q) (↧ₙ p ℕ.* ↧ₙ q) - ------------------------------------------------------------------------- --- Monomorphic to unnormalised _*_ - -toℚᵘ-homo-* : Homomorphic₂ toℚᵘ _*_ ℚᵘ._*_ -toℚᵘ-homo-* p@record{} q@record{} with *-nf p q ℤ.≟ 0ℤ -... | yes nf[p,q]≡0 = *≡* $ begin - ↥ᵘ (toℚᵘ (p * q)) ℤ.* (↧ p ℤ.* ↧ q) ≡⟨ cong (ℤ._* (↧ p ℤ.* ↧ q)) (↥ᵘ-toℚᵘ (p * q)) ⟩ - ↥ (p * q) ℤ.* (↧ p ℤ.* ↧ q) ≡⟨ cong (ℤ._* (↧ p ℤ.* ↧ q)) eq ⟩ - 0ℤ ℤ.* (↧ p ℤ.* ↧ q) ≡⟨⟩ - 0ℤ ℤ.* ↧ (p * q) ≡⟨ cong (ℤ._* ↧ (p * q)) (sym eq2) ⟩ - (↥ p ℤ.* ↥ q) ℤ.* ↧ (p * q) ≡⟨ cong ((↥ p ℤ.* ↥ q) ℤ.*_) (sym (↧ᵘ-toℚᵘ (p * q))) ⟩ - (↥ p ℤ.* ↥ q) ℤ.* ↧ᵘ (toℚᵘ (p * q)) ∎ - where - open ≡-Reasoning - eq2 : ↥ p ℤ.* ↥ q ≡ 0ℤ - eq2 = gcd[i,j]≡0⇒i≡0 (↥ p ℤ.* ↥ q) (↧ p ℤ.* ↧ q) nf[p,q]≡0 - - eq : ↥ (p * q) ≡ 0ℤ - eq rewrite eq2 = cong ↥_ (0/n≡0 (↧ₙ p ℕ.* ↧ₙ q)) -... | no nf[p,q]≢0 = *≡* $ ℤ.*-cancelʳ-≡ _ _ (*-nf p q) {{ℤ.≢-nonZero nf[p,q]≢0}} $ begin - ↥ᵘ (toℚᵘ (p * q)) ℤ.* (↧ p ℤ.* ↧ q) ℤ.* *-nf p q ≡⟨ cong (λ v → v ℤ.* (↧ p ℤ.* ↧ q) ℤ.* *-nf p q) (↥ᵘ-toℚᵘ (p * q)) ⟩ - ↥ (p * q) ℤ.* (↧ p ℤ.* ↧ q) ℤ.* *-nf p q ≡⟨ xy∙z≈xz∙y (↥ (p * q)) _ _ ⟩ - ↥ (p * q) ℤ.* *-nf p q ℤ.* (↧ p ℤ.* ↧ q) ≡⟨ cong (ℤ._* (↧ p ℤ.* ↧ q)) (↥-* p q) ⟩ - (↥ p ℤ.* ↥ q) ℤ.* (↧ p ℤ.* ↧ q) ≡⟨ cong ((↥ p ℤ.* ↥ q) ℤ.*_) (sym (↧-* p q)) ⟩ - (↥ p ℤ.* ↥ q) ℤ.* (↧ (p * q) ℤ.* *-nf p q) ≡⟨ x∙yz≈xy∙z (↥ p ℤ.* ↥ q) _ _ ⟩ - (↥ p ℤ.* ↥ q) ℤ.* ↧ (p * q) ℤ.* *-nf p q ≡˘⟨ cong (λ v → (↥ p ℤ.* ↥ q) ℤ.* v ℤ.* *-nf p q) (↧ᵘ-toℚᵘ (p * q)) ⟩ - (↥ p ℤ.* ↥ q) ℤ.* ↧ᵘ (toℚᵘ (p * q)) ℤ.* *-nf p q ∎ - where open ≡-Reasoning; open CommSemigroupProperties ℤ.*-commutativeSemigroup - -toℚᵘ-homo-1/ : ∀ p .{{_ : NonZero p}} → toℚᵘ (1/ p) ℚᵘ.≃ (ℚᵘ.1/ toℚᵘ p) -toℚᵘ-homo-1/ (mkℚ +[1+ _ ] _ _) = ℚᵘ.≃-refl -toℚᵘ-homo-1/ (mkℚ -[1+ _ ] _ _) = ℚᵘ.≃-refl - -toℚᵘ-isMagmaHomomorphism-* : IsMagmaHomomorphism *-rawMagma ℚᵘ.*-rawMagma toℚᵘ -toℚᵘ-isMagmaHomomorphism-* = record - { isRelHomomorphism = toℚᵘ-isRelHomomorphism - ; homo = toℚᵘ-homo-* - } - -toℚᵘ-isMonoidHomomorphism-* : IsMonoidHomomorphism *-1-rawMonoid ℚᵘ.*-1-rawMonoid toℚᵘ -toℚᵘ-isMonoidHomomorphism-* = record - { isMagmaHomomorphism = toℚᵘ-isMagmaHomomorphism-* - ; ε-homo = ℚᵘ.≃-refl - } - -toℚᵘ-isMonoidMonomorphism-* : IsMonoidMonomorphism *-1-rawMonoid ℚᵘ.*-1-rawMonoid toℚᵘ -toℚᵘ-isMonoidMonomorphism-* = record - { isMonoidHomomorphism = toℚᵘ-isMonoidHomomorphism-* - ; injective = toℚᵘ-injective - } - -toℚᵘ-isNearSemiringHomomorphism-+-* : IsNearSemiringHomomorphism +-*-rawNearSemiring ℚᵘ.+-*-rawNearSemiring toℚᵘ -toℚᵘ-isNearSemiringHomomorphism-+-* = record - { +-isMonoidHomomorphism = toℚᵘ-isMonoidHomomorphism-+ - ; *-homo = toℚᵘ-homo-* - } - -toℚᵘ-isNearSemiringMonomorphism-+-* : IsNearSemiringMonomorphism +-*-rawNearSemiring ℚᵘ.+-*-rawNearSemiring toℚᵘ -toℚᵘ-isNearSemiringMonomorphism-+-* = record - { isNearSemiringHomomorphism = toℚᵘ-isNearSemiringHomomorphism-+-* - ; injective = toℚᵘ-injective - } - -toℚᵘ-isSemiringHomomorphism-+-* : IsSemiringHomomorphism +-*-rawSemiring ℚᵘ.+-*-rawSemiring toℚᵘ -toℚᵘ-isSemiringHomomorphism-+-* = record - { isNearSemiringHomomorphism = toℚᵘ-isNearSemiringHomomorphism-+-* - ; 1#-homo = ℚᵘ.≃-refl - } - -toℚᵘ-isSemiringMonomorphism-+-* : IsSemiringMonomorphism +-*-rawSemiring ℚᵘ.+-*-rawSemiring toℚᵘ -toℚᵘ-isSemiringMonomorphism-+-* = record - { isSemiringHomomorphism = toℚᵘ-isSemiringHomomorphism-+-* - ; injective = toℚᵘ-injective - } - -toℚᵘ-isRingHomomorphism-+-* : IsRingHomomorphism +-*-rawRing ℚᵘ.+-*-rawRing toℚᵘ -toℚᵘ-isRingHomomorphism-+-* = record - { isSemiringHomomorphism = toℚᵘ-isSemiringHomomorphism-+-* - ; -‿homo = toℚᵘ-homo‿- - } - -toℚᵘ-isRingMonomorphism-+-* : IsRingMonomorphism +-*-rawRing ℚᵘ.+-*-rawRing toℚᵘ -toℚᵘ-isRingMonomorphism-+-* = record - { isRingHomomorphism = toℚᵘ-isRingHomomorphism-+-* - ; injective = toℚᵘ-injective - } - ------------------------------------------------------------------------- --- Algebraic properties - -private - module +-*-Monomorphism = RingMonomorphisms toℚᵘ-isRingMonomorphism-+-* - -*-assoc : Associative _*_ -*-assoc = +-*-Monomorphism.*-assoc ℚᵘ.*-isMagma ℚᵘ.*-assoc - -*-comm : Commutative _*_ -*-comm = +-*-Monomorphism.*-comm ℚᵘ.*-isMagma ℚᵘ.*-comm - -*-identityˡ : LeftIdentity 1ℚ _*_ -*-identityˡ = +-*-Monomorphism.*-identityˡ ℚᵘ.*-isMagma ℚᵘ.*-identityˡ - -*-identityʳ : RightIdentity 1ℚ _*_ -*-identityʳ = +-*-Monomorphism.*-identityʳ ℚᵘ.*-isMagma ℚᵘ.*-identityʳ - -*-identity : Identity 1ℚ _*_ -*-identity = *-identityˡ , *-identityʳ - -*-zeroˡ : LeftZero 0ℚ _*_ -*-zeroˡ = +-*-Monomorphism.zeroˡ ℚᵘ.+-0-isGroup ℚᵘ.*-isMagma ℚᵘ.*-zeroˡ - -*-zeroʳ : RightZero 0ℚ _*_ -*-zeroʳ = +-*-Monomorphism.zeroʳ ℚᵘ.+-0-isGroup ℚᵘ.*-isMagma ℚᵘ.*-zeroʳ - -*-zero : Zero 0ℚ _*_ -*-zero = *-zeroˡ , *-zeroʳ - -*-distribˡ-+ : _*_ DistributesOverˡ _+_ -*-distribˡ-+ = +-*-Monomorphism.distribˡ ℚᵘ.+-0-isGroup ℚᵘ.*-isMagma ℚᵘ.*-distribˡ-+ - -*-distribʳ-+ : _*_ DistributesOverʳ _+_ -*-distribʳ-+ = +-*-Monomorphism.distribʳ ℚᵘ.+-0-isGroup ℚᵘ.*-isMagma ℚᵘ.*-distribʳ-+ - -*-distrib-+ : _*_ DistributesOver _+_ -*-distrib-+ = *-distribˡ-+ , *-distribʳ-+ - -*-inverseˡ : ∀ p .{{_ : NonZero p}} → (1/ p) * p ≡ 1ℚ -*-inverseˡ p = toℚᵘ-injective (begin-equality - toℚᵘ (1/ p * p) ≃⟨ toℚᵘ-homo-* (1/ p) p ⟩ - toℚᵘ (1/ p) ℚᵘ.* toℚᵘ p ≃⟨ ℚᵘ.*-congʳ (toℚᵘ-homo-1/ p) ⟩ - ℚᵘ.1/ (toℚᵘ p) ℚᵘ.* toℚᵘ p ≃⟨ ℚᵘ.*-inverseˡ (toℚᵘ p) ⟩ - ℚᵘ.1ℚᵘ ∎) - where open ℚᵘ.≤-Reasoning - -*-inverseʳ : ∀ p .{{_ : NonZero p}} → p * (1/ p) ≡ 1ℚ -*-inverseʳ p = trans (*-comm p (1/ p)) (*-inverseˡ p) - -neg-distribˡ-* : ∀ p q → - (p * q) ≡ - p * q -neg-distribˡ-* = +-*-Monomorphism.neg-distribˡ-* ℚᵘ.+-0-isGroup ℚᵘ.*-isMagma ℚᵘ.neg-distribˡ-* - -neg-distribʳ-* : ∀ p q → - (p * q) ≡ p * - q -neg-distribʳ-* = +-*-Monomorphism.neg-distribʳ-* ℚᵘ.+-0-isGroup ℚᵘ.*-isMagma ℚᵘ.neg-distribʳ-* - ------------------------------------------------------------------------- --- Structures - -*-isMagma : IsMagma _*_ -*-isMagma = +-*-Monomorphism.*-isMagma ℚᵘ.*-isMagma - -*-isSemigroup : IsSemigroup _*_ -*-isSemigroup = +-*-Monomorphism.*-isSemigroup ℚᵘ.*-isSemigroup - -*-1-isMonoid : IsMonoid _*_ 1ℚ -*-1-isMonoid = +-*-Monomorphism.*-isMonoid ℚᵘ.*-1-isMonoid - -*-1-isCommutativeMonoid : IsCommutativeMonoid _*_ 1ℚ -*-1-isCommutativeMonoid = +-*-Monomorphism.*-isCommutativeMonoid ℚᵘ.*-1-isCommutativeMonoid - -+-*-isRing : IsRing _+_ _*_ -_ 0ℚ 1ℚ -+-*-isRing = +-*-Monomorphism.isRing ℚᵘ.+-*-isRing - -+-*-isCommutativeRing : IsCommutativeRing _+_ _*_ -_ 0ℚ 1ℚ -+-*-isCommutativeRing = +-*-Monomorphism.isCommutativeRing ℚᵘ.+-*-isCommutativeRing - ------------------------------------------------------------------------- --- Packages - -*-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 - } - ------------------------------------------------------------------------- --- Properties of _*_ and _≤_ - -*-cancelʳ-≤-pos : ∀ r .{{_ : Positive r}} → p * r ≤ q * r → p ≤ q -*-cancelʳ-≤-pos {p} {q} r pr≤qr = toℚᵘ-cancel-≤ (ℚᵘ.*-cancelʳ-≤-pos (toℚᵘ r) (begin - toℚᵘ p ℚᵘ.* toℚᵘ r ≃˘⟨ toℚᵘ-homo-* p r ⟩ - toℚᵘ (p * r) ≤⟨ toℚᵘ-mono-≤ pr≤qr ⟩ - toℚᵘ (q * r) ≃⟨ toℚᵘ-homo-* q r ⟩ - toℚᵘ q ℚᵘ.* toℚᵘ r ∎)) - where open ℚᵘ.≤-Reasoning - -*-cancelˡ-≤-pos : ∀ r .{{_ : Positive r}} → r * p ≤ r * q → p ≤ q -*-cancelˡ-≤-pos {p} {q} r rewrite *-comm r p | *-comm r q = *-cancelʳ-≤-pos r - -*-monoʳ-≤-nonNeg : ∀ r .{{_ : NonNegative r}} → (_* r) Preserves _≤_ ⟶ _≤_ -*-monoʳ-≤-nonNeg r {p} {q} p≤q = toℚᵘ-cancel-≤ (begin - toℚᵘ (p * r) ≃⟨ toℚᵘ-homo-* p r ⟩ - toℚᵘ p ℚᵘ.* toℚᵘ r ≤⟨ ℚᵘ.*-monoˡ-≤-nonNeg (toℚᵘ r) (toℚᵘ-mono-≤ p≤q) ⟩ - toℚᵘ q ℚᵘ.* toℚᵘ r ≃˘⟨ toℚᵘ-homo-* q r ⟩ - toℚᵘ (q * r) ∎) - where open ℚᵘ.≤-Reasoning - -*-monoˡ-≤-nonNeg : ∀ r .{{_ : NonNegative r}} → (r *_) Preserves _≤_ ⟶ _≤_ -*-monoˡ-≤-nonNeg r {p} {q} rewrite *-comm r p | *-comm r q = *-monoʳ-≤-nonNeg r - -*-monoʳ-≤-nonPos : ∀ r .{{_ : NonPositive r}} → (_* r) Preserves _≤_ ⟶ _≥_ -*-monoʳ-≤-nonPos r {p} {q} p≤q = toℚᵘ-cancel-≤ (begin - toℚᵘ (q * r) ≃⟨ toℚᵘ-homo-* q r ⟩ - toℚᵘ q ℚᵘ.* toℚᵘ r ≤⟨ ℚᵘ.*-monoˡ-≤-nonPos (toℚᵘ r) (toℚᵘ-mono-≤ p≤q) ⟩ - toℚᵘ p ℚᵘ.* toℚᵘ r ≃˘⟨ toℚᵘ-homo-* p r ⟩ - toℚᵘ (p * r) ∎) - where open ℚᵘ.≤-Reasoning - -*-monoˡ-≤-nonPos : ∀ r .{{_ : NonPositive r}} → (r *_) Preserves _≤_ ⟶ _≥_ -*-monoˡ-≤-nonPos r {p} {q} rewrite *-comm r p | *-comm r q = *-monoʳ-≤-nonPos r - -*-cancelʳ-≤-neg : ∀ r .{{_ : Negative r}} → p * r ≤ q * r → p ≥ q -*-cancelʳ-≤-neg {p} {q} r pr≤qr = toℚᵘ-cancel-≤ (ℚᵘ.*-cancelʳ-≤-neg _ (begin - toℚᵘ p ℚᵘ.* toℚᵘ r ≃˘⟨ toℚᵘ-homo-* p r ⟩ - toℚᵘ (p * r) ≤⟨ toℚᵘ-mono-≤ pr≤qr ⟩ - toℚᵘ (q * r) ≃⟨ toℚᵘ-homo-* q r ⟩ - toℚᵘ q ℚᵘ.* toℚᵘ r ∎)) - where open ℚᵘ.≤-Reasoning - -*-cancelˡ-≤-neg : ∀ r .{{_ : Negative r}} → r * p ≤ r * q → p ≥ q -*-cancelˡ-≤-neg {p} {q} r rewrite *-comm r p | *-comm r q = *-cancelʳ-≤-neg r - ------------------------------------------------------------------------- --- Properties of _*_ and _<_ - -*-monoˡ-<-pos : ∀ r .{{_ : Positive r}} → (_* r) Preserves _<_ ⟶ _<_ -*-monoˡ-<-pos r {p} {q} p<q = toℚᵘ-cancel-< (begin-strict - toℚᵘ (p * r) ≃⟨ toℚᵘ-homo-* p r ⟩ - toℚᵘ p ℚᵘ.* toℚᵘ r <⟨ ℚᵘ.*-monoˡ-<-pos (toℚᵘ r) (toℚᵘ-mono-< p<q) ⟩ - toℚᵘ q ℚᵘ.* toℚᵘ r ≃˘⟨ toℚᵘ-homo-* q r ⟩ - toℚᵘ (q * r) ∎) - where open ℚᵘ.≤-Reasoning - -*-monoʳ-<-pos : ∀ r .{{_ : Positive r}} → (r *_) Preserves _<_ ⟶ _<_ -*-monoʳ-<-pos r {p} {q} rewrite *-comm r p | *-comm r q = *-monoˡ-<-pos r - -*-cancelˡ-<-nonNeg : ∀ r .{{_ : NonNegative r}} → ∀ {p q} → r * p < r * q → p < q -*-cancelˡ-<-nonNeg r {p} {q} rp<rq = toℚᵘ-cancel-< (ℚᵘ.*-cancelˡ-<-nonNeg (toℚᵘ r) (begin-strict - toℚᵘ r ℚᵘ.* toℚᵘ p ≃˘⟨ toℚᵘ-homo-* r p ⟩ - toℚᵘ (r * p) <⟨ toℚᵘ-mono-< rp<rq ⟩ - toℚᵘ (r * q) ≃⟨ toℚᵘ-homo-* r q ⟩ - toℚᵘ r ℚᵘ.* toℚᵘ q ∎)) - where open ℚᵘ.≤-Reasoning - -*-cancelʳ-<-nonNeg : ∀ r .{{_ : NonNegative r}} → ∀ {p q} → p * r < q * r → p < q -*-cancelʳ-<-nonNeg r {p} {q} rewrite *-comm p r | *-comm q r = *-cancelˡ-<-nonNeg r - -*-monoˡ-<-neg : ∀ r .{{_ : Negative r}} → (_* r) Preserves _<_ ⟶ _>_ -*-monoˡ-<-neg r {p} {q} p<q = toℚᵘ-cancel-< (begin-strict - toℚᵘ (q * r) ≃⟨ toℚᵘ-homo-* q r ⟩ - toℚᵘ q ℚᵘ.* toℚᵘ r <⟨ ℚᵘ.*-monoˡ-<-neg (toℚᵘ r) (toℚᵘ-mono-< p<q) ⟩ - toℚᵘ p ℚᵘ.* toℚᵘ r ≃˘⟨ toℚᵘ-homo-* p r ⟩ - toℚᵘ (p * r) ∎) - where open ℚᵘ.≤-Reasoning - -*-monoʳ-<-neg : ∀ r .{{_ : Negative r}} → (r *_) Preserves _<_ ⟶ _>_ -*-monoʳ-<-neg r {p} {q} rewrite *-comm r p | *-comm r q = *-monoˡ-<-neg r - -*-cancelˡ-<-nonPos : ∀ r .{{_ : NonPositive r}} → r * p < r * q → p > q -*-cancelˡ-<-nonPos {p} {q} r rp<rq = toℚᵘ-cancel-< (ℚᵘ.*-cancelˡ-<-nonPos (toℚᵘ r) (begin-strict - toℚᵘ r ℚᵘ.* toℚᵘ p ≃˘⟨ toℚᵘ-homo-* r p ⟩ - toℚᵘ (r * p) <⟨ toℚᵘ-mono-< rp<rq ⟩ - toℚᵘ (r * q) ≃⟨ toℚᵘ-homo-* r q ⟩ - toℚᵘ r ℚᵘ.* toℚᵘ q ∎)) - where open ℚᵘ.≤-Reasoning - -*-cancelʳ-<-nonPos : ∀ r .{{_ : NonPositive r}} → p * r < q * r → p > q -*-cancelʳ-<-nonPos {p} {q} r rewrite *-comm p r | *-comm q r = *-cancelˡ-<-nonPos r - ------------------------------------------------------------------------- --- Properties of _⊓_ ------------------------------------------------------------------------- - -p≤q⇒p⊔q≡q : p ≤ q → p ⊔ q ≡ q -p≤q⇒p⊔q≡q {p@record{}} {q@record{}} p≤q with p ≤ᵇ q | inspect (p ≤ᵇ_) q -... | true | _ = refl -... | false | [ p≰q ] = contradiction (≤⇒≤ᵇ p≤q) (subst (¬_ ∘ T) (sym p≰q) λ()) - -p≥q⇒p⊔q≡p : p ≥ q → p ⊔ q ≡ p -p≥q⇒p⊔q≡p {p@record{}} {q@record{}} p≥q with p ≤ᵇ q | inspect (p ≤ᵇ_) q -... | true | [ p≤q ] = ≤-antisym p≥q (≤ᵇ⇒≤ (subst T (sym p≤q) _)) -... | false | [ p≤q ] = refl - -p≤q⇒p⊓q≡p : p ≤ q → p ⊓ q ≡ p -p≤q⇒p⊓q≡p {p@record{}} {q@record{}} p≤q with p ≤ᵇ q | inspect (p ≤ᵇ_) q -... | true | _ = refl -... | false | [ p≰q ] = contradiction (≤⇒≤ᵇ p≤q) (subst (¬_ ∘ T) (sym p≰q) λ()) - -p≥q⇒p⊓q≡q : p ≥ q → p ⊓ q ≡ q -p≥q⇒p⊓q≡q {p@record{}} {q@record{}} p≥q with p ≤ᵇ q | inspect (p ≤ᵇ_) q -... | true | [ p≤q ] = ≤-antisym (≤ᵇ⇒≤ (subst T (sym p≤q) _)) p≥q -... | false | [ p≤q ] = refl - -⊓-operator : MinOperator ≤-totalPreorder -⊓-operator = record - { x≤y⇒x⊓y≈x = p≤q⇒p⊓q≡p - ; x≥y⇒x⊓y≈y = p≥q⇒p⊓q≡q - } - -⊔-operator : MaxOperator ≤-totalPreorder -⊔-operator = record - { x≤y⇒x⊔y≈y = p≤q⇒p⊔q≡q - ; x≥y⇒x⊔y≈x = p≥q⇒p⊔q≡p - } - ------------------------------------------------------------------------- --- Automatically derived properties of _⊓_ and _⊔_ - -private - module ⊓-⊔-properties = MinMaxOp ⊓-operator ⊔-operator - module ⊓-⊔-latticeProperties = LatticeMinMaxOp ⊓-operator ⊔-operator - -open ⊓-⊔-properties public - using - ( ⊓-idem -- : Idempotent _⊓_ - ; ⊓-sel -- : Selective _⊓_ - ; ⊓-assoc -- : Associative _⊓_ - ; ⊓-comm -- : Commutative _⊓_ - - ; ⊔-idem -- : Idempotent _⊔_ - ; ⊔-sel -- : Selective _⊔_ - ; ⊔-assoc -- : Associative _⊔_ - ; ⊔-comm -- : Commutative _⊔_ - - ; ⊓-distribˡ-⊔ -- : _⊓_ DistributesOverˡ _⊔_ - ; ⊓-distribʳ-⊔ -- : _⊓_ DistributesOverʳ _⊔_ - ; ⊓-distrib-⊔ -- : _⊓_ DistributesOver _⊔_ - ; ⊔-distribˡ-⊓ -- : _⊔_ DistributesOverˡ _⊓_ - ; ⊔-distribʳ-⊓ -- : _⊔_ DistributesOverʳ _⊓_ - ; ⊔-distrib-⊓ -- : _⊔_ DistributesOver _⊓_ - ; ⊓-absorbs-⊔ -- : _⊓_ Absorbs _⊔_ - ; ⊔-absorbs-⊓ -- : _⊔_ Absorbs _⊓_ - ; ⊔-⊓-absorptive -- : Absorptive _⊔_ _⊓_ - ; ⊓-⊔-absorptive -- : Absorptive _⊓_ _⊔_ - - ; ⊓-isMagma -- : IsMagma _⊓_ - ; ⊓-isSemigroup -- : IsSemigroup _⊓_ - ; ⊓-isCommutativeSemigroup -- : IsCommutativeSemigroup _⊓_ - ; ⊓-isBand -- : IsBand _⊓_ - ; ⊓-isSelectiveMagma -- : IsSelectiveMagma _⊓_ - - ; ⊔-isMagma -- : IsMagma _⊔_ - ; ⊔-isSemigroup -- : IsSemigroup _⊔_ - ; ⊔-isCommutativeSemigroup -- : IsCommutativeSemigroup _⊔_ - ; ⊔-isBand -- : IsBand _⊔_ - ; ⊔-isSelectiveMagma -- : IsSelectiveMagma _⊔_ - - ; ⊓-magma -- : Magma _ _ - ; ⊓-semigroup -- : Semigroup _ _ - ; ⊓-band -- : Band _ _ - ; ⊓-commutativeSemigroup -- : CommutativeSemigroup _ _ - ; ⊓-selectiveMagma -- : SelectiveMagma _ _ - - ; ⊔-magma -- : Magma _ _ - ; ⊔-semigroup -- : Semigroup _ _ - ; ⊔-band -- : Band _ _ - ; ⊔-commutativeSemigroup -- : CommutativeSemigroup _ _ - ; ⊔-selectiveMagma -- : SelectiveMagma _ _ - - ; ⊓-glb -- : ∀ {p q r} → p ≥ r → q ≥ r → p ⊓ q ≥ r - ; ⊓-triangulate -- : ∀ p q r → p ⊓ q ⊓ r ≡ (p ⊓ q) ⊓ (q ⊓ r) - ; ⊓-mono-≤ -- : _⊓_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ - ; ⊓-monoˡ-≤ -- : ∀ p → (_⊓ p) Preserves _≤_ ⟶ _≤_ - ; ⊓-monoʳ-≤ -- : ∀ p → (p ⊓_) Preserves _≤_ ⟶ _≤_ - - ; ⊔-lub -- : ∀ {p q r} → p ≤ r → q ≤ r → p ⊔ q ≤ r - ; ⊔-triangulate -- : ∀ p q r → p ⊔ q ⊔ r ≡ (p ⊔ q) ⊔ (q ⊔ r) - ; ⊔-mono-≤ -- : _⊔_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ - ; ⊔-monoˡ-≤ -- : ∀ p → (_⊔ p) Preserves _≤_ ⟶ _≤_ - ; ⊔-monoʳ-≤ -- : ∀ p → (p ⊔_) Preserves _≤_ ⟶ _≤_ - ) - renaming - ( x⊓y≈y⇒y≤x to p⊓q≡q⇒q≤p -- : ∀ {p q} → p ⊓ q ≡ q → q ≤ p - ; x⊓y≈x⇒x≤y to p⊓q≡p⇒p≤q -- : ∀ {p q} → p ⊓ q ≡ p → p ≤ q - ; x⊓y≤x to p⊓q≤p -- : ∀ p q → p ⊓ q ≤ p - ; x⊓y≤y to p⊓q≤q -- : ∀ p q → p ⊓ q ≤ q - ; x≤y⇒x⊓z≤y to p≤q⇒p⊓r≤q -- : ∀ {p q} r → p ≤ q → p ⊓ r ≤ q - ; x≤y⇒z⊓x≤y to p≤q⇒r⊓p≤q -- : ∀ {p q} r → p ≤ q → r ⊓ p ≤ q - ; x≤y⊓z⇒x≤y to p≤q⊓r⇒p≤q -- : ∀ {p} q r → p ≤ q ⊓ r → p ≤ q - ; x≤y⊓z⇒x≤z to p≤q⊓r⇒p≤r -- : ∀ {p} q r → p ≤ q ⊓ r → p ≤ r - - ; x⊔y≈y⇒x≤y to p⊔q≡q⇒p≤q -- : ∀ {p q} → p ⊔ q ≡ q → p ≤ q - ; x⊔y≈x⇒y≤x to p⊔q≡p⇒q≤p -- : ∀ {p q} → p ⊔ q ≡ p → q ≤ p - ; x≤x⊔y to p≤p⊔q -- : ∀ p q → p ≤ p ⊔ q - ; x≤y⊔x to p≤q⊔p -- : ∀ p q → p ≤ q ⊔ p - ; x≤y⇒x≤y⊔z to p≤q⇒p≤q⊔r -- : ∀ {p q} r → p ≤ q → p ≤ q ⊔ r - ; x≤y⇒x≤z⊔y to p≤q⇒p≤r⊔q -- : ∀ {p q} r → p ≤ q → p ≤ r ⊔ q - ; x⊔y≤z⇒x≤z to p⊔q≤r⇒p≤r -- : ∀ p q {r} → p ⊔ q ≤ r → p ≤ r - ; x⊔y≤z⇒y≤z to p⊔q≤r⇒q≤r -- : ∀ p q {r} → p ⊔ q ≤ r → q ≤ r - - ; x⊓y≤x⊔y to p⊓q≤p⊔q -- : ∀ p q → p ⊓ q ≤ p ⊔ q - ) - -open ⊓-⊔-latticeProperties public - using - ( ⊓-isSemilattice -- : IsSemilattice _⊓_ - ; ⊔-isSemilattice -- : IsSemilattice _⊔_ - ; ⊔-⊓-isLattice -- : IsLattice _⊔_ _⊓_ - ; ⊓-⊔-isLattice -- : IsLattice _⊓_ _⊔_ - ; ⊔-⊓-isDistributiveLattice -- : IsDistributiveLattice _⊔_ _⊓_ - ; ⊓-⊔-isDistributiveLattice -- : IsDistributiveLattice _⊓_ _⊔_ - - ; ⊓-semilattice -- : Semilattice _ _ - ; ⊔-semilattice -- : Semilattice _ _ - ; ⊔-⊓-lattice -- : Lattice _ _ - ; ⊓-⊔-lattice -- : Lattice _ _ - ; ⊔-⊓-distributiveLattice -- : DistributiveLattice _ _ - ; ⊓-⊔-distributiveLattice -- : DistributiveLattice _ _ - ) - ------------------------------------------------------------------------- --- Other properties of _⊓_ and _⊔_ - -mono-≤-distrib-⊔ : ∀ {f} → f Preserves _≤_ ⟶ _≤_ → - ∀ p q → f (p ⊔ q) ≡ f p ⊔ f q -mono-≤-distrib-⊔ {f} = ⊓-⊔-properties.mono-≤-distrib-⊔ (cong f) - -mono-≤-distrib-⊓ : ∀ {f} → f Preserves _≤_ ⟶ _≤_ → - ∀ p q → f (p ⊓ q) ≡ f p ⊓ f q -mono-≤-distrib-⊓ {f} = ⊓-⊔-properties.mono-≤-distrib-⊓ (cong f) - -mono-<-distrib-⊓ : ∀ {f} → f Preserves _<_ ⟶ _<_ → - ∀ p q → f (p ⊓ q) ≡ f p ⊓ f q -mono-<-distrib-⊓ {f} f-mono-< p q with <-cmp p q -... | tri< p<q p≢r p≯q = begin - f (p ⊓ q) ≡⟨ cong f (p≤q⇒p⊓q≡p (<⇒≤ p<q)) ⟩ - f p ≡˘⟨ p≤q⇒p⊓q≡p (<⇒≤ (f-mono-< p<q)) ⟩ - f p ⊓ f q ∎ - where open ≡-Reasoning -... | tri≈ p≮q refl p≯q = begin - f (p ⊓ q) ≡⟨ cong f (⊓-idem p) ⟩ - f p ≡˘⟨ ⊓-idem (f p) ⟩ - f p ⊓ f q ∎ - where open ≡-Reasoning -... | tri> p≮q p≡r p>q = begin - f (p ⊓ q) ≡⟨ cong f (p≥q⇒p⊓q≡q (<⇒≤ p>q)) ⟩ - f q ≡˘⟨ p≥q⇒p⊓q≡q (<⇒≤ (f-mono-< p>q)) ⟩ - f p ⊓ f q ∎ - where open ≡-Reasoning - -mono-<-distrib-⊔ : ∀ {f} → f Preserves _<_ ⟶ _<_ → - ∀ p q → f (p ⊔ q) ≡ f p ⊔ f q -mono-<-distrib-⊔ {f} f-mono-< p q with <-cmp p q -... | tri< p<q p≢r p≯q = begin - f (p ⊔ q) ≡⟨ cong f (p≤q⇒p⊔q≡q (<⇒≤ p<q)) ⟩ - f q ≡˘⟨ p≤q⇒p⊔q≡q (<⇒≤ (f-mono-< p<q)) ⟩ - f p ⊔ f q ∎ - where open ≡-Reasoning -... | tri≈ p≮q refl p≯q = begin - f (p ⊔ q) ≡⟨ cong f (⊔-idem p) ⟩ - f q ≡˘⟨ ⊔-idem (f p) ⟩ - f p ⊔ f q ∎ - where open ≡-Reasoning -... | tri> p≮q p≡r p>q = begin - f (p ⊔ q) ≡⟨ cong f (p≥q⇒p⊔q≡p (<⇒≤ p>q)) ⟩ - f p ≡˘⟨ p≥q⇒p⊔q≡p (<⇒≤ (f-mono-< p>q)) ⟩ - f p ⊔ f q ∎ - where open ≡-Reasoning - -antimono-≤-distrib-⊓ : ∀ {f} → f Preserves _≤_ ⟶ _≥_ → - ∀ p q → f (p ⊓ q) ≡ f p ⊔ f q -antimono-≤-distrib-⊓ {f} = ⊓-⊔-properties.antimono-≤-distrib-⊓ (cong f) - -antimono-≤-distrib-⊔ : ∀ {f} → f Preserves _≤_ ⟶ _≥_ → - ∀ p q → f (p ⊔ q) ≡ f p ⊓ f q -antimono-≤-distrib-⊔ {f} = ⊓-⊔-properties.antimono-≤-distrib-⊔ (cong f) - ------------------------------------------------------------------------- --- Properties of _⊓_ and _*_ - -*-distribˡ-⊓-nonNeg : ∀ p .{{_ : NonNegative p}} → ∀ q r → p * (q ⊓ r) ≡ (p * q) ⊓ (p * r) -*-distribˡ-⊓-nonNeg p = mono-≤-distrib-⊓ (*-monoˡ-≤-nonNeg p) - -*-distribʳ-⊓-nonNeg : ∀ p .{{_ : NonNegative p}} → ∀ q r → (q ⊓ r) * p ≡ (q * p) ⊓ (r * p) -*-distribʳ-⊓-nonNeg p = mono-≤-distrib-⊓ (*-monoʳ-≤-nonNeg p) - -*-distribˡ-⊔-nonNeg : ∀ p .{{_ : NonNegative p}} → ∀ q r → p * (q ⊔ r) ≡ (p * q) ⊔ (p * r) -*-distribˡ-⊔-nonNeg p = mono-≤-distrib-⊔ (*-monoˡ-≤-nonNeg p) - -*-distribʳ-⊔-nonNeg : ∀ p .{{_ : NonNegative p}} → ∀ q r → (q ⊔ r) * p ≡ (q * p) ⊔ (r * p) -*-distribʳ-⊔-nonNeg p = mono-≤-distrib-⊔ (*-monoʳ-≤-nonNeg p) - ------------------------------------------------------------------------- --- Properties of _⊓_, _⊔_ and _*_ - -*-distribˡ-⊔-nonPos : ∀ p .{{_ : NonPositive p}} → ∀ q r → p * (q ⊔ r) ≡ (p * q) ⊓ (p * r) -*-distribˡ-⊔-nonPos p = antimono-≤-distrib-⊔ (*-monoˡ-≤-nonPos p) - -*-distribʳ-⊔-nonPos : ∀ p .{{_ : NonPositive p}} → ∀ q r → (q ⊔ r) * p ≡ (q * p) ⊓ (r * p) -*-distribʳ-⊔-nonPos p = antimono-≤-distrib-⊔ (*-monoʳ-≤-nonPos p) - -*-distribˡ-⊓-nonPos : ∀ p .{{_ : NonPositive p}} → ∀ q r → p * (q ⊓ r) ≡ (p * q) ⊔ (p * r) -*-distribˡ-⊓-nonPos p = antimono-≤-distrib-⊓ (*-monoˡ-≤-nonPos p) - -*-distribʳ-⊓-nonPos : ∀ p .{{_ : NonPositive p}} → ∀ q r → (q ⊓ r) * p ≡ (q * p) ⊔ (r * p) -*-distribʳ-⊓-nonPos p = antimono-≤-distrib-⊓ (*-monoʳ-≤-nonPos p) - ------------------------------------------------------------------------- --- Properties of 1/_ ------------------------------------------------------------------------- - -nonZero⇒1/nonZero : ∀ p .{{_ : NonZero p}} → NonZero (1/ p) -nonZero⇒1/nonZero (mkℚ +[1+ _ ] _ _) = _ -nonZero⇒1/nonZero (mkℚ -[1+ _ ] _ _) = _ - -1/-involutive : ∀ p .{{_ : NonZero p}} → (1/ (1/ p)) {{nonZero⇒1/nonZero p}} ≡ p -1/-involutive (mkℚ +[1+ n ] d-1 _) = refl -1/-involutive (mkℚ -[1+ n ] d-1 _) = refl - -1/pos⇒pos : ∀ p .{{_ : Positive p}} → Positive ((1/ p) {{pos⇒nonZero p}}) -1/pos⇒pos (mkℚ +[1+ _ ] _ _) = _ - -1/neg⇒neg : ∀ p .{{_ : Negative p}} → Negative ((1/ p) {{neg⇒nonZero p}}) -1/neg⇒neg (mkℚ -[1+ _ ] _ _) = _ - -pos⇒1/pos : ∀ p .{{_ : NonZero p}} .{{_ : Positive (1/ p)}} → Positive p -pos⇒1/pos p = subst Positive (1/-involutive p) (1/pos⇒pos (1/ p)) - -neg⇒1/neg : ∀ p .{{_ : NonZero p}} .{{_ : Negative (1/ p)}} → Negative p -neg⇒1/neg p = subst Negative (1/-involutive p) (1/neg⇒neg (1/ p)) - ------------------------------------------------------------------------- --- Properties of ∣_∣ ------------------------------------------------------------------------- - ------------------------------------------------------------------------- --- Monomorphic to unnormalised -_ - -toℚᵘ-homo-∣-∣ : Homomorphic₁ toℚᵘ ∣_∣ ℚᵘ.∣_∣ -toℚᵘ-homo-∣-∣ (mkℚ +[1+ _ ] _ _) = *≡* refl -toℚᵘ-homo-∣-∣ (mkℚ +0 _ _) = *≡* refl -toℚᵘ-homo-∣-∣ (mkℚ -[1+ _ ] _ _) = *≡* refl - ------------------------------------------------------------------------- --- Properties - -∣p∣≡0⇒p≡0 : ∀ p → ∣ p ∣ ≡ 0ℚ → p ≡ 0ℚ -∣p∣≡0⇒p≡0 (mkℚ +0 zero _) ∣p∣≡0 = refl - -0≤∣p∣ : ∀ p → 0ℚ ≤ ∣ p ∣ -0≤∣p∣ p@record{} = *≤* (begin - (↥ 0ℚ) ℤ.* (↧ ∣ p ∣) ≡⟨ ℤ.*-zeroˡ (↧ ∣ p ∣) ⟩ - 0ℤ ≤⟨ ℤ.+≤+ ℕ.z≤n ⟩ - ↥ ∣ p ∣ ≡˘⟨ ℤ.*-identityʳ (↥ ∣ p ∣) ⟩ - ↥ ∣ p ∣ ℤ.* 1ℤ ∎) - where open ℤ.≤-Reasoning - -0≤p⇒∣p∣≡p : 0ℚ ≤ p → ∣ p ∣ ≡ p -0≤p⇒∣p∣≡p {p@record{}} 0≤p = toℚᵘ-injective (ℚᵘ.0≤p⇒∣p∣≃p (toℚᵘ-mono-≤ 0≤p)) - -∣-p∣≡∣p∣ : ∀ p → ∣ - p ∣ ≡ ∣ p ∣ -∣-p∣≡∣p∣ (mkℚ +[1+ n ] d-1 _) = refl -∣-p∣≡∣p∣ (mkℚ +0 d-1 _) = refl -∣-p∣≡∣p∣ (mkℚ -[1+ n ] d-1 _) = refl - -∣p∣≡p⇒0≤p : ∀ {p} → ∣ p ∣ ≡ p → 0ℚ ≤ p -∣p∣≡p⇒0≤p {p} ∣p∣≡p = toℚᵘ-cancel-≤ (ℚᵘ.∣p∣≃p⇒0≤p (begin-equality - ℚᵘ.∣ toℚᵘ p ∣ ≃⟨ ℚᵘ.≃-sym (toℚᵘ-homo-∣-∣ p) ⟩ - toℚᵘ ∣ p ∣ ≡⟨ cong toℚᵘ ∣p∣≡p ⟩ - toℚᵘ p ∎)) - where open ℚᵘ.≤-Reasoning - -∣p∣≡p∨∣p∣≡-p : ∀ p → ∣ p ∣ ≡ p ⊎ ∣ p ∣ ≡ - p -∣p∣≡p∨∣p∣≡-p (mkℚ (+ n) d-1 _) = inj₁ refl -∣p∣≡p∨∣p∣≡-p (mkℚ (-[1+ n ]) d-1 _) = inj₂ refl - -∣p+q∣≤∣p∣+∣q∣ : ∀ p q → ∣ p + q ∣ ≤ ∣ p ∣ + ∣ q ∣ -∣p+q∣≤∣p∣+∣q∣ p q = toℚᵘ-cancel-≤ (begin - toℚᵘ ∣ p + q ∣ ≃⟨ toℚᵘ-homo-∣-∣ (p + q) ⟩ - ℚᵘ.∣ toℚᵘ (p + q) ∣ ≃⟨ ℚᵘ.∣-∣-cong (toℚᵘ-homo-+ p q) ⟩ - ℚᵘ.∣ toℚᵘ p ℚᵘ.+ toℚᵘ q ∣ ≤⟨ ℚᵘ.∣p+q∣≤∣p∣+∣q∣ (toℚᵘ p) (toℚᵘ q) ⟩ - ℚᵘ.∣ toℚᵘ p ∣ ℚᵘ.+ ℚᵘ.∣ toℚᵘ q ∣ ≃˘⟨ ℚᵘ.+-cong (toℚᵘ-homo-∣-∣ p) (toℚᵘ-homo-∣-∣ q) ⟩ - toℚᵘ ∣ p ∣ ℚᵘ.+ toℚᵘ ∣ q ∣ ≃˘⟨ toℚᵘ-homo-+ ∣ p ∣ ∣ q ∣ ⟩ - toℚᵘ (∣ p ∣ + ∣ q ∣) ∎) - where open ℚᵘ.≤-Reasoning - -∣p-q∣≤∣p∣+∣q∣ : ∀ p q → ∣ p - q ∣ ≤ ∣ p ∣ + ∣ q ∣ -∣p-q∣≤∣p∣+∣q∣ p@record{} q@record{} = begin - ∣ p - q ∣ ≤⟨ ∣p+q∣≤∣p∣+∣q∣ p (- q) ⟩ - ∣ p ∣ + ∣ - q ∣ ≡⟨ cong (λ h → ∣ p ∣ + h) (∣-p∣≡∣p∣ q) ⟩ - ∣ p ∣ + ∣ q ∣ ∎ - where open ≤-Reasoning - -∣p*q∣≡∣p∣*∣q∣ : ∀ p q → ∣ p * q ∣ ≡ ∣ p ∣ * ∣ q ∣ -∣p*q∣≡∣p∣*∣q∣ p q = toℚᵘ-injective (begin-equality - toℚᵘ ∣ p * q ∣ ≃⟨ toℚᵘ-homo-∣-∣ (p * q) ⟩ - ℚᵘ.∣ toℚᵘ (p * q) ∣ ≃⟨ ℚᵘ.∣-∣-cong (toℚᵘ-homo-* p q) ⟩ - ℚᵘ.∣ toℚᵘ p ℚᵘ.* toℚᵘ q ∣ ≃⟨ ℚᵘ.∣p*q∣≃∣p∣*∣q∣ (toℚᵘ p) (toℚᵘ q) ⟩ - ℚᵘ.∣ toℚᵘ p ∣ ℚᵘ.* ℚᵘ.∣ toℚᵘ q ∣ ≃˘⟨ ℚᵘ.*-cong (toℚᵘ-homo-∣-∣ p) (toℚᵘ-homo-∣-∣ q) ⟩ - toℚᵘ ∣ p ∣ ℚᵘ.* toℚᵘ ∣ q ∣ ≃˘⟨ toℚᵘ-homo-* ∣ p ∣ ∣ q ∣ ⟩ - toℚᵘ (∣ p ∣ * ∣ q ∣) ∎) - where open ℚᵘ.≤-Reasoning - -∣-∣-nonNeg : ∀ p → NonNegative ∣ p ∣ -∣-∣-nonNeg (mkℚ +[1+ _ ] _ _) = _ -∣-∣-nonNeg (mkℚ +0 _ _) = _ -∣-∣-nonNeg (mkℚ -[1+ _ ] _ _) = _ - -∣∣p∣∣≡∣p∣ : ∀ p → ∣ ∣ p ∣ ∣ ≡ ∣ p ∣ -∣∣p∣∣≡∣p∣ p = 0≤p⇒∣p∣≡p (0≤∣p∣ p) - - ------------------------------------------------------------------------- --- DEPRECATED NAMES ------------------------------------------------------------------------- --- Please use the new names as continuing support for the old names is --- not guaranteed. - --- Version 2.0 - -*-monoʳ-≤-neg : ∀ r → Negative r → (_* r) Preserves _≤_ ⟶ _≥_ -*-monoʳ-≤-neg r@(mkℚ -[1+ _ ] _ _) _ = *-monoʳ-≤-nonPos r -{-# WARNING_ON_USAGE *-monoʳ-≤-neg -"Warning: *-monoʳ-≤-neg was deprecated in v2.0. ++-0-isGroup : IsGroup _+_ 0ℚ (-_) ++-0-isGroup = +-Monomorphism.isGroup ℚᵘ.+-0-isGroup + ++-0-isAbelianGroup : IsAbelianGroup _+_ 0ℚ (-_) ++-0-isAbelianGroup = +-Monomorphism.isAbelianGroup ℚᵘ.+-0-isAbelianGroup + +------------------------------------------------------------------------ +-- Packages + ++-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 _+_ and _≤_ + ++-mono-≤ : _+_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ ++-mono-≤ {p} {q} {r} {s} p≤q r≤s = toℚᵘ-cancel-≤ (begin + toℚᵘ(p + r) ≃⟨ toℚᵘ-homo-+ p r ⟩ + toℚᵘ(p) ℚᵘ.+ toℚᵘ(r) ≤⟨ ℚᵘ.+-mono-≤ (toℚᵘ-mono-≤ p≤q) (toℚᵘ-mono-≤ r≤s) ⟩ + toℚᵘ(q) ℚᵘ.+ toℚᵘ(s) ≃⟨ ℚᵘ.≃-sym (toℚᵘ-homo-+ q s) ⟩ + toℚᵘ(q + s) ∎) + where open ℚᵘ.≤-Reasoning + ++-monoˡ-≤ : ∀ r → (_+ r) Preserves _≤_ ⟶ _≤_ ++-monoˡ-≤ r p≤q = +-mono-≤ p≤q (≤-refl {r}) + ++-monoʳ-≤ : ∀ r → (_+_ r) Preserves _≤_ ⟶ _≤_ ++-monoʳ-≤ r p≤q = +-mono-≤ (≤-refl {r}) p≤q + +------------------------------------------------------------------------ +-- Properties of _+_ and _<_ + ++-mono-<-≤ : _+_ Preserves₂ _<_ ⟶ _≤_ ⟶ _<_ ++-mono-<-≤ {p} {q} {r} {s} p<q r≤s = toℚᵘ-cancel-< (begin-strict + toℚᵘ(p + r) ≃⟨ toℚᵘ-homo-+ p r ⟩ + toℚᵘ(p) ℚᵘ.+ toℚᵘ(r) <⟨ ℚᵘ.+-mono-<-≤ (toℚᵘ-mono-< p<q) (toℚᵘ-mono-≤ r≤s) ⟩ + toℚᵘ(q) ℚᵘ.+ toℚᵘ(s) ≃⟨ ℚᵘ.≃-sym (toℚᵘ-homo-+ q s) ⟩ + toℚᵘ(q + s) ∎) + where open ℚᵘ.≤-Reasoning + ++-mono-≤-< : _+_ Preserves₂ _≤_ ⟶ _<_ ⟶ _<_ ++-mono-≤-< {p} {q} {r} {s} p≤q r<s rewrite +-comm p r | +-comm q s = +-mono-<-≤ r<s p≤q + ++-mono-< : _+_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_ ++-mono-< {p} {q} {r} {s} p<q r<s = <-trans (+-mono-<-≤ p<q (≤-refl {r})) (+-mono-≤-< (≤-refl {q}) r<s) + ++-monoˡ-< : ∀ r → (_+ r) Preserves _<_ ⟶ _<_ ++-monoˡ-< r p<q = +-mono-<-≤ p<q (≤-refl {r}) + ++-monoʳ-< : ∀ r → (_+_ r) Preserves _<_ ⟶ _<_ ++-monoʳ-< r p<q = +-mono-≤-< (≤-refl {r}) p<q + +------------------------------------------------------------------------ +-- Properties of _*_ +------------------------------------------------------------------------ + +private + *-nf : ℚ → ℚ → ℤ + *-nf p q = gcd (↥ p ℤ.* ↥ q) (↧ p ℤ.* ↧ q) + +↥-* : ∀ p q → ↥ (p * q) ℤ.* *-nf p q ≡ ↥ p ℤ.* ↥ q +↥-* p@record{} q@record{} = ↥-/ (↥ p ℤ.* ↥ q) (↧ₙ p ℕ.* ↧ₙ q) + +↧-* : ∀ p q → ↧ (p * q) ℤ.* *-nf p q ≡ ↧ p ℤ.* ↧ q +↧-* p@record{} q@record{} = ↧-/ (↥ p ℤ.* ↥ q) (↧ₙ p ℕ.* ↧ₙ q) + +------------------------------------------------------------------------ +-- Monomorphic to unnormalised _*_ + +toℚᵘ-homo-* : Homomorphic₂ toℚᵘ _*_ ℚᵘ._*_ +toℚᵘ-homo-* p@record{} q@record{} with *-nf p q ℤ.≟ 0ℤ +... | yes nf[p,q]≡0 = *≡* $ begin + ↥ᵘ (toℚᵘ (p * q)) ℤ.* (↧ p ℤ.* ↧ q) ≡⟨ cong (ℤ._* (↧ p ℤ.* ↧ q)) (↥ᵘ-toℚᵘ (p * q)) ⟩ + ↥ (p * q) ℤ.* (↧ p ℤ.* ↧ q) ≡⟨ cong (ℤ._* (↧ p ℤ.* ↧ q)) eq ⟩ + 0ℤ ℤ.* (↧ p ℤ.* ↧ q) ≡⟨⟩ + 0ℤ ℤ.* ↧ (p * q) ≡⟨ cong (ℤ._* ↧ (p * q)) (sym eq2) ⟩ + (↥ p ℤ.* ↥ q) ℤ.* ↧ (p * q) ≡⟨ cong ((↥ p ℤ.* ↥ q) ℤ.*_) (sym (↧ᵘ-toℚᵘ (p * q))) ⟩ + (↥ p ℤ.* ↥ q) ℤ.* ↧ᵘ (toℚᵘ (p * q)) ∎ + where + open ≡-Reasoning + eq2 : ↥ p ℤ.* ↥ q ≡ 0ℤ + eq2 = gcd[i,j]≡0⇒i≡0 (↥ p ℤ.* ↥ q) (↧ p ℤ.* ↧ q) nf[p,q]≡0 + + eq : ↥ (p * q) ≡ 0ℤ + eq rewrite eq2 = cong ↥_ (0/n≡0 (↧ₙ p ℕ.* ↧ₙ q)) +... | no nf[p,q]≢0 = *≡* (ℤ.*-cancelʳ-≡ _ _ (*-nf p q) {{ℤ.≢-nonZero nf[p,q]≢0}} $ begin + ↥ᵘ (toℚᵘ (p * q)) ℤ.* (↧ p ℤ.* ↧ q) ℤ.* *-nf p q ≡⟨ cong (λ v → v ℤ.* (↧ p ℤ.* ↧ q) ℤ.* *-nf p q) (↥ᵘ-toℚᵘ (p * q)) ⟩ + ↥ (p * q) ℤ.* (↧ p ℤ.* ↧ q) ℤ.* *-nf p q ≡⟨ xy∙z≈xz∙y (↥ (p * q)) _ _ ⟩ + ↥ (p * q) ℤ.* *-nf p q ℤ.* (↧ p ℤ.* ↧ q) ≡⟨ cong (ℤ._* (↧ p ℤ.* ↧ q)) (↥-* p q) ⟩ + (↥ p ℤ.* ↥ q) ℤ.* (↧ p ℤ.* ↧ q) ≡⟨ cong ((↥ p ℤ.* ↥ q) ℤ.*_) (sym (↧-* p q)) ⟩ + (↥ p ℤ.* ↥ q) ℤ.* (↧ (p * q) ℤ.* *-nf p q) ≡⟨ x∙yz≈xy∙z (↥ p ℤ.* ↥ q) _ _ ⟩ + (↥ p ℤ.* ↥ q) ℤ.* ↧ (p * q) ℤ.* *-nf p q ≡⟨ cong (λ v → (↥ p ℤ.* ↥ q) ℤ.* v ℤ.* *-nf p q) (↧ᵘ-toℚᵘ (p * q)) ⟨ + (↥ p ℤ.* ↥ q) ℤ.* ↧ᵘ (toℚᵘ (p * q)) ℤ.* *-nf p q ∎) + where open ≡-Reasoning; open CommSemigroupProperties ℤ.*-commutativeSemigroup + +toℚᵘ-homo-1/ : ∀ p .{{_ : NonZero p}} → toℚᵘ (1/ p) ℚᵘ.≃ (ℚᵘ.1/ toℚᵘ p) +toℚᵘ-homo-1/ (mkℚ +[1+ _ ] _ _) = ℚᵘ.≃-refl +toℚᵘ-homo-1/ (mkℚ -[1+ _ ] _ _) = ℚᵘ.≃-refl + +toℚᵘ-isMagmaHomomorphism-* : IsMagmaHomomorphism *-rawMagma ℚᵘ.*-rawMagma toℚᵘ +toℚᵘ-isMagmaHomomorphism-* = record + { isRelHomomorphism = toℚᵘ-isRelHomomorphism + ; homo = toℚᵘ-homo-* + } + +toℚᵘ-isMonoidHomomorphism-* : IsMonoidHomomorphism *-1-rawMonoid ℚᵘ.*-1-rawMonoid toℚᵘ +toℚᵘ-isMonoidHomomorphism-* = record + { isMagmaHomomorphism = toℚᵘ-isMagmaHomomorphism-* + ; ε-homo = ℚᵘ.≃-refl + } + +toℚᵘ-isMonoidMonomorphism-* : IsMonoidMonomorphism *-1-rawMonoid ℚᵘ.*-1-rawMonoid toℚᵘ +toℚᵘ-isMonoidMonomorphism-* = record + { isMonoidHomomorphism = toℚᵘ-isMonoidHomomorphism-* + ; injective = toℚᵘ-injective + } + +toℚᵘ-isNearSemiringHomomorphism-+-* : IsNearSemiringHomomorphism +-*-rawNearSemiring ℚᵘ.+-*-rawNearSemiring toℚᵘ +toℚᵘ-isNearSemiringHomomorphism-+-* = record + { +-isMonoidHomomorphism = toℚᵘ-isMonoidHomomorphism-+ + ; *-homo = toℚᵘ-homo-* + } + +toℚᵘ-isNearSemiringMonomorphism-+-* : IsNearSemiringMonomorphism +-*-rawNearSemiring ℚᵘ.+-*-rawNearSemiring toℚᵘ +toℚᵘ-isNearSemiringMonomorphism-+-* = record + { isNearSemiringHomomorphism = toℚᵘ-isNearSemiringHomomorphism-+-* + ; injective = toℚᵘ-injective + } + +toℚᵘ-isSemiringHomomorphism-+-* : IsSemiringHomomorphism +-*-rawSemiring ℚᵘ.+-*-rawSemiring toℚᵘ +toℚᵘ-isSemiringHomomorphism-+-* = record + { isNearSemiringHomomorphism = toℚᵘ-isNearSemiringHomomorphism-+-* + ; 1#-homo = ℚᵘ.≃-refl + } + +toℚᵘ-isSemiringMonomorphism-+-* : IsSemiringMonomorphism +-*-rawSemiring ℚᵘ.+-*-rawSemiring toℚᵘ +toℚᵘ-isSemiringMonomorphism-+-* = record + { isSemiringHomomorphism = toℚᵘ-isSemiringHomomorphism-+-* + ; injective = toℚᵘ-injective + } + +toℚᵘ-isRingHomomorphism-+-* : IsRingHomomorphism +-*-rawRing ℚᵘ.+-*-rawRing toℚᵘ +toℚᵘ-isRingHomomorphism-+-* = record + { isSemiringHomomorphism = toℚᵘ-isSemiringHomomorphism-+-* + ; -‿homo = toℚᵘ-homo‿- + } + +toℚᵘ-isRingMonomorphism-+-* : IsRingMonomorphism +-*-rawRing ℚᵘ.+-*-rawRing toℚᵘ +toℚᵘ-isRingMonomorphism-+-* = record + { isRingHomomorphism = toℚᵘ-isRingHomomorphism-+-* + ; injective = toℚᵘ-injective + } + +------------------------------------------------------------------------ +-- Algebraic properties + +private + module +-*-Monomorphism = RingMonomorphisms toℚᵘ-isRingMonomorphism-+-* + +*-assoc : Associative _*_ +*-assoc = +-*-Monomorphism.*-assoc ℚᵘ.*-isMagma ℚᵘ.*-assoc + +*-comm : Commutative _*_ +*-comm = +-*-Monomorphism.*-comm ℚᵘ.*-isMagma ℚᵘ.*-comm + +*-identityˡ : LeftIdentity 1ℚ _*_ +*-identityˡ = +-*-Monomorphism.*-identityˡ ℚᵘ.*-isMagma ℚᵘ.*-identityˡ + +*-identityʳ : RightIdentity 1ℚ _*_ +*-identityʳ = +-*-Monomorphism.*-identityʳ ℚᵘ.*-isMagma ℚᵘ.*-identityʳ + +*-identity : Identity 1ℚ _*_ +*-identity = *-identityˡ , *-identityʳ + +*-zeroˡ : LeftZero 0ℚ _*_ +*-zeroˡ = +-*-Monomorphism.zeroˡ ℚᵘ.+-0-isGroup ℚᵘ.*-isMagma ℚᵘ.*-zeroˡ + +*-zeroʳ : RightZero 0ℚ _*_ +*-zeroʳ = +-*-Monomorphism.zeroʳ ℚᵘ.+-0-isGroup ℚᵘ.*-isMagma ℚᵘ.*-zeroʳ + +*-zero : Zero 0ℚ _*_ +*-zero = *-zeroˡ , *-zeroʳ + +*-distribˡ-+ : _*_ DistributesOverˡ _+_ +*-distribˡ-+ = +-*-Monomorphism.distribˡ ℚᵘ.+-0-isGroup ℚᵘ.*-isMagma ℚᵘ.*-distribˡ-+ + +*-distribʳ-+ : _*_ DistributesOverʳ _+_ +*-distribʳ-+ = +-*-Monomorphism.distribʳ ℚᵘ.+-0-isGroup ℚᵘ.*-isMagma ℚᵘ.*-distribʳ-+ + +*-distrib-+ : _*_ DistributesOver _+_ +*-distrib-+ = *-distribˡ-+ , *-distribʳ-+ + +*-inverseˡ : ∀ p .{{_ : NonZero p}} → (1/ p) * p ≡ 1ℚ +*-inverseˡ p = toℚᵘ-injective (begin-equality + toℚᵘ (1/ p * p) ≃⟨ toℚᵘ-homo-* (1/ p) p ⟩ + toℚᵘ (1/ p) ℚᵘ.* toℚᵘ p ≃⟨ ℚᵘ.*-congʳ (toℚᵘ-homo-1/ p) ⟩ + ℚᵘ.1/ (toℚᵘ p) ℚᵘ.* toℚᵘ p ≃⟨ ℚᵘ.*-inverseˡ (toℚᵘ p) ⟩ + ℚᵘ.1ℚᵘ ∎) + where open ℚᵘ.≤-Reasoning + +*-inverseʳ : ∀ p .{{_ : NonZero p}} → p * (1/ p) ≡ 1ℚ +*-inverseʳ p = trans (*-comm p (1/ p)) (*-inverseˡ p) + +neg-distribˡ-* : ∀ p q → - (p * q) ≡ - p * q +neg-distribˡ-* = +-*-Monomorphism.neg-distribˡ-* ℚᵘ.+-0-isGroup ℚᵘ.*-isMagma ℚᵘ.neg-distribˡ-* + +neg-distribʳ-* : ∀ p q → - (p * q) ≡ p * - q +neg-distribʳ-* = +-*-Monomorphism.neg-distribʳ-* ℚᵘ.+-0-isGroup ℚᵘ.*-isMagma ℚᵘ.neg-distribʳ-* + +------------------------------------------------------------------------ +-- Structures + +*-isMagma : IsMagma _*_ +*-isMagma = +-*-Monomorphism.*-isMagma ℚᵘ.*-isMagma + +*-isSemigroup : IsSemigroup _*_ +*-isSemigroup = +-*-Monomorphism.*-isSemigroup ℚᵘ.*-isSemigroup + +*-1-isMonoid : IsMonoid _*_ 1ℚ +*-1-isMonoid = +-*-Monomorphism.*-isMonoid ℚᵘ.*-1-isMonoid + +*-1-isCommutativeMonoid : IsCommutativeMonoid _*_ 1ℚ +*-1-isCommutativeMonoid = +-*-Monomorphism.*-isCommutativeMonoid ℚᵘ.*-1-isCommutativeMonoid + ++-*-isRing : IsRing _+_ _*_ -_ 0ℚ 1ℚ ++-*-isRing = +-*-Monomorphism.isRing ℚᵘ.+-*-isRing + ++-*-isCommutativeRing : IsCommutativeRing _+_ _*_ -_ 0ℚ 1ℚ ++-*-isCommutativeRing = +-*-Monomorphism.isCommutativeRing ℚᵘ.+-*-isCommutativeRing + +------------------------------------------------------------------------ +-- Packages + +*-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 + } + +------------------------------------------------------------------------ +-- Properties of _*_ and _≤_ + +*-cancelʳ-≤-pos : ∀ r .{{_ : Positive r}} → p * r ≤ q * r → p ≤ q +*-cancelʳ-≤-pos {p} {q} r pr≤qr = toℚᵘ-cancel-≤ (ℚᵘ.*-cancelʳ-≤-pos (toℚᵘ r) (begin + toℚᵘ p ℚᵘ.* toℚᵘ r ≃⟨ toℚᵘ-homo-* p r ⟨ + toℚᵘ (p * r) ≤⟨ toℚᵘ-mono-≤ pr≤qr ⟩ + toℚᵘ (q * r) ≃⟨ toℚᵘ-homo-* q r ⟩ + toℚᵘ q ℚᵘ.* toℚᵘ r ∎)) + where open ℚᵘ.≤-Reasoning + +*-cancelˡ-≤-pos : ∀ r .{{_ : Positive r}} → r * p ≤ r * q → p ≤ q +*-cancelˡ-≤-pos {p} {q} r rewrite *-comm r p | *-comm r q = *-cancelʳ-≤-pos r + +*-monoʳ-≤-nonNeg : ∀ r .{{_ : NonNegative r}} → (_* r) Preserves _≤_ ⟶ _≤_ +*-monoʳ-≤-nonNeg r {p} {q} p≤q = toℚᵘ-cancel-≤ (begin + toℚᵘ (p * r) ≃⟨ toℚᵘ-homo-* p r ⟩ + toℚᵘ p ℚᵘ.* toℚᵘ r ≤⟨ ℚᵘ.*-monoˡ-≤-nonNeg (toℚᵘ r) (toℚᵘ-mono-≤ p≤q) ⟩ + toℚᵘ q ℚᵘ.* toℚᵘ r ≃⟨ toℚᵘ-homo-* q r ⟨ + toℚᵘ (q * r) ∎) + where open ℚᵘ.≤-Reasoning + +*-monoˡ-≤-nonNeg : ∀ r .{{_ : NonNegative r}} → (r *_) Preserves _≤_ ⟶ _≤_ +*-monoˡ-≤-nonNeg r {p} {q} rewrite *-comm r p | *-comm r q = *-monoʳ-≤-nonNeg r + +*-monoʳ-≤-nonPos : ∀ r .{{_ : NonPositive r}} → (_* r) Preserves _≤_ ⟶ _≥_ +*-monoʳ-≤-nonPos r {p} {q} p≤q = toℚᵘ-cancel-≤ (begin + toℚᵘ (q * r) ≃⟨ toℚᵘ-homo-* q r ⟩ + toℚᵘ q ℚᵘ.* toℚᵘ r ≤⟨ ℚᵘ.*-monoˡ-≤-nonPos (toℚᵘ r) (toℚᵘ-mono-≤ p≤q) ⟩ + toℚᵘ p ℚᵘ.* toℚᵘ r ≃⟨ toℚᵘ-homo-* p r ⟨ + toℚᵘ (p * r) ∎) + where open ℚᵘ.≤-Reasoning + +*-monoˡ-≤-nonPos : ∀ r .{{_ : NonPositive r}} → (r *_) Preserves _≤_ ⟶ _≥_ +*-monoˡ-≤-nonPos r {p} {q} rewrite *-comm r p | *-comm r q = *-monoʳ-≤-nonPos r + +*-cancelʳ-≤-neg : ∀ r .{{_ : Negative r}} → p * r ≤ q * r → p ≥ q +*-cancelʳ-≤-neg {p} {q} r pr≤qr = toℚᵘ-cancel-≤ (ℚᵘ.*-cancelʳ-≤-neg _ (begin + toℚᵘ p ℚᵘ.* toℚᵘ r ≃⟨ toℚᵘ-homo-* p r ⟨ + toℚᵘ (p * r) ≤⟨ toℚᵘ-mono-≤ pr≤qr ⟩ + toℚᵘ (q * r) ≃⟨ toℚᵘ-homo-* q r ⟩ + toℚᵘ q ℚᵘ.* toℚᵘ r ∎)) + where open ℚᵘ.≤-Reasoning + +*-cancelˡ-≤-neg : ∀ r .{{_ : Negative r}} → r * p ≤ r * q → p ≥ q +*-cancelˡ-≤-neg {p} {q} r rewrite *-comm r p | *-comm r q = *-cancelʳ-≤-neg r + +------------------------------------------------------------------------ +-- Properties of _*_ and _<_ + +*-monoˡ-<-pos : ∀ r .{{_ : Positive r}} → (_* r) Preserves _<_ ⟶ _<_ +*-monoˡ-<-pos r {p} {q} p<q = toℚᵘ-cancel-< (begin-strict + toℚᵘ (p * r) ≃⟨ toℚᵘ-homo-* p r ⟩ + toℚᵘ p ℚᵘ.* toℚᵘ r <⟨ ℚᵘ.*-monoˡ-<-pos (toℚᵘ r) (toℚᵘ-mono-< p<q) ⟩ + toℚᵘ q ℚᵘ.* toℚᵘ r ≃⟨ toℚᵘ-homo-* q r ⟨ + toℚᵘ (q * r) ∎) + where open ℚᵘ.≤-Reasoning + +*-monoʳ-<-pos : ∀ r .{{_ : Positive r}} → (r *_) Preserves _<_ ⟶ _<_ +*-monoʳ-<-pos r {p} {q} rewrite *-comm r p | *-comm r q = *-monoˡ-<-pos r + +*-cancelˡ-<-nonNeg : ∀ r .{{_ : NonNegative r}} → ∀ {p q} → r * p < r * q → p < q +*-cancelˡ-<-nonNeg r {p} {q} rp<rq = toℚᵘ-cancel-< (ℚᵘ.*-cancelˡ-<-nonNeg (toℚᵘ r) (begin-strict + toℚᵘ r ℚᵘ.* toℚᵘ p ≃⟨ toℚᵘ-homo-* r p ⟨ + toℚᵘ (r * p) <⟨ toℚᵘ-mono-< rp<rq ⟩ + toℚᵘ (r * q) ≃⟨ toℚᵘ-homo-* r q ⟩ + toℚᵘ r ℚᵘ.* toℚᵘ q ∎)) + where open ℚᵘ.≤-Reasoning + +*-cancelʳ-<-nonNeg : ∀ r .{{_ : NonNegative r}} → ∀ {p q} → p * r < q * r → p < q +*-cancelʳ-<-nonNeg r {p} {q} rewrite *-comm p r | *-comm q r = *-cancelˡ-<-nonNeg r + +*-monoˡ-<-neg : ∀ r .{{_ : Negative r}} → (_* r) Preserves _<_ ⟶ _>_ +*-monoˡ-<-neg r {p} {q} p<q = toℚᵘ-cancel-< (begin-strict + toℚᵘ (q * r) ≃⟨ toℚᵘ-homo-* q r ⟩ + toℚᵘ q ℚᵘ.* toℚᵘ r <⟨ ℚᵘ.*-monoˡ-<-neg (toℚᵘ r) (toℚᵘ-mono-< p<q) ⟩ + toℚᵘ p ℚᵘ.* toℚᵘ r ≃⟨ toℚᵘ-homo-* p r ⟨ + toℚᵘ (p * r) ∎) + where open ℚᵘ.≤-Reasoning + +*-monoʳ-<-neg : ∀ r .{{_ : Negative r}} → (r *_) Preserves _<_ ⟶ _>_ +*-monoʳ-<-neg r {p} {q} rewrite *-comm r p | *-comm r q = *-monoˡ-<-neg r + +*-cancelˡ-<-nonPos : ∀ r .{{_ : NonPositive r}} → r * p < r * q → p > q +*-cancelˡ-<-nonPos {p} {q} r rp<rq = toℚᵘ-cancel-< (ℚᵘ.*-cancelˡ-<-nonPos (toℚᵘ r) (begin-strict + toℚᵘ r ℚᵘ.* toℚᵘ p ≃⟨ toℚᵘ-homo-* r p ⟨ + toℚᵘ (r * p) <⟨ toℚᵘ-mono-< rp<rq ⟩ + toℚᵘ (r * q) ≃⟨ toℚᵘ-homo-* r q ⟩ + toℚᵘ r ℚᵘ.* toℚᵘ q ∎)) + where open ℚᵘ.≤-Reasoning + +*-cancelʳ-<-nonPos : ∀ r .{{_ : NonPositive r}} → p * r < q * r → p > q +*-cancelʳ-<-nonPos {p} {q} r rewrite *-comm p r | *-comm q r = *-cancelˡ-<-nonPos r + +------------------------------------------------------------------------ +-- Properties of _⊓_ +------------------------------------------------------------------------ + +p≤q⇒p⊔q≡q : p ≤ q → p ⊔ q ≡ q +p≤q⇒p⊔q≡q {p@record{}} {q@record{}} p≤q with p ≤ᵇ q in p≰q +... | true = refl +... | false = contradiction (≤⇒≤ᵇ p≤q) (subst (¬_ ∘ T) (sym p≰q) λ()) + +p≥q⇒p⊔q≡p : p ≥ q → p ⊔ q ≡ p +p≥q⇒p⊔q≡p {p@record{}} {q@record{}} p≥q with p ≤ᵇ q in p≤q +... | true = ≤-antisym p≥q (≤ᵇ⇒≤ (subst T (sym p≤q) _)) +... | false = refl + +p≤q⇒p⊓q≡p : p ≤ q → p ⊓ q ≡ p +p≤q⇒p⊓q≡p {p@record{}} {q@record{}} p≤q with p ≤ᵇ q in p≰q +... | true = refl +... | false = contradiction (≤⇒≤ᵇ p≤q) (subst (¬_ ∘ T) (sym p≰q) λ()) + +p≥q⇒p⊓q≡q : p ≥ q → p ⊓ q ≡ q +p≥q⇒p⊓q≡q {p@record{}} {q@record{}} p≥q with p ≤ᵇ q in p≤q +... | true = ≤-antisym (≤ᵇ⇒≤ (subst T (sym p≤q) _)) p≥q +... | false = refl + +⊓-operator : MinOperator ≤-totalPreorder +⊓-operator = record + { x≤y⇒x⊓y≈x = p≤q⇒p⊓q≡p + ; x≥y⇒x⊓y≈y = p≥q⇒p⊓q≡q + } + +⊔-operator : MaxOperator ≤-totalPreorder +⊔-operator = record + { x≤y⇒x⊔y≈y = p≤q⇒p⊔q≡q + ; x≥y⇒x⊔y≈x = p≥q⇒p⊔q≡p + } + +------------------------------------------------------------------------ +-- Automatically derived properties of _⊓_ and _⊔_ + +private + module ⊓-⊔-properties = MinMaxOp ⊓-operator ⊔-operator + module ⊓-⊔-latticeProperties = LatticeMinMaxOp ⊓-operator ⊔-operator + +open ⊓-⊔-properties public + using + ( ⊓-idem -- : Idempotent _⊓_ + ; ⊓-sel -- : Selective _⊓_ + ; ⊓-assoc -- : Associative _⊓_ + ; ⊓-comm -- : Commutative _⊓_ + + ; ⊔-idem -- : Idempotent _⊔_ + ; ⊔-sel -- : Selective _⊔_ + ; ⊔-assoc -- : Associative _⊔_ + ; ⊔-comm -- : Commutative _⊔_ + + ; ⊓-distribˡ-⊔ -- : _⊓_ DistributesOverˡ _⊔_ + ; ⊓-distribʳ-⊔ -- : _⊓_ DistributesOverʳ _⊔_ + ; ⊓-distrib-⊔ -- : _⊓_ DistributesOver _⊔_ + ; ⊔-distribˡ-⊓ -- : _⊔_ DistributesOverˡ _⊓_ + ; ⊔-distribʳ-⊓ -- : _⊔_ DistributesOverʳ _⊓_ + ; ⊔-distrib-⊓ -- : _⊔_ DistributesOver _⊓_ + ; ⊓-absorbs-⊔ -- : _⊓_ Absorbs _⊔_ + ; ⊔-absorbs-⊓ -- : _⊔_ Absorbs _⊓_ + ; ⊔-⊓-absorptive -- : Absorptive _⊔_ _⊓_ + ; ⊓-⊔-absorptive -- : Absorptive _⊓_ _⊔_ + + ; ⊓-isMagma -- : IsMagma _⊓_ + ; ⊓-isSemigroup -- : IsSemigroup _⊓_ + ; ⊓-isCommutativeSemigroup -- : IsCommutativeSemigroup _⊓_ + ; ⊓-isBand -- : IsBand _⊓_ + ; ⊓-isSelectiveMagma -- : IsSelectiveMagma _⊓_ + + ; ⊔-isMagma -- : IsMagma _⊔_ + ; ⊔-isSemigroup -- : IsSemigroup _⊔_ + ; ⊔-isCommutativeSemigroup -- : IsCommutativeSemigroup _⊔_ + ; ⊔-isBand -- : IsBand _⊔_ + ; ⊔-isSelectiveMagma -- : IsSelectiveMagma _⊔_ + + ; ⊓-magma -- : Magma _ _ + ; ⊓-semigroup -- : Semigroup _ _ + ; ⊓-band -- : Band _ _ + ; ⊓-commutativeSemigroup -- : CommutativeSemigroup _ _ + ; ⊓-selectiveMagma -- : SelectiveMagma _ _ + + ; ⊔-magma -- : Magma _ _ + ; ⊔-semigroup -- : Semigroup _ _ + ; ⊔-band -- : Band _ _ + ; ⊔-commutativeSemigroup -- : CommutativeSemigroup _ _ + ; ⊔-selectiveMagma -- : SelectiveMagma _ _ + + ; ⊓-glb -- : ∀ {p q r} → p ≥ r → q ≥ r → p ⊓ q ≥ r + ; ⊓-triangulate -- : ∀ p q r → p ⊓ q ⊓ r ≡ (p ⊓ q) ⊓ (q ⊓ r) + ; ⊓-mono-≤ -- : _⊓_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ + ; ⊓-monoˡ-≤ -- : ∀ p → (_⊓ p) Preserves _≤_ ⟶ _≤_ + ; ⊓-monoʳ-≤ -- : ∀ p → (p ⊓_) Preserves _≤_ ⟶ _≤_ + + ; ⊔-lub -- : ∀ {p q r} → p ≤ r → q ≤ r → p ⊔ q ≤ r + ; ⊔-triangulate -- : ∀ p q r → p ⊔ q ⊔ r ≡ (p ⊔ q) ⊔ (q ⊔ r) + ; ⊔-mono-≤ -- : _⊔_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_ + ; ⊔-monoˡ-≤ -- : ∀ p → (_⊔ p) Preserves _≤_ ⟶ _≤_ + ; ⊔-monoʳ-≤ -- : ∀ p → (p ⊔_) Preserves _≤_ ⟶ _≤_ + ) + renaming + ( x⊓y≈y⇒y≤x to p⊓q≡q⇒q≤p -- : ∀ {p q} → p ⊓ q ≡ q → q ≤ p + ; x⊓y≈x⇒x≤y to p⊓q≡p⇒p≤q -- : ∀ {p q} → p ⊓ q ≡ p → p ≤ q + ; x⊓y≤x to p⊓q≤p -- : ∀ p q → p ⊓ q ≤ p + ; x⊓y≤y to p⊓q≤q -- : ∀ p q → p ⊓ q ≤ q + ; x≤y⇒x⊓z≤y to p≤q⇒p⊓r≤q -- : ∀ {p q} r → p ≤ q → p ⊓ r ≤ q + ; x≤y⇒z⊓x≤y to p≤q⇒r⊓p≤q -- : ∀ {p q} r → p ≤ q → r ⊓ p ≤ q + ; x≤y⊓z⇒x≤y to p≤q⊓r⇒p≤q -- : ∀ {p} q r → p ≤ q ⊓ r → p ≤ q + ; x≤y⊓z⇒x≤z to p≤q⊓r⇒p≤r -- : ∀ {p} q r → p ≤ q ⊓ r → p ≤ r + + ; x⊔y≈y⇒x≤y to p⊔q≡q⇒p≤q -- : ∀ {p q} → p ⊔ q ≡ q → p ≤ q + ; x⊔y≈x⇒y≤x to p⊔q≡p⇒q≤p -- : ∀ {p q} → p ⊔ q ≡ p → q ≤ p + ; x≤x⊔y to p≤p⊔q -- : ∀ p q → p ≤ p ⊔ q + ; x≤y⊔x to p≤q⊔p -- : ∀ p q → p ≤ q ⊔ p + ; x≤y⇒x≤y⊔z to p≤q⇒p≤q⊔r -- : ∀ {p q} r → p ≤ q → p ≤ q ⊔ r + ; x≤y⇒x≤z⊔y to p≤q⇒p≤r⊔q -- : ∀ {p q} r → p ≤ q → p ≤ r ⊔ q + ; x⊔y≤z⇒x≤z to p⊔q≤r⇒p≤r -- : ∀ p q {r} → p ⊔ q ≤ r → p ≤ r + ; x⊔y≤z⇒y≤z to p⊔q≤r⇒q≤r -- : ∀ p q {r} → p ⊔ q ≤ r → q ≤ r + + ; x⊓y≤x⊔y to p⊓q≤p⊔q -- : ∀ p q → p ⊓ q ≤ p ⊔ q + ) + +open ⊓-⊔-latticeProperties public + using + ( ⊓-isSemilattice -- : IsSemilattice _⊓_ + ; ⊔-isSemilattice -- : IsSemilattice _⊔_ + ; ⊔-⊓-isLattice -- : IsLattice _⊔_ _⊓_ + ; ⊓-⊔-isLattice -- : IsLattice _⊓_ _⊔_ + ; ⊔-⊓-isDistributiveLattice -- : IsDistributiveLattice _⊔_ _⊓_ + ; ⊓-⊔-isDistributiveLattice -- : IsDistributiveLattice _⊓_ _⊔_ + + ; ⊓-semilattice -- : Semilattice _ _ + ; ⊔-semilattice -- : Semilattice _ _ + ; ⊔-⊓-lattice -- : Lattice _ _ + ; ⊓-⊔-lattice -- : Lattice _ _ + ; ⊔-⊓-distributiveLattice -- : DistributiveLattice _ _ + ; ⊓-⊔-distributiveLattice -- : DistributiveLattice _ _ + ) + +------------------------------------------------------------------------ +-- Other properties of _⊓_ and _⊔_ + +mono-≤-distrib-⊔ : ∀ {f} → f Preserves _≤_ ⟶ _≤_ → + ∀ p q → f (p ⊔ q) ≡ f p ⊔ f q +mono-≤-distrib-⊔ {f} = ⊓-⊔-properties.mono-≤-distrib-⊔ (cong f) + +mono-≤-distrib-⊓ : ∀ {f} → f Preserves _≤_ ⟶ _≤_ → + ∀ p q → f (p ⊓ q) ≡ f p ⊓ f q +mono-≤-distrib-⊓ {f} = ⊓-⊔-properties.mono-≤-distrib-⊓ (cong f) + +mono-<-distrib-⊓ : ∀ {f} → f Preserves _<_ ⟶ _<_ → + ∀ p q → f (p ⊓ q) ≡ f p ⊓ f q +mono-<-distrib-⊓ {f} f-mono-< p q with <-cmp p q +... | tri< p<q p≢r p≯q = begin + f (p ⊓ q) ≡⟨ cong f (p≤q⇒p⊓q≡p (<⇒≤ p<q)) ⟩ + f p ≡⟨ p≤q⇒p⊓q≡p (<⇒≤ (f-mono-< p<q)) ⟨ + f p ⊓ f q ∎ + where open ≡-Reasoning +... | tri≈ p≮q refl p≯q = begin + f (p ⊓ q) ≡⟨ cong f (⊓-idem p) ⟩ + f p ≡⟨ ⊓-idem (f p) ⟨ + f p ⊓ f q ∎ + where open ≡-Reasoning +... | tri> p≮q p≡r p>q = begin + f (p ⊓ q) ≡⟨ cong f (p≥q⇒p⊓q≡q (<⇒≤ p>q)) ⟩ + f q ≡⟨ p≥q⇒p⊓q≡q (<⇒≤ (f-mono-< p>q)) ⟨ + f p ⊓ f q ∎ + where open ≡-Reasoning + +mono-<-distrib-⊔ : ∀ {f} → f Preserves _<_ ⟶ _<_ → + ∀ p q → f (p ⊔ q) ≡ f p ⊔ f q +mono-<-distrib-⊔ {f} f-mono-< p q with <-cmp p q +... | tri< p<q p≢r p≯q = begin + f (p ⊔ q) ≡⟨ cong f (p≤q⇒p⊔q≡q (<⇒≤ p<q)) ⟩ + f q ≡⟨ p≤q⇒p⊔q≡q (<⇒≤ (f-mono-< p<q)) ⟨ + f p ⊔ f q ∎ + where open ≡-Reasoning +... | tri≈ p≮q refl p≯q = begin + f (p ⊔ q) ≡⟨ cong f (⊔-idem p) ⟩ + f q ≡⟨ ⊔-idem (f p) ⟨ + f p ⊔ f q ∎ + where open ≡-Reasoning +... | tri> p≮q p≡r p>q = begin + f (p ⊔ q) ≡⟨ cong f (p≥q⇒p⊔q≡p (<⇒≤ p>q)) ⟩ + f p ≡⟨ p≥q⇒p⊔q≡p (<⇒≤ (f-mono-< p>q)) ⟨ + f p ⊔ f q ∎ + where open ≡-Reasoning + +antimono-≤-distrib-⊓ : ∀ {f} → f Preserves _≤_ ⟶ _≥_ → + ∀ p q → f (p ⊓ q) ≡ f p ⊔ f q +antimono-≤-distrib-⊓ {f} = ⊓-⊔-properties.antimono-≤-distrib-⊓ (cong f) + +antimono-≤-distrib-⊔ : ∀ {f} → f Preserves _≤_ ⟶ _≥_ → + ∀ p q → f (p ⊔ q) ≡ f p ⊓ f q +antimono-≤-distrib-⊔ {f} = ⊓-⊔-properties.antimono-≤-distrib-⊔ (cong f) + +------------------------------------------------------------------------ +-- Properties of _⊓_ and _*_ + +*-distribˡ-⊓-nonNeg : ∀ p .{{_ : NonNegative p}} → ∀ q r → p * (q ⊓ r) ≡ (p * q) ⊓ (p * r) +*-distribˡ-⊓-nonNeg p = mono-≤-distrib-⊓ (*-monoˡ-≤-nonNeg p) + +*-distribʳ-⊓-nonNeg : ∀ p .{{_ : NonNegative p}} → ∀ q r → (q ⊓ r) * p ≡ (q * p) ⊓ (r * p) +*-distribʳ-⊓-nonNeg p = mono-≤-distrib-⊓ (*-monoʳ-≤-nonNeg p) + +*-distribˡ-⊔-nonNeg : ∀ p .{{_ : NonNegative p}} → ∀ q r → p * (q ⊔ r) ≡ (p * q) ⊔ (p * r) +*-distribˡ-⊔-nonNeg p = mono-≤-distrib-⊔ (*-monoˡ-≤-nonNeg p) + +*-distribʳ-⊔-nonNeg : ∀ p .{{_ : NonNegative p}} → ∀ q r → (q ⊔ r) * p ≡ (q * p) ⊔ (r * p) +*-distribʳ-⊔-nonNeg p = mono-≤-distrib-⊔ (*-monoʳ-≤-nonNeg p) + +------------------------------------------------------------------------ +-- Properties of _⊓_, _⊔_ and _*_ + +*-distribˡ-⊔-nonPos : ∀ p .{{_ : NonPositive p}} → ∀ q r → p * (q ⊔ r) ≡ (p * q) ⊓ (p * r) +*-distribˡ-⊔-nonPos p = antimono-≤-distrib-⊔ (*-monoˡ-≤-nonPos p) + +*-distribʳ-⊔-nonPos : ∀ p .{{_ : NonPositive p}} → ∀ q r → (q ⊔ r) * p ≡ (q * p) ⊓ (r * p) +*-distribʳ-⊔-nonPos p = antimono-≤-distrib-⊔ (*-monoʳ-≤-nonPos p) + +*-distribˡ-⊓-nonPos : ∀ p .{{_ : NonPositive p}} → ∀ q r → p * (q ⊓ r) ≡ (p * q) ⊔ (p * r) +*-distribˡ-⊓-nonPos p = antimono-≤-distrib-⊓ (*-monoˡ-≤-nonPos p) + +*-distribʳ-⊓-nonPos : ∀ p .{{_ : NonPositive p}} → ∀ q r → (q ⊓ r) * p ≡ (q * p) ⊔ (r * p) +*-distribʳ-⊓-nonPos p = antimono-≤-distrib-⊓ (*-monoʳ-≤-nonPos p) + +------------------------------------------------------------------------ +-- Properties of 1/_ +------------------------------------------------------------------------ + +nonZero⇒1/nonZero : ∀ p .{{_ : NonZero p}} → NonZero (1/ p) +nonZero⇒1/nonZero (mkℚ +[1+ _ ] _ _) = _ +nonZero⇒1/nonZero (mkℚ -[1+ _ ] _ _) = _ + +1/-involutive : ∀ p .{{_ : NonZero p}} → (1/ (1/ p)) {{nonZero⇒1/nonZero p}} ≡ p +1/-involutive (mkℚ +[1+ n ] d-1 _) = refl +1/-involutive (mkℚ -[1+ n ] d-1 _) = refl + +1/pos⇒pos : ∀ p .{{_ : Positive p}} → Positive ((1/ p) {{pos⇒nonZero p}}) +1/pos⇒pos (mkℚ +[1+ _ ] _ _) = _ + +1/neg⇒neg : ∀ p .{{_ : Negative p}} → Negative ((1/ p) {{neg⇒nonZero p}}) +1/neg⇒neg (mkℚ -[1+ _ ] _ _) = _ + +pos⇒1/pos : ∀ p .{{_ : NonZero p}} .{{_ : Positive (1/ p)}} → Positive p +pos⇒1/pos p = subst Positive (1/-involutive p) (1/pos⇒pos (1/ p)) + +neg⇒1/neg : ∀ p .{{_ : NonZero p}} .{{_ : Negative (1/ p)}} → Negative p +neg⇒1/neg p = subst Negative (1/-involutive p) (1/neg⇒neg (1/ p)) + +------------------------------------------------------------------------ +-- Properties of ∣_∣ +------------------------------------------------------------------------ + +------------------------------------------------------------------------ +-- Monomorphic to unnormalised -_ + +toℚᵘ-homo-∣-∣ : Homomorphic₁ toℚᵘ ∣_∣ ℚᵘ.∣_∣ +toℚᵘ-homo-∣-∣ (mkℚ +[1+ _ ] _ _) = *≡* refl +toℚᵘ-homo-∣-∣ (mkℚ +0 _ _) = *≡* refl +toℚᵘ-homo-∣-∣ (mkℚ -[1+ _ ] _ _) = *≡* refl + +------------------------------------------------------------------------ +-- Properties + +∣p∣≡0⇒p≡0 : ∀ p → ∣ p ∣ ≡ 0ℚ → p ≡ 0ℚ +∣p∣≡0⇒p≡0 (mkℚ +0 zero _) ∣p∣≡0 = refl + +0≤∣p∣ : ∀ p → 0ℚ ≤ ∣ p ∣ +0≤∣p∣ p@record{} = *≤* (begin + (↥ 0ℚ) ℤ.* (↧ ∣ p ∣) ≡⟨ ℤ.*-zeroˡ (↧ ∣ p ∣) ⟩ + 0ℤ ≤⟨ ℤ.+≤+ ℕ.z≤n ⟩ + ↥ ∣ p ∣ ≡⟨ ℤ.*-identityʳ (↥ ∣ p ∣) ⟨ + ↥ ∣ p ∣ ℤ.* 1ℤ ∎) + where open ℤ.≤-Reasoning + +0≤p⇒∣p∣≡p : 0ℚ ≤ p → ∣ p ∣ ≡ p +0≤p⇒∣p∣≡p {p@record{}} 0≤p = toℚᵘ-injective (ℚᵘ.0≤p⇒∣p∣≃p (toℚᵘ-mono-≤ 0≤p)) + +∣-p∣≡∣p∣ : ∀ p → ∣ - p ∣ ≡ ∣ p ∣ +∣-p∣≡∣p∣ (mkℚ +[1+ n ] d-1 _) = refl +∣-p∣≡∣p∣ (mkℚ +0 d-1 _) = refl +∣-p∣≡∣p∣ (mkℚ -[1+ n ] d-1 _) = refl + +∣p∣≡p⇒0≤p : ∀ {p} → ∣ p ∣ ≡ p → 0ℚ ≤ p +∣p∣≡p⇒0≤p {p} ∣p∣≡p = toℚᵘ-cancel-≤ (ℚᵘ.∣p∣≃p⇒0≤p (begin-equality + ℚᵘ.∣ toℚᵘ p ∣ ≃⟨ ℚᵘ.≃-sym (toℚᵘ-homo-∣-∣ p) ⟩ + toℚᵘ ∣ p ∣ ≡⟨ cong toℚᵘ ∣p∣≡p ⟩ + toℚᵘ p ∎)) + where open ℚᵘ.≤-Reasoning + +∣p∣≡p∨∣p∣≡-p : ∀ p → ∣ p ∣ ≡ p ⊎ ∣ p ∣ ≡ - p +∣p∣≡p∨∣p∣≡-p (mkℚ (+ n) d-1 _) = inj₁ refl +∣p∣≡p∨∣p∣≡-p (mkℚ (-[1+ n ]) d-1 _) = inj₂ refl + +∣p+q∣≤∣p∣+∣q∣ : ∀ p q → ∣ p + q ∣ ≤ ∣ p ∣ + ∣ q ∣ +∣p+q∣≤∣p∣+∣q∣ p q = toℚᵘ-cancel-≤ (begin + toℚᵘ ∣ p + q ∣ ≃⟨ toℚᵘ-homo-∣-∣ (p + q) ⟩ + ℚᵘ.∣ toℚᵘ (p + q) ∣ ≃⟨ ℚᵘ.∣-∣-cong (toℚᵘ-homo-+ p q) ⟩ + ℚᵘ.∣ toℚᵘ p ℚᵘ.+ toℚᵘ q ∣ ≤⟨ ℚᵘ.∣p+q∣≤∣p∣+∣q∣ (toℚᵘ p) (toℚᵘ q) ⟩ + ℚᵘ.∣ toℚᵘ p ∣ ℚᵘ.+ ℚᵘ.∣ toℚᵘ q ∣ ≃⟨ ℚᵘ.+-cong (toℚᵘ-homo-∣-∣ p) (toℚᵘ-homo-∣-∣ q) ⟨ + toℚᵘ ∣ p ∣ ℚᵘ.+ toℚᵘ ∣ q ∣ ≃⟨ toℚᵘ-homo-+ ∣ p ∣ ∣ q ∣ ⟨ + toℚᵘ (∣ p ∣ + ∣ q ∣) ∎) + where open ℚᵘ.≤-Reasoning + +∣p-q∣≤∣p∣+∣q∣ : ∀ p q → ∣ p - q ∣ ≤ ∣ p ∣ + ∣ q ∣ +∣p-q∣≤∣p∣+∣q∣ p@record{} q@record{} = begin + ∣ p - q ∣ ≤⟨ ∣p+q∣≤∣p∣+∣q∣ p (- q) ⟩ + ∣ p ∣ + ∣ - q ∣ ≡⟨ cong (λ h → ∣ p ∣ + h) (∣-p∣≡∣p∣ q) ⟩ + ∣ p ∣ + ∣ q ∣ ∎ + where open ≤-Reasoning + +∣p*q∣≡∣p∣*∣q∣ : ∀ p q → ∣ p * q ∣ ≡ ∣ p ∣ * ∣ q ∣ +∣p*q∣≡∣p∣*∣q∣ p q = toℚᵘ-injective (begin-equality + toℚᵘ ∣ p * q ∣ ≃⟨ toℚᵘ-homo-∣-∣ (p * q) ⟩ + ℚᵘ.∣ toℚᵘ (p * q) ∣ ≃⟨ ℚᵘ.∣-∣-cong (toℚᵘ-homo-* p q) ⟩ + ℚᵘ.∣ toℚᵘ p ℚᵘ.* toℚᵘ q ∣ ≃⟨ ℚᵘ.∣p*q∣≃∣p∣*∣q∣ (toℚᵘ p) (toℚᵘ q) ⟩ + ℚᵘ.∣ toℚᵘ p ∣ ℚᵘ.* ℚᵘ.∣ toℚᵘ q ∣ ≃⟨ ℚᵘ.*-cong (toℚᵘ-homo-∣-∣ p) (toℚᵘ-homo-∣-∣ q) ⟨ + toℚᵘ ∣ p ∣ ℚᵘ.* toℚᵘ ∣ q ∣ ≃⟨ toℚᵘ-homo-* ∣ p ∣ ∣ q ∣ ⟨ + toℚᵘ (∣ p ∣ * ∣ q ∣) ∎) + where open ℚᵘ.≤-Reasoning + +∣-∣-nonNeg : ∀ p → NonNegative ∣ p ∣ +∣-∣-nonNeg (mkℚ +[1+ _ ] _ _) = _ +∣-∣-nonNeg (mkℚ +0 _ _) = _ +∣-∣-nonNeg (mkℚ -[1+ _ ] _ _) = _ + +∣∣p∣∣≡∣p∣ : ∀ p → ∣ ∣ p ∣ ∣ ≡ ∣ p ∣ +∣∣p∣∣≡∣p∣ p = 0≤p⇒∣p∣≡p (0≤∣p∣ p) + + +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 2.0 + +*-monoʳ-≤-neg : ∀ r → Negative r → (_* r) Preserves _≤_ ⟶ _≥_ +*-monoʳ-≤-neg r@(mkℚ -[1+ _ ] _ _) _ = *-monoʳ-≤-nonPos r +{-# WARNING_ON_USAGE *-monoʳ-≤-neg +"Warning: *-monoʳ-≤-neg was deprecated in v2.0. Please use *-monoʳ-≤-nonPos instead." -#-} -*-monoˡ-≤-neg : ∀ r → Negative r → (r *_) Preserves _≤_ ⟶ _≥_ -*-monoˡ-≤-neg r@(mkℚ -[1+ _ ] _ _) _ = *-monoˡ-≤-nonPos r -{-# WARNING_ON_USAGE *-monoˡ-≤-neg -"Warning: *-monoˡ-≤-neg was deprecated in v2.0. +#-} +*-monoˡ-≤-neg : ∀ r → Negative r → (r *_) Preserves _≤_ ⟶ _≥_ +*-monoˡ-≤-neg r@(mkℚ -[1+ _ ] _ _) _ = *-monoˡ-≤-nonPos r +{-# WARNING_ON_USAGE *-monoˡ-≤-neg +"Warning: *-monoˡ-≤-neg was deprecated in v2.0. Please use *-monoˡ-≤-nonPos instead." -#-} -*-monoʳ-≤-pos : ∀ r → Positive r → (_* r) Preserves _≤_ ⟶ _≤_ -*-monoʳ-≤-pos r@(mkℚ +[1+ _ ] _ _) _ = *-monoʳ-≤-nonNeg r -{-# WARNING_ON_USAGE *-monoʳ-≤-pos -"Warning: *-monoʳ-≤-pos was deprecated in v2.0. +#-} +*-monoʳ-≤-pos : ∀ r → Positive r → (_* r) Preserves _≤_ ⟶ _≤_ +*-monoʳ-≤-pos r@(mkℚ +[1+ _ ] _ _) _ = *-monoʳ-≤-nonNeg r +{-# WARNING_ON_USAGE *-monoʳ-≤-pos +"Warning: *-monoʳ-≤-pos was deprecated in v2.0. Please use *-monoʳ-≤-nonNeg instead." -#-} -*-monoˡ-≤-pos : ∀ r → Positive r → (r *_) Preserves _≤_ ⟶ _≤_ -*-monoˡ-≤-pos r@(mkℚ +[1+ _ ] _ _) _ = *-monoˡ-≤-nonNeg r -{-# WARNING_ON_USAGE *-monoˡ-≤-pos -"Warning: *-monoˡ-≤-pos was deprecated in v2.0. +#-} +*-monoˡ-≤-pos : ∀ r → Positive r → (r *_) Preserves _≤_ ⟶ _≤_ +*-monoˡ-≤-pos r@(mkℚ +[1+ _ ] _ _) _ = *-monoˡ-≤-nonNeg r +{-# WARNING_ON_USAGE *-monoˡ-≤-pos +"Warning: *-monoˡ-≤-pos was deprecated in v2.0. Please use *-monoˡ-≤-nonNeg instead." -#-} -*-cancelˡ-<-pos : ∀ r → Positive r → ∀ {p q} → r * p < r * q → p < q -*-cancelˡ-<-pos r@(mkℚ +[1+ _ ] _ _) _ = *-cancelˡ-<-nonNeg r -{-# WARNING_ON_USAGE *-cancelˡ-<-pos -"Warning: *-cancelˡ-<-pos was deprecated in v2.0. +#-} +*-cancelˡ-<-pos : ∀ r → Positive r → ∀ {p q} → r * p < r * q → p < q +*-cancelˡ-<-pos r@(mkℚ +[1+ _ ] _ _) _ = *-cancelˡ-<-nonNeg r +{-# WARNING_ON_USAGE *-cancelˡ-<-pos +"Warning: *-cancelˡ-<-pos was deprecated in v2.0. Please use *-cancelˡ-<-nonNeg instead." -#-} -*-cancelʳ-<-pos : ∀ r → Positive r → ∀ {p q} → p * r < q * r → p < q -*-cancelʳ-<-pos r@(mkℚ +[1+ _ ] _ _) _ = *-cancelʳ-<-nonNeg r -{-# WARNING_ON_USAGE *-cancelʳ-<-pos -"Warning: *-cancelʳ-<-pos was deprecated in v2.0. +#-} +*-cancelʳ-<-pos : ∀ r → Positive r → ∀ {p q} → p * r < q * r → p < q +*-cancelʳ-<-pos r@(mkℚ +[1+ _ ] _ _) _ = *-cancelʳ-<-nonNeg r +{-# WARNING_ON_USAGE *-cancelʳ-<-pos +"Warning: *-cancelʳ-<-pos was deprecated in v2.0. Please use *-cancelʳ-<-nonNeg instead." -#-} -*-cancelˡ-<-neg : ∀ r → Negative r → ∀ {p q} → r * p < r * q → p > q -*-cancelˡ-<-neg r@(mkℚ -[1+ _ ] _ _) _ = *-cancelˡ-<-nonPos r -{-# WARNING_ON_USAGE *-cancelˡ-<-neg -"Warning: *-cancelˡ-<-neg was deprecated in v2.0. +#-} +*-cancelˡ-<-neg : ∀ r → Negative r → ∀ {p q} → r * p < r * q → p > q +*-cancelˡ-<-neg r@(mkℚ -[1+ _ ] _ _) _ = *-cancelˡ-<-nonPos r +{-# WARNING_ON_USAGE *-cancelˡ-<-neg +"Warning: *-cancelˡ-<-neg was deprecated in v2.0. Please use *-cancelˡ-<-nonPos instead." -#-} -*-cancelʳ-<-neg : ∀ r → Negative r → ∀ {p q} → p * r < q * r → p > q -*-cancelʳ-<-neg r@(mkℚ -[1+ _ ] _ _) _ = *-cancelʳ-<-nonPos r -{-# WARNING_ON_USAGE *-cancelʳ-<-neg -"Warning: *-cancelʳ-<-neg was deprecated in v2.0. +#-} +*-cancelʳ-<-neg : ∀ r → Negative r → ∀ {p q} → p * r < q * r → p > q +*-cancelʳ-<-neg r@(mkℚ -[1+ _ ] _ _) _ = *-cancelʳ-<-nonPos r +{-# WARNING_ON_USAGE *-cancelʳ-<-neg +"Warning: *-cancelʳ-<-neg was deprecated in v2.0. Please use *-cancelʳ-<-nonPos instead." -#-} -negative<positive : Negative p → Positive q → p < q -negative<positive {p} {q} p<0 q>0 = neg<pos p q {{p<0}} {{q>0}} -{-# WARNING_ON_USAGE negative<positive -"Warning: negative<positive was deprecated in v2.0. +#-} +negative<positive : Negative p → Positive q → p < q +negative<positive {p} {q} p<0 q>0 = neg<pos p q {{p<0}} {{q>0}} +{-# WARNING_ON_USAGE negative<positive +"Warning: negative<positive was deprecated in v2.0. Please use neg<pos instead." -#-} -{- issue1865/issue1755: raw bundles have moved to `Data.X.Base` -} -open Data.Rational.Base public - using (+-rawMagma; +-0-rawGroup; *-rawMagma; +-*-rawNearSemiring; +-*-rawSemiring; +-*-rawRing) - renaming (+-0-rawMonoid to +-rawMonoid; *-1-rawMonoid to *-rawMonoid) +#-} +{- issue1865/issue1755: raw bundles have moved to `Data.X.Base` -} +open Data.Rational.Base public + using (+-rawMagma; +-0-rawGroup; *-rawMagma; +-*-rawNearSemiring; +-*-rawSemiring; +-*-rawRing) + renaming (+-0-rawMonoid to +-rawMonoid; *-1-rawMonoid to *-rawMonoid) \ No newline at end of file diff --git a/Data.Rational.Unnormalised.Base.html b/Data.Rational.Unnormalised.Base.html index b05f680c..e84c8421 100644 --- a/Data.Rational.Unnormalised.Base.html +++ b/Data.Rational.Unnormalised.Base.html @@ -10,372 +10,383 @@ module Data.Rational.Unnormalised.Base where open import Algebra.Bundles.Raw -open import Data.Bool.Base using (Bool; true; false; if_then_else_) +open import Data.Bool.Base using (Bool; true; false; if_then_else_) open import Data.Integer.Base as ℤ - using (ℤ; +_; +0; +[1+_]; -[1+_]; +<+; +≤+) -open import Data.Nat.Base as ℕ using (ℕ; zero; suc) -open import Level using (0ℓ) -open import Relation.Nullary.Negation using (¬_) -open import Relation.Nullary.Negation using (contradiction) -open import Relation.Unary using (Pred) -open import Relation.Binary.Core using (Rel) -open import Relation.Binary.PropositionalEquality.Core - using (_≡_; _≢_; refl) + using (ℤ; +_; +0; +[1+_]; -[1+_]; +<+; +≤+) + hiding (module ℤ) +open import Data.Nat.Base as ℕ using (ℕ; zero; suc) +open import Level using (0ℓ) +open import Relation.Nullary.Negation.Core using (¬_; contradiction) +open import Relation.Unary using (Pred) +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.PropositionalEquality.Core + using (_≡_; _≢_; refl) ------------------------------------------------------------------------- --- Definition +------------------------------------------------------------------------ +-- Definition --- Here we define rationals that are not necessarily in reduced form. --- Consequently there are multiple ways of representing a given rational --- number, and the performance of the arithmetic operations may suffer --- due to blowup of the numerator and denominator. +-- Here we define rationals that are not necessarily in reduced form. +-- Consequently there are multiple ways of representing a given rational +-- number, and the performance of the arithmetic operations may suffer +-- due to blowup of the numerator and denominator. --- Nonetheless they are much easier to reason about. In general proofs --- are first proved for these unnormalised rationals and then translated --- into the normalised rationals. +-- Nonetheless they are much easier to reason about. In general proofs +-- are first proved for these unnormalised rationals and then translated +-- into the normalised rationals. -record ℚᵘ : Set where - -- We add "no-eta-equality; pattern" to the record to stop Agda - -- automatically unfolding rationals when arithmetic operations are - -- applied to them (see definition of operators below and Issue #1753 - -- for details). - no-eta-equality; pattern +record ℚᵘ : Set where + -- We add "no-eta-equality; pattern" to the record to stop Agda + -- automatically unfolding rationals when arithmetic operations are + -- applied to them (see definition of operators below and Issue #1753 + -- for details). + no-eta-equality; pattern - constructor mkℚᵘ - field - numerator : ℤ - denominator-1 : ℕ + constructor mkℚᵘ + field + numerator : ℤ + denominator-1 : ℕ - denominatorℕ : ℕ - denominatorℕ = suc denominator-1 + denominatorℕ : ℕ + denominatorℕ = suc denominator-1 - denominator : ℤ - denominator = + denominatorℕ + denominator : ℤ + denominator = + denominatorℕ -open ℚᵘ public using () - renaming - ( numerator to ↥_ - ; denominator to ↧_ - ; denominatorℕ to ↧ₙ_ - ) +open ℚᵘ public using () + renaming + ( numerator to ↥_ + ; denominator to ↧_ + ; denominatorℕ to ↧ₙ_ + ) ------------------------------------------------------------------------- --- Equality of rational numbers (does not coincide with _≡_) +------------------------------------------------------------------------ +-- Equality of rational numbers (does not coincide with _≡_) -infix 4 _≃_ _≠_ +infix 4 _≃_ _≠_ -data _≃_ : Rel ℚᵘ 0ℓ where - *≡* : ∀ {p q} → (↥ p ℤ.* ↧ q) ≡ (↥ q ℤ.* ↧ p) → p ≃ q +data _≃_ : Rel ℚᵘ 0ℓ where + *≡* : ∀ {p q} → (↥ p ℤ.* ↧ q) ≡ (↥ q ℤ.* ↧ p) → p ≃ q -_≠_ : Rel ℚᵘ 0ℓ -p ≠ q = ¬ (p ≃ q) +_≄_ : Rel ℚᵘ 0ℓ +p ≄ q = ¬ (p ≃ q) ------------------------------------------------------------------------- --- Ordering of rationals +------------------------------------------------------------------------ +-- Ordering of rationals -infix 4 _≤_ _<_ _≥_ _>_ _≰_ _≱_ _≮_ _≯_ +infix 4 _≤_ _<_ _≥_ _>_ _≰_ _≱_ _≮_ _≯_ -data _≤_ : Rel ℚᵘ 0ℓ where - *≤* : ∀ {p q} → (↥ p ℤ.* ↧ q) ℤ.≤ (↥ q ℤ.* ↧ p) → p ≤ q +data _≤_ : Rel ℚᵘ 0ℓ where + *≤* : ∀ {p q} → (↥ p ℤ.* ↧ q) ℤ.≤ (↥ q ℤ.* ↧ p) → p ≤ q -data _<_ : Rel ℚᵘ 0ℓ where - *<* : ∀ {p q} → (↥ p ℤ.* ↧ q) ℤ.< (↥ q ℤ.* ↧ p) → p < q +data _<_ : Rel ℚᵘ 0ℓ where + *<* : ∀ {p q} → (↥ p ℤ.* ↧ q) ℤ.< (↥ q ℤ.* ↧ p) → p < q -_≥_ : Rel ℚᵘ 0ℓ -x ≥ y = y ≤ x +_≥_ : Rel ℚᵘ 0ℓ +x ≥ y = y ≤ x -_>_ : Rel ℚᵘ 0ℓ -x > y = y < x +_>_ : Rel ℚᵘ 0ℓ +x > y = y < x -_≰_ : Rel ℚᵘ 0ℓ -x ≰ y = ¬ (x ≤ y) +_≰_ : Rel ℚᵘ 0ℓ +x ≰ y = ¬ (x ≤ y) -_≱_ : Rel ℚᵘ 0ℓ -x ≱ y = ¬ (x ≥ y) +_≱_ : Rel ℚᵘ 0ℓ +x ≱ y = ¬ (x ≥ y) -_≮_ : Rel ℚᵘ 0ℓ -x ≮ y = ¬ (x < y) +_≮_ : Rel ℚᵘ 0ℓ +x ≮ y = ¬ (x < y) -_≯_ : Rel ℚᵘ 0ℓ -x ≯ y = ¬ (x > y) +_≯_ : Rel ℚᵘ 0ℓ +x ≯ y = ¬ (x > y) ------------------------------------------------------------------------- --- Boolean ordering +------------------------------------------------------------------------ +-- Boolean ordering -infix 4 _≤ᵇ_ +infix 4 _≤ᵇ_ -_≤ᵇ_ : ℚᵘ → ℚᵘ → Bool -p ≤ᵇ q = (↥ p ℤ.* ↧ q) ℤ.≤ᵇ (↥ q ℤ.* ↧ p) +_≤ᵇ_ : ℚᵘ → ℚᵘ → Bool +p ≤ᵇ q = (↥ p ℤ.* ↧ q) ℤ.≤ᵇ (↥ q ℤ.* ↧ p) ------------------------------------------------------------------------- --- Constructing rationals +------------------------------------------------------------------------ +-- Constructing rationals --- An alternative constructor for ℚᵘ. See the constants section below --- for examples of how to use this operator. +-- An alternative constructor for ℚᵘ. See the constants section below +-- for examples of how to use this operator. -infixl 7 _/_ +infixl 7 _/_ -_/_ : (n : ℤ) (d : ℕ) .{{_ : ℕ.NonZero d}} → ℚᵘ -n / suc d = mkℚᵘ n d +_/_ : (n : ℤ) (d : ℕ) .{{_ : ℕ.NonZero d}} → ℚᵘ +n / suc d = mkℚᵘ n d ------------------------------------------------------------------------------- --- Some constants +------------------------------------------------------------------------ +-- Some constants -0ℚᵘ : ℚᵘ -0ℚᵘ = + 0 / 1 +0ℚᵘ : ℚᵘ +0ℚᵘ = + 0 / 1 -1ℚᵘ : ℚᵘ -1ℚᵘ = + 1 / 1 +1ℚᵘ : ℚᵘ +1ℚᵘ = + 1 / 1 -½ : ℚᵘ -½ = + 1 / 2 +½ : ℚᵘ +½ = + 1 / 2 --½ : ℚᵘ --½ = ℤ.- (+ 1) / 2 +-½ : ℚᵘ +-½ = ℤ.- (+ 1) / 2 ------------------------------------------------------------------------- --- Simple predicates +------------------------------------------------------------------------ +-- Simple predicates -NonZero : Pred ℚᵘ 0ℓ -NonZero p = ℤ.NonZero (↥ p) +NonZero : Pred ℚᵘ 0ℓ +NonZero p = ℤ.NonZero (↥ p) -Positive : Pred ℚᵘ 0ℓ -Positive p = ℤ.Positive (↥ p) +Positive : Pred ℚᵘ 0ℓ +Positive p = ℤ.Positive (↥ p) -Negative : Pred ℚᵘ 0ℓ -Negative p = ℤ.Negative (↥ p) +Negative : Pred ℚᵘ 0ℓ +Negative p = ℤ.Negative (↥ p) -NonPositive : Pred ℚᵘ 0ℓ -NonPositive p = ℤ.NonPositive (↥ p) +NonPositive : Pred ℚᵘ 0ℓ +NonPositive p = ℤ.NonPositive (↥ p) -NonNegative : Pred ℚᵘ 0ℓ -NonNegative p = ℤ.NonNegative (↥ p) +NonNegative : Pred ℚᵘ 0ℓ +NonNegative p = ℤ.NonNegative (↥ p) --- Constructors and destructors +-- Instances --- Note: these could be proved more elegantly using the constructors --- from ℤ but it requires importing `Data.Integer.Properties` which --- we would like to avoid doing. +open ℤ public + using (nonZero; pos; nonNeg; nonPos0; nonPos; neg) -≢-nonZero : ∀ {p} → p ≠ 0ℚᵘ → NonZero p -≢-nonZero {mkℚᵘ -[1+ _ ] _ } _ = _ -≢-nonZero {mkℚᵘ +[1+ _ ] _ } _ = _ -≢-nonZero {mkℚᵘ +0 zero } p≢0 = contradiction (*≡* refl) p≢0 -≢-nonZero {mkℚᵘ +0 (suc d)} p≢0 = contradiction (*≡* refl) p≢0 +-- Constructors and destructors ->-nonZero : ∀ {p} → p > 0ℚᵘ → NonZero p ->-nonZero {mkℚᵘ +0 _} (*<* (+<+ ())) ->-nonZero {mkℚᵘ +[1+ n ] _} (*<* _) = _ +-- Note: these could be proved more elegantly using the constructors +-- from ℤ but it requires importing `Data.Integer.Properties` which +-- we would like to avoid doing. -<-nonZero : ∀ {p} → p < 0ℚᵘ → NonZero p -<-nonZero {mkℚᵘ +[1+ n ] _} (*<* _) = _ -<-nonZero {mkℚᵘ +0 _} (*<* (+<+ ())) -<-nonZero {mkℚᵘ -[1+ n ] _} (*<* _) = _ +≢-nonZero : ∀ {p} → p ≄ 0ℚᵘ → NonZero p +≢-nonZero {mkℚᵘ -[1+ _ ] _ } _ = _ +≢-nonZero {mkℚᵘ +[1+ _ ] _ } _ = _ +≢-nonZero {mkℚᵘ +0 zero } p≢0 = contradiction (*≡* refl) p≢0 +≢-nonZero {mkℚᵘ +0 (suc d)} p≢0 = contradiction (*≡* refl) p≢0 -positive : ∀ {p} → p > 0ℚᵘ → Positive p -positive {mkℚᵘ +[1+ n ] _} (*<* _) = _ -positive {mkℚᵘ +0 _} (*<* (+<+ ())) -positive {mkℚᵘ (-[1+_] n) _} (*<* ()) +>-nonZero : ∀ {p} → p > 0ℚᵘ → NonZero p +>-nonZero {mkℚᵘ +0 _} (*<* (+<+ ())) +>-nonZero {mkℚᵘ +[1+ n ] _} (*<* _) = _ -negative : ∀ {p} → p < 0ℚᵘ → Negative p -negative {mkℚᵘ +[1+ n ] _} (*<* (+<+ ())) -negative {mkℚᵘ +0 _} (*<* (+<+ ())) -negative {mkℚᵘ (-[1+_] n) _} (*<* _ ) = _ +<-nonZero : ∀ {p} → p < 0ℚᵘ → NonZero p +<-nonZero {mkℚᵘ +[1+ n ] _} (*<* _) = _ +<-nonZero {mkℚᵘ +0 _} (*<* (+<+ ())) +<-nonZero {mkℚᵘ -[1+ n ] _} (*<* _) = _ -nonPositive : ∀ {p} → p ≤ 0ℚᵘ → NonPositive p -nonPositive {mkℚᵘ +[1+ n ] _} (*≤* (+≤+ ())) -nonPositive {mkℚᵘ +0 _} (*≤* _) = _ -nonPositive {mkℚᵘ -[1+ n ] _} (*≤* _) = _ +positive : ∀ {p} → p > 0ℚᵘ → Positive p +positive {mkℚᵘ +[1+ n ] _} (*<* _) = _ +positive {mkℚᵘ +0 _} (*<* (+<+ ())) +positive {mkℚᵘ (-[1+_] n) _} (*<* ()) -nonNegative : ∀ {p} → p ≥ 0ℚᵘ → NonNegative p -nonNegative {mkℚᵘ +0 _} (*≤* _) = _ -nonNegative {mkℚᵘ +[1+ n ] _} (*≤* _) = _ +negative : ∀ {p} → p < 0ℚᵘ → Negative p +negative {mkℚᵘ +[1+ n ] _} (*<* (+<+ ())) +negative {mkℚᵘ +0 _} (*<* (+<+ ())) +negative {mkℚᵘ (-[1+_] n) _} (*<* _ ) = _ ------------------------------------------------------------------------------- --- Operations on rationals +nonPositive : ∀ {p} → p ≤ 0ℚᵘ → NonPositive p +nonPositive {mkℚᵘ +[1+ n ] _} (*≤* (+≤+ ())) +nonPositive {mkℚᵘ +0 _} (*≤* _) = _ +nonPositive {mkℚᵘ -[1+ n ] _} (*≤* _) = _ --- Explanation for `@record{}` everywhere: combined with no-eta-equality on --- the record definition of ℚᵘ above, these annotations prevent the operations --- from automatically expanding unless their arguments are explicitly pattern --- matched on. --- --- For example prior to their addition, `p + q` would often be normalised by --- Agda to `(↥ p ℤ.* ↧ q ℤ.+ ↥ q ℤ.* ↧ p) / (↧ₙ p ℕ.* ↧ₙ q)`. While in this --- small example this isn't a big problem, it leads to an exponential blowup --- when you have large arithmetic expressions which would often choke --- both type-checking and the display code. For example, the normalised --- form of `p + q + r + s + t + u` would be ~300 lines long. --- --- This is fundementally a problem with Agda, so if over-eager normalisation --- is ever fixed in Agda (e.g. with glued representation of terms) these --- annotations can be removed. +nonNegative : ∀ {p} → p ≥ 0ℚᵘ → NonNegative p +nonNegative {mkℚᵘ +0 _} (*≤* _) = _ +nonNegative {mkℚᵘ +[1+ n ] _} (*≤* _) = _ -infix 8 -_ 1/_ -infixl 7 _*_ _÷_ _⊓_ -infixl 6 _-_ _+_ _⊔_ +------------------------------------------------------------------------ +-- Operations on rationals --- negation +-- Explanation for `@record{}` everywhere: combined with no-eta-equality +-- on the record definition of ℚᵘ above, these annotations prevent the +-- operations from automatically expanding unless their arguments are +-- explicitly pattern matched on. +-- +-- For example prior to their addition, `p + q` would often be +-- normalised by Agda to `(↥ p ℤ.* ↧ q ℤ.+ ↥ q ℤ.* ↧ p) / (↧ₙ p ℕ.* ↧ₙ q)`. +-- While in this small example this isn't a big problem, it leads to an +-- exponential blowup when you have large arithmetic expressions which +-- would often choke both type-checking and the display code. For +-- example, the normalised form of `p + q + r + s + t + u` would be +-- ~300 lines long. +-- +-- This is fundementally a problem with Agda, so if over-eager +-- normalisation is ever fixed in Agda (e.g. with glued representation +-- of terms) these annotations can be removed. --_ : ℚᵘ → ℚᵘ -- mkℚᵘ n d = mkℚᵘ (ℤ.- n) d - --- addition - -_+_ : ℚᵘ → ℚᵘ → ℚᵘ -p@record{} + q@record{} = (↥ p ℤ.* ↧ q ℤ.+ ↥ q ℤ.* ↧ p) / (↧ₙ p ℕ.* ↧ₙ q) - --- multiplication - -_*_ : ℚᵘ → ℚᵘ → ℚᵘ -p@record{} * q@record{} = (↥ p ℤ.* ↥ q) / (↧ₙ p ℕ.* ↧ₙ q) - --- subtraction - -_-_ : ℚᵘ → ℚᵘ → ℚᵘ -p - q = p + (- q) - --- reciprocal: requires a proof that the numerator is not zero - -1/_ : (p : ℚᵘ) → .{{_ : NonZero p}} → ℚᵘ -1/ mkℚᵘ +[1+ n ] d = mkℚᵘ +[1+ d ] n -1/ mkℚᵘ -[1+ n ] d = mkℚᵘ -[1+ d ] n - --- division: requires a proof that the denominator is not zero - -_÷_ : (p q : ℚᵘ) → .{{_ : NonZero q}} → ℚᵘ -p@record{} ÷ q@record{} = p * (1/ q) - --- max -_⊔_ : (p q : ℚᵘ) → ℚᵘ -p@record{} ⊔ q@record{} = if p ≤ᵇ q then q else p - --- min -_⊓_ : (p q : ℚᵘ) → ℚᵘ -p@record{} ⊓ q@record{} = if p ≤ᵇ q then p else q - --- absolute value -∣_∣ : ℚᵘ → ℚᵘ -∣ mkℚᵘ p q ∣ = mkℚᵘ (+ ℤ.∣ p ∣) q - ------------------------------------------------------------------------- --- Rounding functions - --- Floor (round towards -∞) -floor : ℚᵘ → ℤ -floor p@record{} = ↥ p ℤ./ ↧ p - --- Ceiling (round towards +∞) -ceiling : ℚᵘ → ℤ -ceiling p@record{} = ℤ.- floor (- p) - --- Truncate (round towards 0) -truncate : ℚᵘ → ℤ -truncate p with p ≤ᵇ 0ℚᵘ -... | true = ceiling p -... | false = floor p - --- Round (to nearest integer) -round : ℚᵘ → ℤ -round p with p ≤ᵇ 0ℚᵘ -... | true = ceiling (p - ½) -... | false = floor (p + ½) - --- Fractional part (remainder after floor) -fracPart : ℚᵘ → ℚᵘ -fracPart p@record{} = ∣ p - truncate p / 1 ∣ - --- Extra notations ⌊ ⌋ floor, ⌈ ⌉ ceiling, [ ] truncate -syntax floor p = ⌊ p ⌋ -syntax ceiling p = ⌈ p ⌉ -syntax truncate p = [ p ] - ------------------------------------------------------------------------- --- Raw bundles for _+_ - -+-rawMagma : RawMagma 0ℓ 0ℓ -+-rawMagma = record - { _≈_ = _≃_ - ; _∙_ = _+_ - } - -+-0-rawMonoid : RawMonoid 0ℓ 0ℓ -+-0-rawMonoid = record - { _≈_ = _≃_ - ; _∙_ = _+_ - ; ε = 0ℚᵘ - } - -+-0-rawGroup : RawGroup 0ℓ 0ℓ -+-0-rawGroup = record - { Carrier = ℚᵘ - ; _≈_ = _≃_ - ; _∙_ = _+_ - ; ε = 0ℚᵘ - ; _⁻¹ = -_ - } - -+-*-rawNearSemiring : RawNearSemiring 0ℓ 0ℓ -+-*-rawNearSemiring = record - { Carrier = ℚᵘ - ; _≈_ = _≃_ - ; _+_ = _+_ - ; _*_ = _*_ - ; 0# = 0ℚᵘ - } - -+-*-rawSemiring : RawSemiring 0ℓ 0ℓ -+-*-rawSemiring = record - { Carrier = ℚᵘ - ; _≈_ = _≃_ - ; _+_ = _+_ - ; _*_ = _*_ - ; 0# = 0ℚᵘ - ; 1# = 1ℚᵘ - } - -+-*-rawRing : RawRing 0ℓ 0ℓ -+-*-rawRing = record - { Carrier = ℚᵘ - ; _≈_ = _≃_ - ; _+_ = _+_ - ; _*_ = _*_ - ; -_ = -_ - ; 0# = 0ℚᵘ - ; 1# = 1ℚᵘ - } - ------------------------------------------------------------------------- --- Raw bundles for _*_ - -*-rawMagma : RawMagma 0ℓ 0ℓ -*-rawMagma = record - { _≈_ = _≃_ - ; _∙_ = _*_ - } - -*-1-rawMonoid : RawMonoid 0ℓ 0ℓ -*-1-rawMonoid = record - { _≈_ = _≃_ - ; _∙_ = _*_ - ; ε = 1ℚᵘ - } - ------------------------------------------------------------------------- --- DEPRECATED NAMES ------------------------------------------------------------------------- --- Please use the new names as continuing support for the old names is --- not guaranteed. - --- Version 2.0 - -+-rawMonoid = +-0-rawMonoid -{-# WARNING_ON_USAGE +-rawMonoid -"Warning: +-rawMonoid was deprecated in v2.0 +infix 8 -_ 1/_ +infixl 7 _*_ _÷_ _⊓_ +infixl 6 _-_ _+_ _⊔_ + +-- negation + +-_ : ℚᵘ → ℚᵘ +- mkℚᵘ n d = mkℚᵘ (ℤ.- n) d + +-- addition + +_+_ : ℚᵘ → ℚᵘ → ℚᵘ +p@record{} + q@record{} = (↥ p ℤ.* ↧ q ℤ.+ ↥ q ℤ.* ↧ p) / (↧ₙ p ℕ.* ↧ₙ q) + +-- multiplication + +_*_ : ℚᵘ → ℚᵘ → ℚᵘ +p@record{} * q@record{} = (↥ p ℤ.* ↥ q) / (↧ₙ p ℕ.* ↧ₙ q) + +-- subtraction + +_-_ : ℚᵘ → ℚᵘ → ℚᵘ +p - q = p + (- q) + +-- reciprocal: requires a proof that the numerator is not zero + +1/_ : (p : ℚᵘ) → .{{_ : NonZero p}} → ℚᵘ +1/ mkℚᵘ +[1+ n ] d = mkℚᵘ +[1+ d ] n +1/ mkℚᵘ -[1+ n ] d = mkℚᵘ -[1+ d ] n + +-- division: requires a proof that the denominator is not zero + +_÷_ : (p q : ℚᵘ) → .{{_ : NonZero q}} → ℚᵘ +p@record{} ÷ q@record{} = p * (1/ q) + +-- max +_⊔_ : (p q : ℚᵘ) → ℚᵘ +p@record{} ⊔ q@record{} = if p ≤ᵇ q then q else p + +-- min +_⊓_ : (p q : ℚᵘ) → ℚᵘ +p@record{} ⊓ q@record{} = if p ≤ᵇ q then p else q + +-- absolute value +∣_∣ : ℚᵘ → ℚᵘ +∣ mkℚᵘ p q ∣ = mkℚᵘ (+ ℤ.∣ p ∣) q + +------------------------------------------------------------------------ +-- Rounding functions + +-- Floor (round towards -∞) +floor : ℚᵘ → ℤ +floor p@record{} = ↥ p ℤ./ ↧ p + +-- Ceiling (round towards +∞) +ceiling : ℚᵘ → ℤ +ceiling p@record{} = ℤ.- floor (- p) + +-- Truncate (round towards 0) +truncate : ℚᵘ → ℤ +truncate p with p ≤ᵇ 0ℚᵘ +... | true = ceiling p +... | false = floor p + +-- Round (to nearest integer) +round : ℚᵘ → ℤ +round p with p ≤ᵇ 0ℚᵘ +... | true = ceiling (p - ½) +... | false = floor (p + ½) + +-- Fractional part (remainder after floor) +fracPart : ℚᵘ → ℚᵘ +fracPart p@record{} = ∣ p - truncate p / 1 ∣ + +-- Extra notations ⌊ ⌋ floor, ⌈ ⌉ ceiling, [ ] truncate +syntax floor p = ⌊ p ⌋ +syntax ceiling p = ⌈ p ⌉ +syntax truncate p = [ p ] + +------------------------------------------------------------------------ +-- Raw bundles for _+_ + ++-rawMagma : RawMagma 0ℓ 0ℓ ++-rawMagma = record + { _≈_ = _≃_ + ; _∙_ = _+_ + } + ++-0-rawMonoid : RawMonoid 0ℓ 0ℓ ++-0-rawMonoid = record + { _≈_ = _≃_ + ; _∙_ = _+_ + ; ε = 0ℚᵘ + } + ++-0-rawGroup : RawGroup 0ℓ 0ℓ ++-0-rawGroup = record + { Carrier = ℚᵘ + ; _≈_ = _≃_ + ; _∙_ = _+_ + ; ε = 0ℚᵘ + ; _⁻¹ = -_ + } + ++-*-rawNearSemiring : RawNearSemiring 0ℓ 0ℓ ++-*-rawNearSemiring = record + { Carrier = ℚᵘ + ; _≈_ = _≃_ + ; _+_ = _+_ + ; _*_ = _*_ + ; 0# = 0ℚᵘ + } + ++-*-rawSemiring : RawSemiring 0ℓ 0ℓ ++-*-rawSemiring = record + { Carrier = ℚᵘ + ; _≈_ = _≃_ + ; _+_ = _+_ + ; _*_ = _*_ + ; 0# = 0ℚᵘ + ; 1# = 1ℚᵘ + } + ++-*-rawRing : RawRing 0ℓ 0ℓ ++-*-rawRing = record + { Carrier = ℚᵘ + ; _≈_ = _≃_ + ; _+_ = _+_ + ; _*_ = _*_ + ; -_ = -_ + ; 0# = 0ℚᵘ + ; 1# = 1ℚᵘ + } + +------------------------------------------------------------------------ +-- Raw bundles for _*_ + +*-rawMagma : RawMagma 0ℓ 0ℓ +*-rawMagma = record + { _≈_ = _≃_ + ; _∙_ = _*_ + } + +*-1-rawMonoid : RawMonoid 0ℓ 0ℓ +*-1-rawMonoid = record + { _≈_ = _≃_ + ; _∙_ = _*_ + ; ε = 1ℚᵘ + } + +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 2.0 + ++-rawMonoid = +-0-rawMonoid +{-# WARNING_ON_USAGE +-rawMonoid +"Warning: +-rawMonoid was deprecated in v2.0 Please use +-0-rawMonoid instead." -#-} -*-rawMonoid = *-1-rawMonoid -{-# WARNING_ON_USAGE *-rawMonoid -"Warning: *-rawMonoid was deprecated in v2.0 +#-} +*-rawMonoid = *-1-rawMonoid +{-# WARNING_ON_USAGE *-rawMonoid +"Warning: *-rawMonoid was deprecated in v2.0 Please use *-1-rawMonoid instead." -#-} +#-} +_≠_ = _≄_ +{-# WARNING_ON_USAGE _≠_ +"Warning: _≠_ was deprecated in v2.0 +Please use _≄_ instead." +#-} \ No newline at end of file diff --git a/Data.Rational.Unnormalised.Properties.html b/Data.Rational.Unnormalised.Properties.html index fa75df53..bbf4cbec 100644 --- a/Data.Rational.Unnormalised.Properties.html +++ b/Data.Rational.Unnormalised.Properties.html @@ -1,1863 +1,1991 @@ -Data.Rational.Unnormalised.Properties
------------------------------------------------------------------------
--- The Agda standard library
---
--- Properties of unnormalized Rational numbers
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-{-# OPTIONS --warn=noUserWarning #-} -- for +-rawMonoid, *-rawMonoid (issue #1865, #1844, #1755)
-
-module Data.Rational.Unnormalised.Properties where
-
-open import Algebra
-open import Algebra.Lattice
-import Algebra.Consequences.Setoid as Consequences
-open import Algebra.Consequences.Propositional
-open import Algebra.Construct.NaturalChoice.Base
-import Algebra.Construct.NaturalChoice.MinMaxOp as MinMaxOp
-import Algebra.Lattice.Construct.NaturalChoice.MinMaxOp as LatticeMinMaxOp
-open import Data.Bool.Base using (T; true; false)
-open import Data.Nat.Base as ℕ using (suc; pred)
-import Data.Nat.Properties as ℕ
-open import Data.Nat.Solver renaming (module +-*-Solver to ℕ-solver)
-open import Data.Integer.Base as ℤ using (ℤ; +0; +[1+_]; -[1+_]; 0ℤ; 1ℤ; -1ℤ)
-open import Data.Integer.Solver renaming (module +-*-Solver to ℤ-solver)
-import Data.Integer.Properties as ℤ
-open import Data.Rational.Unnormalised.Base
-open import Data.Product using (_,_)
-open import Data.Sum.Base using (_⊎_; [_,_]′; inj₁; inj₂)
-import Data.Sign as Sign
-open import Function.Base using (_on_; _$_; _∘_; flip)
-open import Level using (0ℓ)
-open import Relation.Nullary using (¬_; yes; no)
-import Relation.Nullary.Decidable as Dec
-open import Relation.Nullary.Negation using (contradiction; contraposition)
-open import Relation.Binary
-import Relation.Binary.Consequences as BC
-open import Relation.Binary.PropositionalEquality
-import Relation.Binary.Properties.Poset as PosetProperties
-
-open import Algebra.Properties.CommutativeSemigroup ℤ.*-commutativeSemigroup
-
-private
-  variable
-    p q r : ℚᵘ
-
-------------------------------------------------------------------------
--- Properties of ↥_ and ↧_
-------------------------------------------------------------------------
-
-↥↧≡⇒≡ : ∀ {p q} → ↥ p ≡ ↥ q → ↧ₙ p ≡ ↧ₙ q → p ≡ q
-↥↧≡⇒≡ {mkℚᵘ _ _} {mkℚᵘ _ _} refl refl = refl
-
-------------------------------------------------------------------------
--- Properties of _/_
-------------------------------------------------------------------------
-
-/-cong : ∀ {n₁ d₁ n₂ d₂} .{{_ : ℕ.NonZero d₁}} .{{_ : ℕ.NonZero d₂}} →
-         n₁ ≡ n₂ → d₁ ≡ d₂ → n₁ / d₁ ≡ n₂ / d₂
-/-cong refl refl = refl
-
-↥[n/d]≡n : ∀ n d .{{_ : ℕ.NonZero d}} → ↥ (n / d) ≡ n
-↥[n/d]≡n n (suc d) = refl
-
-↧[n/d]≡d : ∀ n d .{{_ : ℕ.NonZero d}} → ↧ (n / d) ≡ ℤ.+ d
-↧[n/d]≡d n (suc d) = 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 -_
-------------------------------------------------------------------------
-
-neg-involutive-≡ : Involutive _≡_ (-_)
-neg-involutive-≡ (mkℚᵘ n d) = cong (λ n → mkℚᵘ n d) (ℤ.neg-involutive n)
-
-neg-involutive : Involutive _≃_ (-_)
-neg-involutive p rewrite neg-involutive-≡ p = ≃-refl
-
--‿cong : Congruent₁ _≃_ (-_)
--‿cong {p@record{}} {q@record{}} (*≡* p≡q) = *≡* (begin
-  ↥(- p) ℤ.* ↧ q            ≡˘⟨ ℤ.*-identityˡ (ℤ.- (↥ p) ℤ.* ↧ q) ⟩
-  1ℤ ℤ.* (↥(- p) ℤ.* ↧ q)   ≡˘⟨ ℤ.*-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 (ℤ.-1ℤ ℤ.*_) p≡q ⟩
-  -1ℤ ℤ.* (↥ q ℤ.* ↧ p)     ≡˘⟨ ℤ.*-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
-
-neg-mono-< : -_ Preserves  _<_ ⟶ _>_
-neg-mono-< {p@record{}} {q@record{}} (*<* p<q) = *<* $ begin-strict
-  ℤ.-  ↥ q ℤ.* ↧ p     ≡˘⟨ ℤ.neg-distribˡ-* (↥ q) (↧ p) ⟩
-  ℤ.- (↥ q ℤ.* ↧ p)    <⟨ ℤ.neg-mono-< p<q ⟩
-  ℤ.- (↥ p ℤ.* ↧ q)    ≡⟨ ℤ.neg-distribˡ-* (↥ p) (↧ q) ⟩
-  ↥ (- p) ℤ.* ↧ (- q)  ∎
-  where open ℤ.≤-Reasoning
-
-neg-cancel-< : ∀ {p q} → - p < - q → q < p
-neg-cancel-< {p@record{}} {q@record{}} (*<* -↥p↧q<-↥q↧p) = *<* $ begin-strict
-  ↥ q ℤ.* ↧ p              ≡˘⟨ ℤ.neg-involutive (↥ q ℤ.* ↧ p) ⟩
-  ℤ.- ℤ.- (↥ q ℤ.* ↧ p)    ≡⟨ cong ℤ.-_ (ℤ.neg-distribˡ-* (↥ q) (↧ p)) ⟩
-  ℤ.- ((ℤ.- ↥ q) ℤ.* ↧ p)  <⟨ ℤ.neg-mono-< -↥p↧q<-↥q↧p ⟩
-  ℤ.- ((ℤ.- ↥ p) ℤ.* ↧ q)  ≡˘⟨ cong ℤ.-_ (ℤ.neg-distribˡ-* (↥ p) (↧ q)) ⟩
-  ℤ.- ℤ.- (↥ p ℤ.* ↧ q)    ≡⟨ ℤ.neg-involutive (↥ p ℤ.* ↧ q) ⟩
-  ↥ p ℤ.* ↧ q              ∎
-  where open ℤ.≤-Reasoning
-
-------------------------------------------------------------------------
--- Properties of _≤_
-------------------------------------------------------------------------
--- Relational properties
-
-drop-*≤* : p ≤ q → (↥ p ℤ.* ↧ q) ℤ.≤ (↥ q ℤ.* ↧ p)
-drop-*≤* (*≤* pq≤qp) = pq≤qp
-
-≤-reflexive : _≃_ ⇒ _≤_
-≤-reflexive (*≡* eq) = *≤* (ℤ.≤-reflexive eq)
-
-≤-refl : Reflexive _≤_
-≤-refl = ≤-reflexive ≃-refl
-
-≤-reflexive-≡ : _≡_ ⇒ _≤_
-≤-reflexive-≡ refl = ≤-refl
-
-≤-trans : Transitive _≤_
-≤-trans {p} {q} {r} (*≤* eq₁) (*≤* eq₂)
-  = let n₁ = ↥ p; n₂ = ↥ q; n₃ = ↥ r; d₁ = ↧ p; d₂ = ↧ q; d₃ = ↧ r in *≤* $
-  ℤ.*-cancelʳ-≤-pos (n₁ ℤ.* d₃) (n₃ ℤ.* d₁) d₂ $ begin
-  (n₁  ℤ.* d₃) ℤ.* d₂  ≡⟨ ℤ.*-assoc n₁ d₃ d₂ ⟩
-  n₁   ℤ.* (d₃ ℤ.* d₂) ≡⟨ cong (n₁ ℤ.*_) (ℤ.*-comm d₃ d₂) ⟩
-  n₁   ℤ.* (d₂ ℤ.* d₃) ≡˘⟨ ℤ.*-assoc n₁ d₂ d₃ ⟩
-  (n₁  ℤ.* d₂) ℤ.* d₃  ≤⟨ ℤ.*-monoʳ-≤-nonNeg d₃ eq₁ ⟩
-  (n₂  ℤ.* d₁) ℤ.* d₃  ≡⟨ cong (ℤ._* d₃) (ℤ.*-comm n₂ d₁) ⟩
-  (d₁ ℤ.* n₂)  ℤ.* d₃  ≡⟨ ℤ.*-assoc d₁ n₂ d₃ ⟩
-  d₁  ℤ.* (n₂  ℤ.* d₃) ≤⟨ ℤ.*-monoˡ-≤-nonNeg d₁ eq₂ ⟩
-  d₁  ℤ.* (n₃  ℤ.* d₂) ≡˘⟨ ℤ.*-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))
-
-≤-respˡ-≃ : _≤_ Respectsˡ _≃_
-≤-respˡ-≃ x≈y = ≤-trans (≤-reflexive (≃-sym x≈y))
-
-≤-respʳ-≃ : _≤_ Respectsʳ _≃_
-≤-respʳ-≃ x≈y z≤x = ≤-trans z≤x (≤-reflexive x≈y)
-
-≤-resp₂-≃ : _≤_ Respects₂ _≃_
-≤-resp₂-≃ = ≤-respʳ-≃ , ≤-respˡ-≃
-
-infix 4 _≤?_ _≥?_
-
-_≤?_ : Decidable _≤_
-p ≤? q = Dec.map′ *≤* drop-*≤* (↥ p ℤ.* ↧ q ℤ.≤? ↥ q ℤ.* ↧ p)
-
-_≥?_ : Decidable _≥_
-_≥?_ = flip _≤?_
-
-≤-irrelevant : Irrelevant _≤_
-≤-irrelevant (*≤* p≤q₁) (*≤* p≤q₂) = cong *≤* (ℤ.≤-irrelevant p≤q₁ p≤q₂)
-
-------------------------------------------------------------------------
--- Structures over _≃_
-
-≤-isPreorder : IsPreorder _≃_ _≤_
-≤-isPreorder = record
-  { isEquivalence = ≃-isEquivalence
-  ; reflexive     = ≤-reflexive
-  ; trans         = ≤-trans
-  }
-
-≤-isTotalPreorder : IsTotalPreorder _≃_ _≤_
-≤-isTotalPreorder = record
-  { isPreorder = ≤-isPreorder
-  ; total      = ≤-total
-  }
-
-≤-isPartialOrder : IsPartialOrder _≃_ _≤_
-≤-isPartialOrder = record
-  { isPreorder = ≤-isPreorder
-  ; antisym    = ≤-antisym
-  }
-
-≤-isTotalOrder : IsTotalOrder _≃_ _≤_
-≤-isTotalOrder = record
-  { isPartialOrder = ≤-isPartialOrder
-  ; total          = ≤-total
-  }
-
-≤-isDecTotalOrder : IsDecTotalOrder _≃_ _≤_
-≤-isDecTotalOrder = record
-  { isTotalOrder = ≤-isTotalOrder
-  ; _≟_          = _≃?_
-  ; _≤?_         = _≤?_
-  }
-
-------------------------------------------------------------------------
--- Bundles over _≃_
-
-≤-preorder : Preorder 0ℓ 0ℓ 0ℓ
-≤-preorder = record
-  { isPreorder = ≤-isPreorder
-  }
-
-≤-totalPreorder : TotalPreorder 0ℓ 0ℓ 0ℓ
-≤-totalPreorder = record
-  { isTotalPreorder = ≤-isTotalPreorder
-  }
+Data.Rational.Unnormalised.Properties
-----------------------------------------------------------------------
+-- The Agda standard library
+--
+-- Properties of unnormalized Rational numbers
+------------------------------------------------------------------------
+
+{-# OPTIONS --cubical-compatible --safe #-}
+{-# OPTIONS --warn=noUserWarning #-} -- for +-rawMonoid, *-rawMonoid (issue #1865, #1844, #1755)
+
+module Data.Rational.Unnormalised.Properties where
+
+open import Algebra
+open import Algebra.Apartness
+open import Algebra.Lattice
+import Algebra.Consequences.Setoid as Consequences
+open import Algebra.Consequences.Propositional
+open import Algebra.Construct.NaturalChoice.Base
+import Algebra.Construct.NaturalChoice.MinMaxOp as MinMaxOp
+import Algebra.Lattice.Construct.NaturalChoice.MinMaxOp as LatticeMinMaxOp
+open import Data.Bool.Base using (T; true; false)
+open import Data.Nat.Base as ℕ using (suc; pred)
+import Data.Nat.Properties as ℕ
+open import Data.Nat.Solver renaming (module +-*-Solver to ℕ-solver)
+open import Data.Integer.Base as ℤ using (ℤ; +0; +[1+_]; -[1+_]; 0ℤ; 1ℤ; -1ℤ)
+open import Data.Integer.Solver renaming (module +-*-Solver to ℤ-solver)
+import Data.Integer.Properties as ℤ
+open import Data.Rational.Unnormalised.Base
+open import Data.Product.Base using (_,_; proj₁; proj₂)
+open import Data.Sum.Base using (_⊎_; [_,_]′; inj₁; inj₂)
+import Data.Sign as Sign
+open import Function.Base using (_on_; _$_; _∘_; flip)
+open import Level using (0ℓ)
+open import Relation.Nullary.Decidable.Core as Dec using (yes; no)
+open import Relation.Nullary.Negation.Core using (¬_; contradiction)
+open import Relation.Binary.Core using (_⇒_; _Preserves_⟶_; _Preserves₂_⟶_⟶_)
+open import Relation.Binary.Bundles
+  using (Setoid; DecSetoid; Preorder; TotalPreorder; Poset; TotalOrder; DecTotalOrder; StrictPartialOrder; StrictTotalOrder; DenseLinearOrder)
+open import Relation.Binary.Structures
+  using (IsEquivalence; IsDecEquivalence; IsApartnessRelation; IsTotalPreorder; IsPreorder; IsPartialOrder; IsTotalOrder; IsDecTotalOrder; IsStrictPartialOrder; IsStrictTotalOrder; IsDenseLinearOrder)
+open import Relation.Binary.Definitions
+  using (Reflexive; Symmetric; Transitive; Cotransitive; Tight; Decidable; Antisymmetric; Asymmetric; Dense; Total; Trans; Trichotomous; Irreflexive; Irrelevant; _Respectsˡ_; _Respectsʳ_; _Respects₂_; tri≈; tri<; tri>)
+import Relation.Binary.Consequences as BC
+open import Relation.Binary.PropositionalEquality
+import Relation.Binary.Properties.Poset as PosetProperties
+import Relation.Binary.Reasoning.Setoid as SetoidReasoning
+open import Relation.Binary.Reasoning.Syntax
+
+open import Algebra.Properties.CommutativeSemigroup ℤ.*-commutativeSemigroup
+
+private
+  variable
+    p q r : ℚᵘ
+
+------------------------------------------------------------------------
+-- Properties of ↥_ and ↧_
+------------------------------------------------------------------------
+
+↥↧≡⇒≡ : ∀ {p q} → ↥ p ≡ ↥ q → ↧ₙ p ≡ ↧ₙ q → p ≡ q
+↥↧≡⇒≡ {mkℚᵘ _ _} {mkℚᵘ _ _} refl refl = refl
+
+------------------------------------------------------------------------
+-- Properties of _/_
+------------------------------------------------------------------------
+
+/-cong : ∀ {n₁ d₁ n₂ d₂} .{{_ : ℕ.NonZero d₁}} .{{_ : ℕ.NonZero d₂}} →
+         n₁ ≡ n₂ → d₁ ≡ d₂ → n₁ / d₁ ≡ n₂ / d₂
+/-cong refl refl = refl
+
+↥[n/d]≡n : ∀ n d .{{_ : ℕ.NonZero d}} → ↥ (n / d) ≡ n
+↥[n/d]≡n n (suc d) = refl
+
+↧[n/d]≡d : ∀ n d .{{_ : ℕ.NonZero d}} → ↧ (n / d) ≡ ℤ.+ d
+↧[n/d]≡d n (suc d) = 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
+
+infix 4 _≃?_
+
+_≃?_ : Decidable _≃_
+p ≃? q = Dec.map′ *≡* drop-*≡* (↥ p ℤ.* ↧ q ℤ.≟ ↥ q ℤ.* ↧ p)
+
+0≄1 : 0ℚᵘ ≄ 1ℚᵘ
+0≄1 = Dec.from-no (0ℚᵘ ≃? 1ℚᵘ)
+
+≃-≄-irreflexive : Irreflexive _≃_ _≄_
+≃-≄-irreflexive x≃y x≄y = x≄y x≃y
+
+≄-symmetric : Symmetric _≄_
+≄-symmetric x≄y y≃x = x≄y (≃-sym y≃x)
+
+≄-cotransitive : Cotransitive _≄_
+≄-cotransitive {x} {y} x≄y z with x ≃? z | z ≃? y
+... | no  x≄z | _       = inj₁ x≄z
+... | yes _   | no z≄y  = inj₂ z≄y
+... | yes x≃z | yes z≃y = contradiction (≃-trans x≃z z≃y) x≄y
+
+≃-isEquivalence : IsEquivalence _≃_
+≃-isEquivalence = record
+  { refl  = ≃-refl
+  ; sym   = ≃-sym
+  ; trans = ≃-trans
+  }
+
+≃-isDecEquivalence : IsDecEquivalence _≃_
+≃-isDecEquivalence = record
+  { isEquivalence = ≃-isEquivalence
+  ; _≟_           = _≃?_
+  }
+
+≄-isApartnessRelation : IsApartnessRelation _≃_ _≄_
+≄-isApartnessRelation = record
+  { irrefl  = ≃-≄-irreflexive
+  ; sym     = ≄-symmetric
+  ; cotrans = ≄-cotransitive
+  }
+
+≄-tight : Tight _≃_ _≄_
+proj₁ (≄-tight p q) ¬p≄q = Dec.decidable-stable (p ≃? q) ¬p≄q
+proj₂ (≄-tight p q) p≃q p≄q = p≄q p≃q
+
+≃-setoid : Setoid 0ℓ 0ℓ
+≃-setoid = record
+  { isEquivalence = ≃-isEquivalence
+  }
+
+≃-decSetoid : DecSetoid 0ℓ 0ℓ
+≃-decSetoid = record
+  { isDecEquivalence = ≃-isDecEquivalence
+  }
+
+module ≃-Reasoning = SetoidReasoning ≃-setoid
+
+↥p≡0⇒p≃0 : ∀ p → ↥ p ≡ 0ℤ → p ≃ 0ℚᵘ
+↥p≡0⇒p≃0 p ↥p≡0 = *≡* (cong (ℤ._* (↧ 0ℚᵘ)) ↥p≡0)
+
+p≃0⇒↥p≡0 : ∀ p → p ≃ 0ℚᵘ → ↥ p ≡ 0ℤ
+p≃0⇒↥p≡0 p (*≡* eq) = begin
+  ↥ p          ≡⟨ ℤ.*-identityʳ (↥ p) ⟨
+  ↥ p ℤ.* 1ℤ  ≡⟨ eq ⟩
+  0ℤ           ∎
+  where open ≡-Reasoning
+
+↥p≡↥q≡0⇒p≃q : ∀ p q → ↥ p ≡ 0ℤ → ↥ q ≡ 0ℤ → p ≃ q
+↥p≡↥q≡0⇒p≃q p q ↥p≡0 ↥q≡0 = ≃-trans (↥p≡0⇒p≃0 p ↥p≡0) (≃-sym (↥p≡0⇒p≃0 _ ↥q≡0))
+
+------------------------------------------------------------------------
+-- Properties of -_
+------------------------------------------------------------------------
+
+neg-involutive-≡ : Involutive _≡_ (-_)
+neg-involutive-≡ (mkℚᵘ n d) = cong (λ n → mkℚᵘ n d) (ℤ.neg-involutive n)
+
+neg-involutive : Involutive _≃_ (-_)
+neg-involutive p rewrite neg-involutive-≡ p = ≃-refl
+
+-‿cong : Congruent₁ _≃_ (-_)
+-‿cong {p@record{}} {q@record{}} (*≡* p≡q) = *≡* (begin
+  ↥(- p) ℤ.* ↧ q            ≡⟨ ℤ.*-identityˡ (ℤ.- (↥ p) ℤ.* ↧ q) ⟨
+  1ℤ ℤ.* (↥(- p) ℤ.* ↧ q)   ≡⟨ ℤ.*-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 (ℤ.-1ℤ ℤ.*_) p≡q ⟩
+  -1ℤ ℤ.* (↥ q ℤ.* ↧ p)     ≡⟨ ℤ.*-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
+
+neg-mono-< : -_ Preserves  _<_ ⟶ _>_
+neg-mono-< {p@record{}} {q@record{}} (*<* p<q) = *<* $ begin-strict
+  ℤ.-  ↥ q ℤ.* ↧ p     ≡⟨ ℤ.neg-distribˡ-* (↥ q) (↧ p) ⟨
+  ℤ.- (↥ q ℤ.* ↧ p)    <⟨ ℤ.neg-mono-< p<q ⟩
+  ℤ.- (↥ p ℤ.* ↧ q)    ≡⟨ ℤ.neg-distribˡ-* (↥ p) (↧ q) ⟩
+  ↥ (- p) ℤ.* ↧ (- q)  ∎
+  where open ℤ.≤-Reasoning
+
+neg-cancel-< : ∀ {p q} → - p < - q → q < p
+neg-cancel-< {p@record{}} {q@record{}} (*<* -↥p↧q<-↥q↧p) = *<* $ begin-strict
+  ↥ q ℤ.* ↧ p              ≡⟨ ℤ.neg-involutive (↥ q ℤ.* ↧ p) ⟨
+  ℤ.- ℤ.- (↥ q ℤ.* ↧ p)    ≡⟨ cong ℤ.-_ (ℤ.neg-distribˡ-* (↥ q) (↧ p)) ⟩
+  ℤ.- ((ℤ.- ↥ q) ℤ.* ↧ p)  <⟨ ℤ.neg-mono-< -↥p↧q<-↥q↧p ⟩
+  ℤ.- ((ℤ.- ↥ p) ℤ.* ↧ q)  ≡⟨ cong ℤ.-_ (ℤ.neg-distribˡ-* (↥ p) (↧ q)) ⟨
+  ℤ.- ℤ.- (↥ p ℤ.* ↧ q)    ≡⟨ ℤ.neg-involutive (↥ p ℤ.* ↧ q) ⟩
+  ↥ p ℤ.* ↧ q              ∎
+  where open ℤ.≤-Reasoning
+
+------------------------------------------------------------------------
+-- Properties of _≤_
+------------------------------------------------------------------------
+-- Relational properties
+
+drop-*≤* : p ≤ q → (↥ p ℤ.* ↧ q) ℤ.≤ (↥ q ℤ.* ↧ p)
+drop-*≤* (*≤* pq≤qp) = pq≤qp
+
+≤-reflexive : _≃_ ⇒ _≤_
+≤-reflexive (*≡* eq) = *≤* (ℤ.≤-reflexive eq)
+
+≤-refl : Reflexive _≤_
+≤-refl = ≤-reflexive ≃-refl
+
+≤-reflexive-≡ : _≡_ ⇒ _≤_
+≤-reflexive-≡ refl = ≤-refl
+
+≤-trans : Transitive _≤_
+≤-trans {p} {q} {r} (*≤* eq₁) (*≤* eq₂)
+  = let n₁ = ↥ p; n₂ = ↥ q; n₃ = ↥ r; d₁ = ↧ p; d₂ = ↧ q; d₃ = ↧ r in *≤* $
+  ℤ.*-cancelʳ-≤-pos (n₁ ℤ.* d₃) (n₃ ℤ.* d₁) d₂ $ begin
+  (n₁  ℤ.* d₃) ℤ.* d₂  ≡⟨ ℤ.*-assoc n₁ d₃ d₂ ⟩
+  n₁   ℤ.* (d₃ ℤ.* d₂) ≡⟨ cong (n₁ ℤ.*_) (ℤ.*-comm d₃ d₂) ⟩
+  n₁   ℤ.* (d₂ ℤ.* d₃) ≡⟨ ℤ.*-assoc n₁ d₂ d₃ ⟨
+  (n₁  ℤ.* d₂) ℤ.* d₃  ≤⟨ ℤ.*-monoʳ-≤-nonNeg d₃ eq₁ ⟩
+  (n₂  ℤ.* d₁) ℤ.* d₃  ≡⟨ cong (ℤ._* d₃) (ℤ.*-comm n₂ d₁) ⟩
+  (d₁ ℤ.* n₂)  ℤ.* d₃  ≡⟨ ℤ.*-assoc d₁ n₂ d₃ ⟩
+  d₁  ℤ.* (n₂  ℤ.* d₃) ≤⟨ ℤ.*-monoˡ-≤-nonNeg d₁ eq₂ ⟩
+  d₁  ℤ.* (n₃  ℤ.* d₂) ≡⟨ ℤ.*-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))
+
+≤-respˡ-≃ : _≤_ Respectsˡ _≃_
+≤-respˡ-≃ x≈y = ≤-trans (≤-reflexive (≃-sym x≈y))
+
+≤-respʳ-≃ : _≤_ Respectsʳ _≃_
+≤-respʳ-≃ x≈y z≤x = ≤-trans z≤x (≤-reflexive x≈y)
+
+≤-resp₂-≃ : _≤_ Respects₂ _≃_
+≤-resp₂-≃ = ≤-respʳ-≃ , ≤-respˡ-≃
+
+infix 4 _≤?_ _≥?_
+
+_≤?_ : Decidable _≤_
+p ≤? q = Dec.map′ *≤* drop-*≤* (↥ p ℤ.* ↧ q ℤ.≤? ↥ q ℤ.* ↧ p)
+
+_≥?_ : Decidable _≥_
+_≥?_ = flip _≤?_
+
+≤-irrelevant : Irrelevant _≤_
+≤-irrelevant (*≤* p≤q₁) (*≤* p≤q₂) = cong *≤* (ℤ.≤-irrelevant p≤q₁ p≤q₂)
+
+------------------------------------------------------------------------
+-- Structures over _≃_
+
+≤-isPreorder : IsPreorder _≃_ _≤_
+≤-isPreorder = record
+  { isEquivalence = ≃-isEquivalence
+  ; reflexive     = ≤-reflexive
+  ; trans         = ≤-trans
+  }
+
+≤-isTotalPreorder : IsTotalPreorder _≃_ _≤_
+≤-isTotalPreorder = record
+  { isPreorder = ≤-isPreorder
+  ; total      = ≤-total
+  }
+
+≤-isPartialOrder : IsPartialOrder _≃_ _≤_
+≤-isPartialOrder = record
+  { isPreorder = ≤-isPreorder
+  ; antisym    = ≤-antisym
+  }
+
+≤-isTotalOrder : IsTotalOrder _≃_ _≤_
+≤-isTotalOrder = record
+  { isPartialOrder = ≤-isPartialOrder
+  ; total          = ≤-total
+  }
+
+≤-isDecTotalOrder : IsDecTotalOrder _≃_ _≤_
+≤-isDecTotalOrder = record
+  { isTotalOrder = ≤-isTotalOrder
+  ; _≟_          = _≃?_
+  ; _≤?_         = _≤?_
+  }
+
+------------------------------------------------------------------------
+-- Bundles over _≃_
+
+≤-preorder : Preorder 0ℓ 0ℓ 0ℓ
+≤-preorder = record
+  { isPreorder = ≤-isPreorder
+  }
+
+≤-totalPreorder : TotalPreorder 0ℓ 0ℓ 0ℓ
+≤-totalPreorder = record
+  { isTotalPreorder = ≤-isTotalPreorder
+  }
 
-≤-poset : Poset 0ℓ 0ℓ 0ℓ
-≤-poset = record
-  { isPartialOrder = ≤-isPartialOrder
-  }
-
-≤-totalOrder : TotalOrder 0ℓ 0ℓ 0ℓ
-≤-totalOrder = record
-  { isTotalOrder = ≤-isTotalOrder
-  }
-
-≤-decTotalOrder : DecTotalOrder 0ℓ 0ℓ 0ℓ
-≤-decTotalOrder = record
-  { isDecTotalOrder = ≤-isDecTotalOrder
-  }
-
-------------------------------------------------------------------------
--- Structures over _≡_
-
-≤-isPreorder-≡ : IsPreorder _≡_ _≤_
-≤-isPreorder-≡ = record
-  { isEquivalence = isEquivalence
-  ; reflexive     = ≤-reflexive-≡
-  ; trans         = ≤-trans
-  }
-
-≤-isTotalPreorder-≡ : IsTotalPreorder _≡_ _≤_
-≤-isTotalPreorder-≡ = record
-  { isPreorder = ≤-isPreorder-≡
-  ; total      = ≤-total
-  }
-
-------------------------------------------------------------------------
--- Bundles over _≡_
-
-≤-preorder-≡ : Preorder 0ℓ 0ℓ 0ℓ
-≤-preorder-≡ = record
-  { isPreorder = ≤-isPreorder-≡
-  }
-
-≤-totalPreorder-≡ : TotalPreorder 0ℓ 0ℓ 0ℓ
-≤-totalPreorder-≡ = record
-  { isTotalPreorder = ≤-isTotalPreorder-≡
-  }
-
-------------------------------------------------------------------------
--- Other properties of _≤_
-
-mono⇒cong : ∀ {f} → f Preserves _≤_ ⟶ _≤_ → f Preserves _≃_ ⟶ _≃_
-mono⇒cong = BC.mono⇒cong _≃_ _≃_ ≃-sym ≤-reflexive ≤-antisym
-
-antimono⇒cong : ∀ {f} → f Preserves _≤_ ⟶ _≥_ → f Preserves _≃_ ⟶ _≃_
-antimono⇒cong = BC.antimono⇒cong _≃_ _≃_ ≃-sym ≤-reflexive ≤-antisym
-
-------------------------------------------------------------------------
--- Properties of _≤ᵇ_
-------------------------------------------------------------------------
-
-≤ᵇ⇒≤ : T (p ≤ᵇ q) → p ≤ q
-≤ᵇ⇒≤ = *≤* ∘ ℤ.≤ᵇ⇒≤
-
-≤⇒≤ᵇ : p ≤ q → T (p ≤ᵇ q)
-≤⇒≤ᵇ = ℤ.≤⇒≤ᵇ ∘ drop-*≤*
-
-------------------------------------------------------------------------
--- Properties of _<_
-------------------------------------------------------------------------
-
-drop-*<* : p < q → (↥ p ℤ.* ↧ q) ℤ.< (↥ q ℤ.* ↧ p)
-drop-*<* (*<* pq<qp) = pq<qp
-
-------------------------------------------------------------------------
--- Relationship between other operators
-
-<⇒≤ : _<_ ⇒ _≤_
-<⇒≤ (*<* p<q) = *≤* (ℤ.<⇒≤ p<q)
-
-<⇒≢ : _<_ ⇒ _≢_
-<⇒≢ (*<* x<y) refl = ℤ.<⇒≢ x<y refl
-
-<⇒≱ : _<_ ⇒ _≱_
-<⇒≱ (*<* x<y) = ℤ.<⇒≱ x<y ∘ drop-*≤*
-
-≰⇒> : _≰_ ⇒ _>_
-≰⇒> p≰q = *<* (ℤ.≰⇒> (p≰q ∘ *≤*))
-
-≮⇒≥ : _≮_ ⇒ _≥_
-≮⇒≥ p≮q = *≤* (ℤ.≮⇒≥ (p≮q ∘ *<*))
-
-≰⇒≥ : _≰_ ⇒ _≥_
-≰⇒≥ = <⇒≤ ∘ ≰⇒>
-
-------------------------------------------------------------------------
--- Relational properties
-
-<-irrefl-≡ : Irreflexive _≡_ _<_
-<-irrefl-≡ refl (*<* x<x) = ℤ.<-irrefl refl x<x
-
-<-irrefl : Irreflexive _≃_ _<_
-<-irrefl (*≡* x≡y) (*<* x<y) = ℤ.<-irrefl x≡y x<y
-
-<-asym : Asymmetric _<_
-<-asym (*<* x<y) = ℤ.<-asym x<y ∘ drop-*<*
-
-≤-<-trans : Trans _≤_ _<_ _<_
-≤-<-trans {p} {q} {r} (*≤* p≤q) (*<* q<r) = *<* $
-  ℤ.*-cancelʳ-<-nonNeg _ $ begin-strict
-  n₁ ℤ.*  d₃ ℤ.* d₂  ≡⟨ ℤ.*-assoc n₁ d₃ d₂ ⟩
-  n₁ ℤ.* (d₃ ℤ.* d₂) ≡⟨ cong (n₁ ℤ.*_) (ℤ.*-comm d₃ d₂) ⟩
-  n₁ ℤ.* (d₂ ℤ.* d₃) ≡˘⟨ ℤ.*-assoc n₁ d₂ d₃ ⟩
-  n₁ ℤ.*  d₂ ℤ.* d₃  ≤⟨ ℤ.*-monoʳ-≤-nonNeg (↧ r) p≤q ⟩
-  n₂ ℤ.*  d₁ ℤ.* d₃  ≡⟨ cong (ℤ._* d₃) (ℤ.*-comm n₂ d₁) ⟩
-  d₁ ℤ.*  n₂ ℤ.* d₃  ≡⟨ ℤ.*-assoc d₁ n₂ d₃ ⟩
-  d₁ ℤ.* (n₂ ℤ.* d₃) <⟨ ℤ.*-monoˡ-<-pos (↧ p) q<r ⟩
-  d₁ ℤ.* (n₃ ℤ.* d₂) ≡˘⟨ ℤ.*-assoc d₁ n₃ d₂ ⟩
-  d₁ ℤ.*  n₃ ℤ.* d₂  ≡⟨ cong (ℤ._* d₂) (ℤ.*-comm d₁ n₃) ⟩
-  n₃ ℤ.*  d₁ ℤ.* d₂  ∎
-  where open ℤ.≤-Reasoning
-        n₁ = ↥ p; n₂ = ↥ q; n₃ = ↥ r; d₁ = ↧ p; d₂ = ↧ q; d₃ = ↧ r
-
-<-≤-trans : Trans _<_ _≤_ _<_
-<-≤-trans {p} {q} {r} (*<* p<q) (*≤* q≤r) = *<* $
-  ℤ.*-cancelʳ-<-nonNeg _ $ begin-strict
-  n₁ ℤ.*  d₃ ℤ.* d₂  ≡⟨ ℤ.*-assoc n₁ d₃ d₂ ⟩
-  n₁ ℤ.* (d₃ ℤ.* d₂) ≡⟨ cong (n₁ ℤ.*_) (ℤ.*-comm d₃ d₂) ⟩
-  n₁ ℤ.* (d₂ ℤ.* d₃) ≡˘⟨ ℤ.*-assoc n₁ d₂ d₃ ⟩
-  n₁ ℤ.*  d₂ ℤ.* d₃  <⟨ ℤ.*-monoʳ-<-pos (↧ r) p<q ⟩
-  n₂ ℤ.*  d₁ ℤ.* d₃  ≡⟨ cong (ℤ._* d₃) (ℤ.*-comm n₂ d₁) ⟩
-  d₁ ℤ.*  n₂ ℤ.* d₃  ≡⟨ ℤ.*-assoc d₁ n₂ d₃ ⟩
-  d₁ ℤ.* (n₂ ℤ.* d₃) ≤⟨ ℤ.*-monoˡ-≤-nonNeg (↧ p) q≤r ⟩
-  d₁ ℤ.* (n₃ ℤ.* d₂) ≡˘⟨ ℤ.*-assoc d₁ n₃ d₂ ⟩
-  d₁ ℤ.*  n₃ ℤ.* d₂  ≡⟨ cong (ℤ._* d₂) (ℤ.*-comm d₁ n₃) ⟩
-  n₃ ℤ.*  d₁ ℤ.* d₂  ∎
-  where open ℤ.≤-Reasoning
-        n₁ = ↥ p; n₂ = ↥ q; n₃ = ↥ r; d₁ = ↧ p; d₂ = ↧ q; d₃ = ↧ r
-
-<-trans : Transitive _<_
-<-trans = ≤-<-trans ∘ <⇒≤
-
-<-cmp : Trichotomous _≃_ _<_
-<-cmp p q with ℤ.<-cmp (↥ p ℤ.* ↧ q) (↥ q ℤ.* ↧ p)
-... | tri< x<y x≉y x≯y = tri< (*<* x<y) (x≉y ∘ drop-*≡*) (x≯y ∘ drop-*<*)
-... | tri≈ x≮y x≈y x≯y = tri≈ (x≮y ∘ drop-*<*) (*≡* x≈y) (x≯y ∘ drop-*<*)
-... | tri> x≮y x≉y x>y = tri> (x≮y ∘ drop-*<*) (x≉y ∘ drop-*≡*) (*<* x>y)
-
-infix 4 _<?_ _>?_
-
-_<?_ : Decidable _<_
-p <? q = Dec.map′ *<* drop-*<* (↥ p ℤ.* ↧ q ℤ.<? ↥ q ℤ.* ↧ p)
-
-_>?_ : Decidable _>_
-_>?_ = flip _<?_
-
-<-irrelevant : Irrelevant _<_
-<-irrelevant (*<* p<q₁) (*<* p<q₂) = cong *<* (ℤ.<-irrelevant p<q₁ p<q₂)
-
-<-respʳ-≃ : _<_ Respectsʳ _≃_
-<-respʳ-≃ {p} {q} {r} (*≡* q≡r) (*<* p<q) = *<* $
-  ℤ.*-cancelʳ-<-nonNeg _ $ begin-strict
-  n₁ ℤ.*  d₃ ℤ.* d₂  ≡⟨ ℤ.*-assoc n₁ d₃ d₂ ⟩
-  n₁ ℤ.* (d₃ ℤ.* d₂) ≡⟨ cong (n₁ ℤ.*_) (ℤ.*-comm d₃ d₂) ⟩
-  n₁ ℤ.* (d₂ ℤ.* d₃) ≡˘⟨ ℤ.*-assoc n₁ d₂ d₃ ⟩
-  n₁ ℤ.*  d₂ ℤ.* d₃  <⟨ ℤ.*-monoʳ-<-pos (↧ r) p<q ⟩
-  n₂ ℤ.*  d₁ ℤ.* d₃  ≡⟨ ℤ.*-assoc n₂ d₁ d₃ ⟩
-  n₂ ℤ.* (d₁ ℤ.* d₃) ≡⟨ cong (n₂ ℤ.*_) (ℤ.*-comm d₁ d₃) ⟩
-  n₂ ℤ.* (d₃ ℤ.* d₁) ≡˘⟨ ℤ.*-assoc n₂ d₃ d₁ ⟩
-  n₂ ℤ.*  d₃ ℤ.* d₁  ≡⟨ cong (ℤ._* d₁) q≡r ⟩
-  n₃ ℤ.*  d₂ ℤ.* d₁  ≡⟨ ℤ.*-assoc n₃ d₂ d₁ ⟩
-  n₃ ℤ.* (d₂ ℤ.* d₁) ≡⟨ cong (n₃ ℤ.*_) (ℤ.*-comm d₂ d₁) ⟩
-  n₃ ℤ.* (d₁ ℤ.* d₂) ≡˘⟨ ℤ.*-assoc n₃ d₁ d₂ ⟩
-  n₃ ℤ.*  d₁ ℤ.* d₂  ∎
-  where open ℤ.≤-Reasoning
-        n₁ = ↥ p; n₂ = ↥ q; n₃ = ↥ r; d₁ = ↧ p; d₂ = ↧ q; d₃ = ↧ r
-
-<-respˡ-≃ : _<_ Respectsˡ _≃_
-<-respˡ-≃ q≃r q<p
-  = subst (_< _) (neg-involutive-≡ _)
-  $ subst (_ <_) (neg-involutive-≡ _)
-  $ neg-mono-< (<-respʳ-≃ (-‿cong q≃r) (neg-mono-< q<p))
-
-<-resp-≃ : _<_ Respects₂ _≃_
-<-resp-≃ = <-respʳ-≃ , <-respˡ-≃
-
-------------------------------------------------------------------------
--- Structures
-
-<-isStrictPartialOrder-≡ : IsStrictPartialOrder _≡_ _<_
-<-isStrictPartialOrder-≡ = record
-  { isEquivalence = isEquivalence
-  ; irrefl        = <-irrefl-≡
-  ; trans         = <-trans
-  ; <-resp-≈      = subst (_ <_) , subst (_< _)
-  }
-
-<-isStrictPartialOrder : IsStrictPartialOrder _≃_ _<_
-<-isStrictPartialOrder = record
-  { isEquivalence = ≃-isEquivalence
-  ; irrefl        = <-irrefl
-  ; trans         = <-trans
-  ; <-resp-≈      = <-resp-≃
-  }
-
-<-isStrictTotalOrder : IsStrictTotalOrder _≃_ _<_
-<-isStrictTotalOrder = record
-  { isEquivalence = ≃-isEquivalence
-  ; trans         = <-trans
-  ; compare       = <-cmp
-  }
-
-------------------------------------------------------------------------
--- Bundles
-
-<-strictPartialOrder-≡ : StrictPartialOrder 0ℓ 0ℓ 0ℓ
-<-strictPartialOrder-≡ = record
-  { isStrictPartialOrder = <-isStrictPartialOrder-≡
-  }
-
-<-strictPartialOrder : StrictPartialOrder 0ℓ 0ℓ 0ℓ
-<-strictPartialOrder = record
-  { isStrictPartialOrder = <-isStrictPartialOrder
-  }
-
-<-strictTotalOrder : StrictTotalOrder 0ℓ 0ℓ 0ℓ
-<-strictTotalOrder = record
-  { isStrictTotalOrder = <-isStrictTotalOrder
-  }
-
-------------------------------------------------------------------------
--- A specialised module for reasoning about the _≤_ and _<_ relations
-------------------------------------------------------------------------
-
-module ≤-Reasoning where
-  import Relation.Binary.Reasoning.Base.Triple
-    ≤-isPreorder
-    <-trans
-    <-resp-≃
-    <⇒≤
-    <-≤-trans
-    ≤-<-trans
-    as Triple
-  open Triple public hiding (step-≈; step-≈˘)
-
-  infixr 2 step-≃ step-≃˘
-
-  step-≃  = Triple.step-≈
-  step-≃˘ = Triple.step-≈˘
-
-  syntax step-≃  x y∼z x≃y = x ≃⟨  x≃y ⟩ y∼z
-  syntax step-≃˘ x y∼z y≃x = x ≃˘⟨ y≃x ⟩ y∼z
-
-
-------------------------------------------------------------------------
--- Properties of ↥_/↧_
-
-≥0⇒↥≥0 : ∀ {n dm} → mkℚᵘ n dm ≥ 0ℚᵘ → n ℤ.≥ 0ℤ
-≥0⇒↥≥0 {n} {dm} r≥0 = ℤ.≤-trans (drop-*≤* r≥0)
-                                (ℤ.≤-reflexive $ ℤ.*-identityʳ n)
-
->0⇒↥>0 : ∀ {n dm} → mkℚᵘ n dm > 0ℚᵘ → n ℤ.> 0ℤ
->0⇒↥>0 {n} {dm} r>0 = ℤ.<-≤-trans (drop-*<* r>0)
-                                  (ℤ.≤-reflexive $ ℤ.*-identityʳ n)
-
-------------------------------------------------------------------------
--- Properties of sign predicates
-
-positive⁻¹ : ∀ p → .{{Positive p}} → p > 0ℚᵘ
-positive⁻¹ (mkℚᵘ +[1+ n ] _) = *<* (ℤ.+<+ ℕ.z<s)
-
-nonNegative⁻¹ : ∀ p → .{{NonNegative p}} → p ≥ 0ℚᵘ
-nonNegative⁻¹ (mkℚᵘ +0       _) = *≤* (ℤ.+≤+ ℕ.z≤n)
-nonNegative⁻¹ (mkℚᵘ +[1+ n ] _) = *≤* (ℤ.+≤+ ℕ.z≤n)
+≤-poset : Poset 0ℓ 0ℓ 0ℓ
+≤-poset = record
+  { isPartialOrder = ≤-isPartialOrder
+  }
+
+≤-totalOrder : TotalOrder 0ℓ 0ℓ 0ℓ
+≤-totalOrder = record
+  { isTotalOrder = ≤-isTotalOrder
+  }
+
+≤-decTotalOrder : DecTotalOrder 0ℓ 0ℓ 0ℓ
+≤-decTotalOrder = record
+  { isDecTotalOrder = ≤-isDecTotalOrder
+  }
+
+------------------------------------------------------------------------
+-- Structures over _≡_
+
+≤-isPreorder-≡ : IsPreorder _≡_ _≤_
+≤-isPreorder-≡ = record
+  { isEquivalence = isEquivalence
+  ; reflexive     = ≤-reflexive-≡
+  ; trans         = ≤-trans
+  }
+
+≤-isTotalPreorder-≡ : IsTotalPreorder _≡_ _≤_
+≤-isTotalPreorder-≡ = record
+  { isPreorder = ≤-isPreorder-≡
+  ; total      = ≤-total
+  }
+
+------------------------------------------------------------------------
+-- Bundles over _≡_
+
+≤-preorder-≡ : Preorder 0ℓ 0ℓ 0ℓ
+≤-preorder-≡ = record
+  { isPreorder = ≤-isPreorder-≡
+  }
+
+≤-totalPreorder-≡ : TotalPreorder 0ℓ 0ℓ 0ℓ
+≤-totalPreorder-≡ = record
+  { isTotalPreorder = ≤-isTotalPreorder-≡
+  }
+
+------------------------------------------------------------------------
+-- Other properties of _≤_
+
+mono⇒cong : ∀ {f} → f Preserves _≤_ ⟶ _≤_ → f Preserves _≃_ ⟶ _≃_
+mono⇒cong = BC.mono⇒cong _≃_ _≃_ ≃-sym ≤-reflexive ≤-antisym
+
+antimono⇒cong : ∀ {f} → f Preserves _≤_ ⟶ _≥_ → f Preserves _≃_ ⟶ _≃_
+antimono⇒cong = BC.antimono⇒cong _≃_ _≃_ ≃-sym ≤-reflexive ≤-antisym
+
+------------------------------------------------------------------------
+-- Properties of _≤ᵇ_
+------------------------------------------------------------------------
+
+≤ᵇ⇒≤ : T (p ≤ᵇ q) → p ≤ q
+≤ᵇ⇒≤ = *≤* ∘ ℤ.≤ᵇ⇒≤
+
+≤⇒≤ᵇ : p ≤ q → T (p ≤ᵇ q)
+≤⇒≤ᵇ = ℤ.≤⇒≤ᵇ ∘ drop-*≤*
+
+------------------------------------------------------------------------
+-- Properties of _<_
+------------------------------------------------------------------------
+
+drop-*<* : p < q → (↥ p ℤ.* ↧ q) ℤ.< (↥ q ℤ.* ↧ p)
+drop-*<* (*<* pq<qp) = pq<qp
+
+------------------------------------------------------------------------
+-- Relationship between other operators
+
+<⇒≤ : _<_ ⇒ _≤_
+<⇒≤ (*<* p<q) = *≤* (ℤ.<⇒≤ p<q)
+
+<⇒≢ : _<_ ⇒ _≢_
+<⇒≢ (*<* x<y) refl = ℤ.<⇒≢ x<y refl
+
+<⇒≱ : _<_ ⇒ _≱_
+<⇒≱ (*<* x<y) = ℤ.<⇒≱ x<y ∘ drop-*≤*
+
+≰⇒> : _≰_ ⇒ _>_
+≰⇒> p≰q = *<* (ℤ.≰⇒> (p≰q ∘ *≤*))
+
+≮⇒≥ : _≮_ ⇒ _≥_
+≮⇒≥ p≮q = *≤* (ℤ.≮⇒≥ (p≮q ∘ *<*))
+
+≰⇒≥ : _≰_ ⇒ _≥_
+≰⇒≥ = <⇒≤ ∘ ≰⇒>
+
+------------------------------------------------------------------------
+-- Relational properties
+
+<-irrefl-≡ : Irreflexive _≡_ _<_
+<-irrefl-≡ refl (*<* x<x) = ℤ.<-irrefl refl x<x
+
+<-irrefl : Irreflexive _≃_ _<_
+<-irrefl (*≡* x≡y) (*<* x<y) = ℤ.<-irrefl x≡y x<y
+
+<-asym : Asymmetric _<_
+<-asym (*<* x<y) = ℤ.<-asym x<y ∘ drop-*<*
+
+<-dense : Dense _<_
+<-dense {p} {q} (*<* p<q) = m , p<m , m<q
+  where
+  open ℤ.≤-Reasoning
+  m : ℚᵘ
+  m = mkℚᵘ (↥ p ℤ.+ ↥ q) (pred (↧ₙ p ℕ.+ ↧ₙ q))
+
+  p<m : p < m
+  p<m = *<* (begin-strict
+    ↥ p ℤ.* ↧ m
+      ≡⟨⟩
+    ↥ p ℤ.* (↧ p ℤ.+ ↧ q)
+      ≡⟨ ℤ.*-distribˡ-+ (↥ p) (↧ p) (↧ q) ⟩
+    ↥ p ℤ.* ↧ p ℤ.+ ↥ p ℤ.* ↧ q
+      <⟨ ℤ.+-monoʳ-< (↥ p ℤ.* ↧ p) p<q ⟩
+    ↥ p ℤ.* ↧ p ℤ.+ ↥ q ℤ.* ↧ p
+      ≡⟨ ℤ.*-distribʳ-+ (↧ p) (↥ p) (↥ q) ⟨
+    (↥ p ℤ.+ ↥ q) ℤ.* ↧ p
+      ≡⟨⟩
+    ↥ m ℤ.* ↧ p ∎)
+
+  m<q : m < q
+  m<q = *<* (begin-strict
+    ↥ m ℤ.* ↧ q
+      ≡⟨ ℤ.*-distribʳ-+ (↧ q) (↥ p) (↥ q) ⟩
+    ↥ p ℤ.* ↧ q ℤ.+ ↥ q ℤ.* ↧ q
+      <⟨ ℤ.+-monoˡ-< (↥ q ℤ.* ↧ q) p<q ⟩
+    ↥ q ℤ.* ↧ p ℤ.+ ↥ q ℤ.* ↧ q
+      ≡⟨ ℤ.*-distribˡ-+ (↥ q) (↧ p) (↧ q) ⟨
+    ↥ q ℤ.* (↧ p ℤ.+ ↧ q)
+      ≡⟨⟩
+    ↥ q ℤ.* ↧ m ∎)
+
+≤-<-trans : Trans _≤_ _<_ _<_
+≤-<-trans {p} {q} {r} (*≤* p≤q) (*<* q<r) = *<* $
+  ℤ.*-cancelʳ-<-nonNeg _ $ begin-strict
+  n₁ ℤ.*  d₃ ℤ.* d₂  ≡⟨ ℤ.*-assoc n₁ d₃ d₂ ⟩
+  n₁ ℤ.* (d₃ ℤ.* d₂) ≡⟨ cong (n₁ ℤ.*_) (ℤ.*-comm d₃ d₂) ⟩
+  n₁ ℤ.* (d₂ ℤ.* d₃) ≡⟨ ℤ.*-assoc n₁ d₂ d₃ ⟨
+  n₁ ℤ.*  d₂ ℤ.* d₃  ≤⟨ ℤ.*-monoʳ-≤-nonNeg (↧ r) p≤q ⟩
+  n₂ ℤ.*  d₁ ℤ.* d₃  ≡⟨ cong (ℤ._* d₃) (ℤ.*-comm n₂ d₁) ⟩
+  d₁ ℤ.*  n₂ ℤ.* d₃  ≡⟨ ℤ.*-assoc d₁ n₂ d₃ ⟩
+  d₁ ℤ.* (n₂ ℤ.* d₃) <⟨ ℤ.*-monoˡ-<-pos (↧ p) q<r ⟩
+  d₁ ℤ.* (n₃ ℤ.* d₂) ≡⟨ ℤ.*-assoc d₁ n₃ d₂ ⟨
+  d₁ ℤ.*  n₃ ℤ.* d₂  ≡⟨ cong (ℤ._* d₂) (ℤ.*-comm d₁ n₃) ⟩
+  n₃ ℤ.*  d₁ ℤ.* d₂  ∎
+  where open ℤ.≤-Reasoning
+        n₁ = ↥ p; n₂ = ↥ q; n₃ = ↥ r; d₁ = ↧ p; d₂ = ↧ q; d₃ = ↧ r
+
+<-≤-trans : Trans _<_ _≤_ _<_
+<-≤-trans {p} {q} {r} (*<* p<q) (*≤* q≤r) = *<* $
+  ℤ.*-cancelʳ-<-nonNeg _ $ begin-strict
+  n₁ ℤ.*  d₃ ℤ.* d₂  ≡⟨ ℤ.*-assoc n₁ d₃ d₂ ⟩
+  n₁ ℤ.* (d₃ ℤ.* d₂) ≡⟨ cong (n₁ ℤ.*_) (ℤ.*-comm d₃ d₂) ⟩
+  n₁ ℤ.* (d₂ ℤ.* d₃) ≡⟨ ℤ.*-assoc n₁ d₂ d₃ ⟨
+  n₁ ℤ.*  d₂ ℤ.* d₃  <⟨ ℤ.*-monoʳ-<-pos (↧ r) p<q ⟩
+  n₂ ℤ.*  d₁ ℤ.* d₃  ≡⟨ cong (ℤ._* d₃) (ℤ.*-comm n₂ d₁) ⟩
+  d₁ ℤ.*  n₂ ℤ.* d₃  ≡⟨ ℤ.*-assoc d₁ n₂ d₃ ⟩
+  d₁ ℤ.* (n₂ ℤ.* d₃) ≤⟨ ℤ.*-monoˡ-≤-nonNeg (↧ p) q≤r ⟩
+  d₁ ℤ.* (n₃ ℤ.* d₂) ≡⟨ ℤ.*-assoc d₁ n₃ d₂ ⟨
+  d₁ ℤ.*  n₃ ℤ.* d₂  ≡⟨ cong (ℤ._* d₂) (ℤ.*-comm d₁ n₃) ⟩
+  n₃ ℤ.*  d₁ ℤ.* d₂  ∎
+  where open ℤ.≤-Reasoning
+        n₁ = ↥ p; n₂ = ↥ q; n₃ = ↥ r; d₁ = ↧ p; d₂ = ↧ q; d₃ = ↧ r
+
+<-trans : Transitive _<_
+<-trans = ≤-<-trans ∘ <⇒≤
+
+<-cmp : Trichotomous _≃_ _<_
+<-cmp p q with ℤ.<-cmp (↥ p ℤ.* ↧ q) (↥ q ℤ.* ↧ p)
+... | tri< x<y x≉y x≯y = tri< (*<* x<y) (x≉y ∘ drop-*≡*) (x≯y ∘ drop-*<*)
+... | tri≈ x≮y x≈y x≯y = tri≈ (x≮y ∘ drop-*<*) (*≡* x≈y) (x≯y ∘ drop-*<*)
+... | tri> x≮y x≉y x>y = tri> (x≮y ∘ drop-*<*) (x≉y ∘ drop-*≡*) (*<* x>y)
+
+infix 4 _<?_ _>?_
+
+_<?_ : Decidable _<_
+p <? q = Dec.map′ *<* drop-*<* (↥ p ℤ.* ↧ q ℤ.<? ↥ q ℤ.* ↧ p)
+
+_>?_ : Decidable _>_
+_>?_ = flip _<?_
+
+<-irrelevant : Irrelevant _<_
+<-irrelevant (*<* p<q₁) (*<* p<q₂) = cong *<* (ℤ.<-irrelevant p<q₁ p<q₂)
+
+<-respʳ-≃ : _<_ Respectsʳ _≃_
+<-respʳ-≃ {p} {q} {r} (*≡* q≡r) (*<* p<q) = *<* $
+  ℤ.*-cancelʳ-<-nonNeg _ $ begin-strict
+  n₁ ℤ.*  d₃ ℤ.* d₂  ≡⟨ ℤ.*-assoc n₁ d₃ d₂ ⟩
+  n₁ ℤ.* (d₃ ℤ.* d₂) ≡⟨ cong (n₁ ℤ.*_) (ℤ.*-comm d₃ d₂) ⟩
+  n₁ ℤ.* (d₂ ℤ.* d₃) ≡⟨ ℤ.*-assoc n₁ d₂ d₃ ⟨
+  n₁ ℤ.*  d₂ ℤ.* d₃  <⟨ ℤ.*-monoʳ-<-pos (↧ r) p<q ⟩
+  n₂ ℤ.*  d₁ ℤ.* d₃  ≡⟨ ℤ.*-assoc n₂ d₁ d₃ ⟩
+  n₂ ℤ.* (d₁ ℤ.* d₃) ≡⟨ cong (n₂ ℤ.*_) (ℤ.*-comm d₁ d₃) ⟩
+  n₂ ℤ.* (d₃ ℤ.* d₁) ≡⟨ ℤ.*-assoc n₂ d₃ d₁ ⟨
+  n₂ ℤ.*  d₃ ℤ.* d₁  ≡⟨ cong (ℤ._* d₁) q≡r ⟩
+  n₃ ℤ.*  d₂ ℤ.* d₁  ≡⟨ ℤ.*-assoc n₃ d₂ d₁ ⟩
+  n₃ ℤ.* (d₂ ℤ.* d₁) ≡⟨ cong (n₃ ℤ.*_) (ℤ.*-comm d₂ d₁) ⟩
+  n₃ ℤ.* (d₁ ℤ.* d₂) ≡⟨ ℤ.*-assoc n₃ d₁ d₂ ⟨
+  n₃ ℤ.*  d₁ ℤ.* d₂  ∎
+  where open ℤ.≤-Reasoning
+        n₁ = ↥ p; n₂ = ↥ q; n₃ = ↥ r; d₁ = ↧ p; d₂ = ↧ q; d₃ = ↧ r
+
+<-respˡ-≃ : _<_ Respectsˡ _≃_
+<-respˡ-≃ q≃r q<p
+  = subst (_< _) (neg-involutive-≡ _)
+  $ subst (_ <_) (neg-involutive-≡ _)
+  $ neg-mono-< (<-respʳ-≃ (-‿cong q≃r) (neg-mono-< q<p))
+
+<-resp-≃ : _<_ Respects₂ _≃_
+<-resp-≃ = <-respʳ-≃ , <-respˡ-≃
+
+------------------------------------------------------------------------
+-- Structures
+
+<-isStrictPartialOrder-≡ : IsStrictPartialOrder _≡_ _<_
+<-isStrictPartialOrder-≡ = record
+  { isEquivalence = isEquivalence
+  ; irrefl        = <-irrefl-≡
+  ; trans         = <-trans
+  ; <-resp-≈      = subst (_ <_) , subst (_< _)
+  }
+
+<-isStrictPartialOrder : IsStrictPartialOrder _≃_ _<_
+<-isStrictPartialOrder = record
+  { isEquivalence = ≃-isEquivalence
+  ; irrefl        = <-irrefl
+  ; trans         = <-trans
+  ; <-resp-≈      = <-resp-≃
+  }
+
+<-isStrictTotalOrder : IsStrictTotalOrder _≃_ _<_
+<-isStrictTotalOrder = record
+  { isStrictPartialOrder = <-isStrictPartialOrder
+  ; compare              = <-cmp
+  }
+
+<-isDenseLinearOrder : IsDenseLinearOrder _≃_ _<_
+<-isDenseLinearOrder = record
+  { isStrictTotalOrder = <-isStrictTotalOrder
+  ; dense              = <-dense
+  }
+
+------------------------------------------------------------------------
+-- Bundles
+
+<-strictPartialOrder-≡ : StrictPartialOrder 0ℓ 0ℓ 0ℓ
+<-strictPartialOrder-≡ = record
+  { isStrictPartialOrder = <-isStrictPartialOrder-≡
+  }
+
+<-strictPartialOrder : StrictPartialOrder 0ℓ 0ℓ 0ℓ
+<-strictPartialOrder = record
+  { isStrictPartialOrder = <-isStrictPartialOrder
+  }
+
+<-strictTotalOrder : StrictTotalOrder 0ℓ 0ℓ 0ℓ
+<-strictTotalOrder = record
+  { isStrictTotalOrder = <-isStrictTotalOrder
+  }
+
+<-denseLinearOrder : DenseLinearOrder 0ℓ 0ℓ 0ℓ
+<-denseLinearOrder = record
+  { isDenseLinearOrder = <-isDenseLinearOrder
+  }
+
+------------------------------------------------------------------------
+-- A specialised module for reasoning about the _≤_ and _<_ relations
+------------------------------------------------------------------------
+
+module ≤-Reasoning where
+  import Relation.Binary.Reasoning.Base.Triple
+    ≤-isPreorder
+    <-asym
+    <-trans
+    <-resp-≃
+    <⇒≤
+    <-≤-trans
+    ≤-<-trans
+    as Triple
+
+  open Triple public
+    hiding (step-≈; step-≈˘; step-≈-⟩; step-≈-⟨)
+    renaming (≈-go to ≃-go)
+
+  open ≃-syntax _IsRelatedTo_ _IsRelatedTo_ ≃-go ≃-sym public
+
+------------------------------------------------------------------------
+-- Properties of ↥_/↧_
+
+≥0⇒↥≥0 : ∀ {n dm} → mkℚᵘ n dm ≥ 0ℚᵘ → n ℤ.≥ 0ℤ
+≥0⇒↥≥0 {n} {dm} r≥0 = ℤ.≤-trans (drop-*≤* r≥0)
+                                (ℤ.≤-reflexive $ ℤ.*-identityʳ n)
+
+>0⇒↥>0 : ∀ {n dm} → mkℚᵘ n dm > 0ℚᵘ → n ℤ.> 0ℤ
+>0⇒↥>0 {n} {dm} r>0 = ℤ.<-≤-trans (drop-*<* r>0)
+                                  (ℤ.≤-reflexive $ ℤ.*-identityʳ n)
+
+------------------------------------------------------------------------
+-- Properties of sign predicates
+
+positive⁻¹ : ∀ p → .{{Positive p}} → p > 0ℚᵘ
+positive⁻¹ (mkℚᵘ +[1+ n ] _) = *<* (ℤ.+<+ ℕ.z<s)
+
+nonNegative⁻¹ : ∀ p → .{{NonNegative p}} → p ≥ 0ℚᵘ
+nonNegative⁻¹ (mkℚᵘ +0       _) = *≤* (ℤ.+≤+ ℕ.z≤n)
+nonNegative⁻¹ (mkℚᵘ +[1+ n ] _) = *≤* (ℤ.+≤+ ℕ.z≤n)
+
+negative⁻¹ : ∀ p → .{{Negative p}} → p < 0ℚᵘ
+negative⁻¹ (mkℚᵘ -[1+ n ] _) = *<* ℤ.-<+
+
+nonPositive⁻¹ : ∀ p → .{{NonPositive p}} → p ≤ 0ℚᵘ
+nonPositive⁻¹ (mkℚᵘ +0       _) = *≤* (ℤ.+≤+ ℕ.z≤n)
+nonPositive⁻¹ (mkℚᵘ -[1+ n ] _) = *≤* ℤ.-≤+
+
+pos⇒nonNeg : ∀ p → .{{Positive p}} → NonNegative p
+pos⇒nonNeg (mkℚᵘ +0       _) = _
+pos⇒nonNeg (mkℚᵘ +[1+ n ] _) = _
+
+neg⇒nonPos : ∀ p → .{{Negative p}} → NonPositive p
+neg⇒nonPos (mkℚᵘ +0       _) = _
+neg⇒nonPos (mkℚᵘ -[1+ n ] _) = _
 
-negative⁻¹ : ∀ p → .{{Negative p}} → p < 0ℚᵘ
-negative⁻¹ (mkℚᵘ -[1+ n ] _) = *<* ℤ.-<+
-
-nonPositive⁻¹ : ∀ p → .{{NonPositive p}} → p ≤ 0ℚᵘ
-nonPositive⁻¹ (mkℚᵘ +0       _) = *≤* (ℤ.+≤+ ℕ.z≤n)
-nonPositive⁻¹ (mkℚᵘ -[1+ n ] _) = *≤* ℤ.-≤+
+neg<pos : ∀ p q → .{{Negative p}} → .{{Positive q}} → p < q
+neg<pos p q = <-trans (negative⁻¹ p) (positive⁻¹ q)
 
-pos⇒nonNeg : ∀ p → .{{Positive p}} → NonNegative p
-pos⇒nonNeg (mkℚᵘ +0       _) = _
-pos⇒nonNeg (mkℚᵘ +[1+ n ] _) = _
+pos⇒nonZero : ∀ p → .{{Positive p}} → NonZero p
+pos⇒nonZero (mkℚᵘ (+[1+ _ ]) _) = _
 
-neg⇒nonPos : ∀ p → .{{Negative p}} → NonPositive p
-neg⇒nonPos (mkℚᵘ +0       _) = _
-neg⇒nonPos (mkℚᵘ -[1+ n ] _) = _
+nonNeg∧nonPos⇒0 : ∀ p → .{{NonNegative p}} → .{{NonPositive p}} → p ≃ 0ℚᵘ
+nonNeg∧nonPos⇒0 (mkℚᵘ +0 _) = *≡* refl
 
-neg<pos : ∀ p q → .{{Negative p}} → .{{Positive q}} → p < q
-neg<pos p q = <-trans (negative⁻¹ p) (positive⁻¹ q)
+nonNeg<⇒pos : ∀ {p q} .{{_ : NonNegative p}} → p < q → Positive q
+nonNeg<⇒pos {p} p<q = positive (≤-<-trans (nonNegative⁻¹ p) p<q)
 
-pos⇒nonZero : ∀ p → .{{Positive p}} → NonZero p
-pos⇒nonZero (mkℚᵘ (+[1+ _ ]) _) = _
+nonNeg≤⇒nonNeg : ∀ {p q} .{{_ : NonNegative p}} → p ≤ q → NonNegative q
+nonNeg≤⇒nonNeg {p} p≤q = nonNegative (≤-trans (nonNegative⁻¹ p) p≤q)
 
-nonNeg∧nonPos⇒0 : ∀ p → .{{NonNegative p}} → .{{NonPositive p}} → p ≃ 0ℚᵘ
-nonNeg∧nonPos⇒0 (mkℚᵘ +0 _) = *≡* refl
+neg⇒nonZero : ∀ p → .{{Negative p}} → NonZero p
+neg⇒nonZero (mkℚᵘ (-[1+ _ ]) _) = _
 
-nonNeg<⇒pos : ∀ {p q} .{{_ : NonNegative p}} → p < q → Positive q
-nonNeg<⇒pos {p} p<q = positive (≤-<-trans (nonNegative⁻¹ p) p<q)
+------------------------------------------------------------------------
+-- Properties of _+_
+------------------------------------------------------------------------
 
-nonNeg≤⇒nonNeg : ∀ {p q} .{{_ : NonNegative p}} → p ≤ q → NonNegative q
-nonNeg≤⇒nonNeg {p} p≤q = nonNegative (≤-trans (nonNegative⁻¹ p) p≤q)
+------------------------------------------------------------------------
+-- Algebraic properties
 
-neg⇒nonZero : ∀ p → .{{Negative p}} → NonZero p
-neg⇒nonZero (mkℚᵘ (-[1+ _ ]) _) = _
+-- Congruence
 
-------------------------------------------------------------------------
--- Properties of _+_
-------------------------------------------------------------------------
++-cong : Congruent₂ _≃_ _+_
++-cong {x@record{}} {y@record{}} {u@record{}} {v@record{}} (*≡* 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
+
++-congʳ : ∀ p → q ≃ r → p + q ≃ p + r
++-congʳ p q≃r = +-cong (≃-refl {p}) q≃r
+
++-congˡ : ∀ p → q ≃ r → q + p ≃ r + p
++-congˡ p q≃r = +-cong q≃r (≃-refl {p})
+
+-- Associativity
 
-------------------------------------------------------------------------
--- Algebraic properties
++-assoc-↥ : Associative (_≡_ on ↥_) _+_
++-assoc-↥ p@record{} q@record{} r@record{} = 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
 
--- Congruence
-
-+-cong : Congruent₂ _≃_ _+_
-+-cong {x@record{}} {y@record{}} {u@record{}} {v@record{}} (*≡* 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
-
-+-congʳ : ∀ p → q ≃ r → p + q ≃ p + r
-+-congʳ p q≃r = +-cong (≃-refl {p}) q≃r
-
-+-congˡ : ∀ p → q ≃ r → q + p ≃ r + p
-+-congˡ p q≃r = +-cong q≃r (≃-refl {p})
-
--- Associativity
-
-+-assoc-↥ : Associative (_≡_ on ↥_) _+_
-+-assoc-↥ p@record{} q@record{} r@record{} = 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@record{} q@record{} r@record{} = ℕ.*-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@record{} q@record{} = ℤ.+-comm (↥ p ℤ.* ↧ q) (↥ q ℤ.* ↧ p)
-
-+-comm-↧ : Commutative (_≡_ on ↧ₙ_) _+_
-+-comm-↧ p@record{} q@record{} = ℕ.*-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@record{} = begin
-  0ℤ ℤ.* ↧ p ℤ.+ ↥ p ℤ.* 1ℤ ≡⟨ cong₂ ℤ._+_ (ℤ.*-zeroˡ (↧ p)) (ℤ.*-identityʳ (↥ p)) ⟩
-  0ℤ ℤ.+ ↥ p                ≡⟨ ℤ.+-identityˡ (↥ p) ⟩
-  ↥ p                       ∎ where open ≡-Reasoning
-
-+-identityˡ-↧ : LeftIdentity (_≡_ on ↧ₙ_) 0ℚᵘ _+_
-+-identityˡ-↧ p@record{} = ℕ.+-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@record{} = *≡* 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@record{} = *≡* 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ʳ
-
-+-cancelˡ : ∀ {r p q} → r + p ≃ r + q → p ≃ q
-+-cancelˡ {r} {p} {q} r+p≃r+q = begin-equality
-  p            ≃˘⟨ +-identityʳ p ⟩
-  p + 0ℚᵘ      ≃˘⟨ +-congʳ p (+-inverseʳ r) ⟩
-  p + (r - r)  ≃˘⟨ +-assoc p r (- r) ⟩
-  (p + r) - r  ≃⟨ +-congˡ (- r) (+-comm p r) ⟩
-  (r + p) - r  ≃⟨ +-congˡ (- r) r+p≃r+q ⟩
-  (r + q) - r  ≃⟨ +-congˡ (- r) (+-comm r q) ⟩
-  (q + r) - r  ≃⟨ +-assoc q r (- r) ⟩
-  q + (r - r)  ≃⟨ +-congʳ q (+-inverseʳ r) ⟩
-  q + 0ℚᵘ      ≃⟨ +-identityʳ q ⟩
-  q            ∎ where open ≤-Reasoning
-
-+-cancelʳ : ∀ {r p q} → p + r ≃ q + r → p ≃ q
-+-cancelʳ {r} {p} {q} p+r≃q+r = +-cancelˡ {r} $ begin-equality
-  r + p ≃⟨ +-comm r p ⟩
-  p + r ≃⟨ p+r≃q+r ⟩
-  q + r ≃⟨ +-comm q r ⟩
-  r + q ∎ where open ≤-Reasoning
-
-p+p≃0⇒p≃0 : ∀ p → p + p ≃ 0ℚᵘ → p ≃ 0ℚᵘ
-p+p≃0⇒p≃0 (mkℚᵘ ℤ.+0 _) (*≡* _) = *≡* refl
-
-------------------------------------------------------------------------
--- Properties of _+_ and -_
-
-neg-distrib-+ : ∀ p q → - (p + q) ≡ (- p) + (- q)
-neg-distrib-+ p@record{} q@record{} = ↥↧≡⇒≡ (begin
-    ℤ.- (↥ p ℤ.* ↧ q ℤ.+ ↥ q ℤ.* ↧ p)       ≡⟨ ℤ.neg-distrib-+ (↥ p ℤ.* ↧ q) _ ⟩
-    ℤ.- (↥ p ℤ.* ↧ q) ℤ.+ ℤ.- (↥ q ℤ.* ↧ p) ≡⟨ cong₂ ℤ._+_ (ℤ.neg-distribˡ-* (↥ p) _)
-                                                           (ℤ.neg-distribˡ-* (↥ q) _) ⟩
-    (ℤ.- ↥ p) ℤ.* ↧ q ℤ.+ (ℤ.- ↥ q) ℤ.* ↧ p ∎
-  ) refl
-  where open ≡-Reasoning
-
-p≃-p⇒p≃0 : ∀ p → p ≃ - p → p ≃ 0ℚᵘ
-p≃-p⇒p≃0 p p≃-p = p+p≃0⇒p≃0 p (begin-equality
-  p + p  ≃⟨ +-congʳ p p≃-p ⟩
-  p - p  ≃⟨ +-inverseʳ p ⟩
-  0ℚᵘ    ∎)
-  where open ≤-Reasoning
-
-------------------------------------------------------------------------
--- Properties of _+_ and _≤_
-
-private
-  lemma : ∀ r p q → (↥ r ℤ.* ↧ p ℤ.+ ↥ p ℤ.* ↧ r) ℤ.* (↧ r ℤ.* ↧ q)
-                    ≡ (↥ r ℤ.* ↧ r) ℤ.* (↧ p ℤ.* ↧ q) ℤ.+ (↧ r ℤ.* ↧ r) ℤ.* (↥ p ℤ.* ↧ q)
-  lemma r p q = solve 5 (λ ↥r ↧r ↧p ↥p ↧q →
-                          (↥r :* ↧p :+ ↥p :* ↧r) :* (↧r :* ↧q) :=
-                          (↥r :* ↧r) :* (↧p :* ↧q) :+ (↧r :* ↧r) :* (↥p :* ↧q))
-                      refl (↥ r) (↧ r) (↧ p) (↥ p) (↧ q)
-    where open ℤ-solver
-
-+-monoʳ-≤ : ∀ r → (r +_) Preserves _≤_ ⟶ _≤_
-+-monoʳ-≤ r@record{} {p@record{}} {q@record{}} (*≤* x≤y) = *≤* $ begin
-  ↥ (r + p) ℤ.* ↧ (r + q)                                  ≡⟨ lemma r p q ⟩
-  r₂ ℤ.* (↧ p ℤ.* ↧ q) ℤ.+ (↧ r ℤ.* ↧ r) ℤ.* (↥ p ℤ.* ↧ q) ≤⟨ leq ⟩
-  r₂ ℤ.* (↧ q ℤ.* ↧ p) ℤ.+ (↧ r ℤ.* ↧ r) ℤ.* (↥ q ℤ.* ↧ p) ≡⟨ sym $ lemma r q p ⟩
-  ↥ (r + q) ℤ.* (↧ (r + p))                                ∎
-  where
-  open ℤ.≤-Reasoning; r₂ = ↥ r ℤ.* ↧ r
-  leq = ℤ.+-mono-≤
-    (ℤ.≤-reflexive $ cong (r₂ ℤ.*_) (ℤ.*-comm (↧ p) (↧ q)))
-    (ℤ.*-monoˡ-≤-nonNeg (↧ r ℤ.* ↧ r) x≤y)
-
-+-monoˡ-≤ : ∀ r → (_+ r) Preserves _≤_ ⟶ _≤_
-+-monoˡ-≤ r {p} {q} rewrite +-comm-≡ p r | +-comm-≡ q r = +-monoʳ-≤ r
-
-+-mono-≤ : _+_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_
-+-mono-≤ {p} {q} {u} {v} p≤q u≤v = ≤-trans (+-monoˡ-≤ u p≤q) (+-monoʳ-≤ q u≤v)
-
-p≤q⇒p≤r+q : ∀ r .{{_ : NonNegative r}} → p ≤ q → p ≤ r + q
-p≤q⇒p≤r+q {p} {q} r p≤q = subst (_≤ r + q) (+-identityˡ-≡ p) (+-mono-≤ (nonNegative⁻¹ r) p≤q)
-
-p≤q+p : ∀ p q .{{_ : NonNegative q}} → p ≤ q + p
-p≤q+p p q = p≤q⇒p≤r+q q ≤-refl
-
-p≤p+q : ∀ p q .{{_ : NonNegative q}} → p ≤ p + q
-p≤p+q p q rewrite +-comm-≡ p q = p≤q+p p q
-
-------------------------------------------------------------------------
--- Properties of _+_ and _<_
-
-+-monoʳ-< : ∀ r → (r +_) Preserves _<_ ⟶ _<_
-+-monoʳ-< r@record{} {p@record{}} {q@record{}} (*<* x<y) = *<* $ begin-strict
-  ↥ (r + p) ℤ.* (↧ (r + q))                          ≡⟨ lemma r p q ⟩
-  ↥r↧r ℤ.* (↧ p ℤ.* ↧ q) ℤ.+ ↧r↧r ℤ.* (↥ p ℤ.* ↧ q)  <⟨ leq ⟩
-  ↥r↧r ℤ.* (↧ q ℤ.* ↧ p) ℤ.+ ↧r↧r ℤ.* (↥ q ℤ.* ↧ p)  ≡⟨ sym $ lemma r q p ⟩
-  ↥ (r + q) ℤ.* (↧ (r + p))                          ∎
-  where
-  open ℤ.≤-Reasoning; ↥r↧r = ↥ r ℤ.* ↧ r; ↧r↧r = ↧ r ℤ.* ↧ r
-  leq = ℤ.+-mono-≤-<
-    (ℤ.≤-reflexive $ cong (↥r↧r ℤ.*_) (ℤ.*-comm (↧ p) (↧ q)))
-    (ℤ.*-monoˡ-<-pos ↧r↧r x<y)
-
-+-monoˡ-< : ∀ r → (_+ r) Preserves _<_ ⟶ _<_
-+-monoˡ-< r {p} {q} rewrite +-comm-≡ p r | +-comm-≡ q r = +-monoʳ-< r
-
-+-mono-< : _+_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_
-+-mono-< {p} {q} {u} {v} p<q u<v = <-trans (+-monoˡ-< u p<q) (+-monoʳ-< q u<v)
-
-+-mono-≤-< : _+_ Preserves₂ _≤_ ⟶ _<_ ⟶ _<_
-+-mono-≤-< {p} {q} {r} p≤q q<r = ≤-<-trans (+-monoˡ-≤ r p≤q) (+-monoʳ-< q q<r)
-
-+-mono-<-≤ : _+_ Preserves₂ _<_ ⟶ _≤_ ⟶ _<_
-+-mono-<-≤ {p} {q} {r} p<q q≤r = <-≤-trans (+-monoˡ-< r p<q) (+-monoʳ-≤ q q≤r)
-
------------------------------------------------------------------------
--- Properties of _+_ and predicates
-
-pos+pos⇒pos : ∀ p .{{_ : Positive p}} →
-              ∀ q .{{_ : Positive q}} →
-              Positive (p + q)
-pos+pos⇒pos p q = positive (+-mono-< (positive⁻¹ p) (positive⁻¹ q))
-
-nonNeg+nonNeg⇒nonNeg : ∀ p .{{_ : NonNegative p}} →
-                       ∀ q .{{_ : NonNegative q}} →
-                       NonNegative (p + q)
-nonNeg+nonNeg⇒nonNeg p q = nonNegative
-  (+-mono-≤ (nonNegative⁻¹ p) (nonNegative⁻¹ q))
-
------------------------------------------------------------------------
--- Properties of _-_
-
-+-minus-telescope : ∀ p q r → (p - q) + (q - r) ≃ p - r
-+-minus-telescope p q r = begin-equality
-  (p - q) + (q - r)   ≃⟨ ≃-sym (+-assoc (p - q) q (- r)) ⟩
-  (p - q) + q - r     ≃⟨ +-congˡ (- r) (+-assoc p (- q) q) ⟩
-  (p + (- q + q)) - r ≃⟨ +-congˡ (- r) (+-congʳ p (+-inverseˡ q)) ⟩
-  (p + 0ℚᵘ) - r       ≃⟨ +-congˡ (- r) (+-identityʳ p) ⟩
-  p - r               ∎ where open ≤-Reasoning
-
-p≃q⇒p-q≃0 : ∀ p q → p ≃ q → p - q ≃ 0ℚᵘ
-p≃q⇒p-q≃0 p q p≃q = begin-equality
-  p - q ≃⟨ +-congˡ (- q) p≃q ⟩
-  q - q ≃⟨ +-inverseʳ q ⟩
-  0ℚᵘ   ∎ where open ≤-Reasoning
-
-p-q≃0⇒p≃q : ∀ p q → p - q ≃ 0ℚᵘ → p ≃ q
-p-q≃0⇒p≃q p q p-q≃0 = begin-equality
-  p             ≡˘⟨ +-identityʳ-≡ p ⟩
-  p + 0ℚᵘ       ≃⟨ +-congʳ p (≃-sym (+-inverseˡ q)) ⟩
-  p + (- q + q) ≡˘⟨ +-assoc-≡ p (- q) q ⟩
-  (p - q) + q   ≃⟨ +-congˡ q p-q≃0 ⟩
-  0ℚᵘ + q       ≡⟨ +-identityˡ-≡ q ⟩
-  q             ∎ where open ≤-Reasoning
-
-neg-mono-≤ : -_ Preserves _≤_ ⟶ _≥_
-neg-mono-≤ {p@record{}} {q@record{}} (*≤* p≤q) = *≤* $ begin
-  ℤ.- ↥ q ℤ.* ↧ p   ≡˘⟨ ℤ.neg-distribˡ-* (↥ q) (↧ p) ⟩
-  ℤ.- (↥ q ℤ.* ↧ p) ≤⟨ ℤ.neg-mono-≤ p≤q ⟩
-  ℤ.- (↥ p ℤ.* ↧ q) ≡⟨ ℤ.neg-distribˡ-* (↥ p) (↧ q) ⟩
-  ℤ.- ↥ p ℤ.* ↧ q   ∎ where open ℤ.≤-Reasoning
-
-neg-cancel-≤ : ∀ {p q} → - p ≤ - q → q ≤ p
-neg-cancel-≤ {p@record{}} {q@record{}} (*≤* -↥p↧q≤-↥q↧p) = *≤* $ begin
-  ↥ q ℤ.* ↧ p             ≡˘⟨ ℤ.neg-involutive (↥ q ℤ.* ↧ p) ⟩
-  ℤ.- ℤ.- (↥ q ℤ.* ↧ p)   ≡⟨ cong ℤ.-_ (ℤ.neg-distribˡ-* (↥ q) (↧ p)) ⟩
-  ℤ.- ((ℤ.- ↥ q) ℤ.* ↧ p) ≤⟨ ℤ.neg-mono-≤ -↥p↧q≤-↥q↧p ⟩
-  ℤ.- ((ℤ.- ↥ p) ℤ.* ↧ q) ≡˘⟨ cong ℤ.-_ (ℤ.neg-distribˡ-* (↥ p) (↧ q)) ⟩
-  ℤ.- ℤ.- (↥ p ℤ.* ↧ q)   ≡⟨ ℤ.neg-involutive (↥ p ℤ.* ↧ q) ⟩
-  ↥ p ℤ.* ↧ q             ∎
-  where
-    open ℤ.≤-Reasoning
-
-p≤q⇒p-q≤0 : ∀ {p q} → p ≤ q → p - q ≤ 0ℚᵘ
-p≤q⇒p-q≤0 {p} {q} p≤q = begin
-  p - q ≤⟨ +-monoˡ-≤ (- q) p≤q ⟩
-  q - q ≃⟨ +-inverseʳ q ⟩
-  0ℚᵘ   ∎ where open ≤-Reasoning
-
-p-q≤0⇒p≤q : ∀ {p q} → p - q ≤ 0ℚᵘ → p ≤ q
-p-q≤0⇒p≤q {p} {q} p-q≤0 = begin
-  p             ≡˘⟨ +-identityʳ-≡ p ⟩
-  p + 0ℚᵘ       ≃⟨ +-congʳ p (≃-sym (+-inverseˡ q)) ⟩
-  p + (- q + q) ≡˘⟨ +-assoc-≡ p (- q) q ⟩
-  (p - q) + q   ≤⟨ +-monoˡ-≤ q p-q≤0 ⟩
-  0ℚᵘ + q       ≡⟨ +-identityˡ-≡ q ⟩
-  q             ∎ where open ≤-Reasoning
-
-p≤q⇒0≤q-p : ∀ {p q} → p ≤ q → 0ℚᵘ ≤ q - p
-p≤q⇒0≤q-p {p} {q} p≤q = begin
-  0ℚᵘ   ≃⟨ ≃-sym (+-inverseʳ p) ⟩
-  p - p ≤⟨ +-monoˡ-≤ (- p) p≤q ⟩
-  q - p ∎ where open ≤-Reasoning
-
-0≤q-p⇒p≤q : ∀ {p q} → 0ℚᵘ ≤ q - p → p ≤ q
-0≤q-p⇒p≤q {p} {q} 0≤p-q = begin
-  p             ≡˘⟨ +-identityˡ-≡ p ⟩
-  0ℚᵘ + p       ≤⟨ +-monoˡ-≤ p 0≤p-q ⟩
-  q - p + p     ≡⟨ +-assoc-≡ q (- p) p ⟩
-  q + (- p + p) ≃⟨ +-congʳ q (+-inverseˡ p) ⟩
-  q + 0ℚᵘ       ≡⟨ +-identityʳ-≡ q ⟩
-  q             ∎ 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 _*_
-------------------------------------------------------------------------
-
-------------------------------------------------------------------------
--- Algebraic properties
-
-*-cong : Congruent₂ _≃_ _*_
-*-cong {x@record{}} {y@record{}} {u@record{}} {v@record{}} (*≡* ↥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
-
-*-congˡ : LeftCongruent _≃_ _*_
-*-congˡ {p} q≃r = *-cong (≃-refl {p}) q≃r
-
-*-congʳ : RightCongruent _≃_ _*_
-*-congʳ {p} q≃r = *-cong q≃r (≃-refl {p})
-
--- Associativity
-
-*-assoc-↥ : Associative (_≡_ on ↥_) _*_
-*-assoc-↥ p@record{} q@record{} r@record{} = ℤ.*-assoc (↥ p) (↥ q) (↥ r)
-
-*-assoc-↧ : Associative (_≡_ on ↧ₙ_) _*_
-*-assoc-↧ p@record{} q@record{} r@record{} = ℕ.*-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@record{} q@record{} = ℤ.*-comm (↥ p) (↥ q)
-
-*-comm-↧ : Commutative (_≡_ on ↧ₙ_) _*_
-*-comm-↧ p@record{} q@record{} = ℕ.*-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@record{} = ↥↧≡⇒≡ (ℤ.*-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ʳ
-
-*-inverseˡ : ∀ p .{{_ : NonZero p}} → (1/ p) * p ≃ 1ℚᵘ
-*-inverseˡ p@(mkℚᵘ -[1+ n ] d) = *-inverseˡ (mkℚᵘ +[1+ n ] d)
-*-inverseˡ p@(mkℚᵘ +[1+ n ] d) = *≡* $ cong +[1+_] $ begin
-  (n ℕ.+ d ℕ.* suc n) ℕ.* 1 ≡⟨ ℕ.*-identityʳ _ ⟩
-  (n ℕ.+ d ℕ.* suc n)       ≡⟨ cong (n ℕ.+_) (ℕ.*-suc d n) ⟩
-  (n ℕ.+ (d ℕ.+ d ℕ.* n))   ≡⟨ solve 2 (λ n d → n :+ (d :+ d :* n) := d :+ (n :+ n :* d)) refl n d ⟩
-  (d ℕ.+ (n ℕ.+ n ℕ.* d))   ≡⟨ cong (d ℕ.+_) (sym (ℕ.*-suc n d)) ⟩
-  d ℕ.+ n ℕ.* suc d         ≡˘⟨ ℕ.+-identityʳ _ ⟩
-  d ℕ.+ n ℕ.* suc d ℕ.+ 0   ∎
-  where open ≡-Reasoning; open ℕ-solver
-
-*-inverseʳ : ∀ p .{{_ : NonZero p}} → p * 1/ p ≃ 1ℚᵘ
-*-inverseʳ p = ≃-trans (*-comm p (1/ p)) (*-inverseˡ p)
-
-*-zeroˡ : LeftZero _≃_ 0ℚᵘ _*_
-*-zeroˡ p@record{} = *≡* refl
-
-*-zeroʳ : RightZero _≃_ 0ℚᵘ _*_
-*-zeroʳ = Consequences.comm+zeˡ⇒zeʳ ≃-setoid *-comm *-zeroˡ
-
-*-zero : Zero _≃_ 0ℚᵘ _*_
-*-zero = *-zeroˡ , *-zeroʳ
-
-*-distribˡ-+ : _DistributesOverˡ_ _≃_ _*_ _+_
-*-distribˡ-+ p@record{} q@record{} r@record{} =
-  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ʳ-+ = Consequences.comm+distrˡ⇒distrʳ ≃-setoid +-cong *-comm *-distribˡ-+
-
-*-distrib-+ : _DistributesOver_ _≃_ _*_ _+_
-*-distrib-+ = *-distribˡ-+ , *-distribʳ-+
-
-------------------------------------------------------------------------
--- Properties of _*_ and -_
-
-neg-distribˡ-* : ∀ p q → - (p * q) ≃ - p * q
-neg-distribˡ-* p@record{} q@record{} =
-  *≡* $ cong (ℤ._* (↧ p ℤ.* ↧ q)) $ ℤ.neg-distribˡ-* (↥ p) (↥ q)
-
-neg-distribʳ-* : ∀ p q → - (p * q) ≃ p * - q
-neg-distribʳ-* p@record{} q@record{} =
-  *≡* $ cong (ℤ._* (↧ p ℤ.* ↧ q)) $ ℤ.neg-distribʳ-* (↥ p) (↥ q)
-
-------------------------------------------------------------------------
--- Properties of _*_ and _/_
-
-*-cancelˡ-/ : ∀ p {q r} .{{_ : ℕ.NonZero r}} .{{_ : ℕ.NonZero (p ℕ.* r)}} →
-              ((ℤ.+ p ℤ.* q) / (p ℕ.* r)) ≃ (q / r)
-*-cancelˡ-/ p {q} {r} = *≡* (begin-equality
-  (↥ ((ℤ.+ p ℤ.* q) / (p ℕ.* r))) ℤ.* (↧ (q / r)) ≡⟨  cong (ℤ._* ↧ (q / r)) (↥[n/d]≡n (ℤ.+ p ℤ.* q) (p ℕ.* r)) ⟩
-  (ℤ.+ p ℤ.* q) ℤ.* (↧ (q / r))                   ≡⟨  cong ((ℤ.+ p ℤ.* q) ℤ.*_) (↧[n/d]≡d q r) ⟩
-  (ℤ.+ p ℤ.* q) ℤ.* ℤ.+ r                         ≡⟨  xy∙z≈y∙xz (ℤ.+ p) q (ℤ.+ r) ⟩
-  (q ℤ.* (ℤ.+ p ℤ.* ℤ.+ r))                       ≡˘⟨ cong (ℤ._* (ℤ.+ p ℤ.* ℤ.+ r)) (↥[n/d]≡n q r) ⟩
-  (↥ (q / r)) ℤ.* (ℤ.+ p ℤ.* ℤ.+ r)               ≡˘⟨  cong (↥ (q / r) ℤ.*_) (ℤ.pos-* p r) ⟩
-  (↥ (q / r)) ℤ.* (ℤ.+ (p ℕ.* r))                 ≡˘⟨ cong (↥ (q / r) ℤ.*_) (↧[n/d]≡d (ℤ.+ p ℤ.* q) (p ℕ.* r)) ⟩
-  (↥ (q / r)) ℤ.* (↧ ((ℤ.+ p ℤ.* q) / (p ℕ.* r))) ∎)
-  where open ℤ.≤-Reasoning
-
-*-cancelʳ-/ : ∀ p {q r} .{{_ : ℕ.NonZero r}} .{{_ : ℕ.NonZero (r ℕ.* p)}} →
-              ((q ℤ.* ℤ.+ p) / (r ℕ.* p)) ≃ (q / r)
-*-cancelʳ-/ p {q} {r} rewrite ℕ.*-comm r p | ℤ.*-comm q (ℤ.+ p) = *-cancelˡ-/ p
-
-------------------------------------------------------------------------
--- Properties of _*_ and _≤_
-
-private
-  reorder₁ : ∀ a b c d → a ℤ.* b ℤ.* (c ℤ.* d) ≡ a ℤ.* c ℤ.* b ℤ.* d
-  reorder₁ = solve 4 (λ a b c d → (a :* b) :* (c :* d) := (a :* c) :* b :* d) refl
-    where open ℤ-solver
-
-  reorder₂ : ∀ a b c d → a ℤ.* b ℤ.* (c ℤ.* d) ≡ a ℤ.* c ℤ.* (b ℤ.* d)
-  reorder₂ = solve 4 (λ a b c d → (a :* b) :* (c :* d) := (a :* c) :* (b :* d)) refl
-    where open ℤ-solver
-
-  +▹-nonNeg : ∀ n → ℤ.NonNegative (Sign.+ ℤ.◃ n)
-  +▹-nonNeg 0       = _
-  +▹-nonNeg (suc _) = _
-
-*-cancelʳ-≤-pos : ∀ r .{{_ : Positive r}} → p * r ≤ q * r → p ≤ q
-*-cancelʳ-≤-pos {p@record{}} {q@record{}} r@(mkℚᵘ +[1+ _ ] _) (*≤* x≤y) =
- *≤* $ ℤ.*-cancelʳ-≤-pos _ _ (↥ r ℤ.* ↧ r) $ begin
-    (↥ p ℤ.* ↧ q) ℤ.* (↥ r ℤ.* ↧ r)  ≡⟨ reorder₂ (↥ p) _ _ (↧ r) ⟩
-    (↥ p ℤ.* ↥ r) ℤ.* (↧ q ℤ.* ↧ r)  ≤⟨ x≤y ⟩
-    (↥ q ℤ.* ↥ r) ℤ.* (↧ p ℤ.* ↧ r)  ≡⟨ reorder₂ (↥ q) _ _ (↧ r) ⟩
-    (↥ q ℤ.* ↧ p) ℤ.* (↥ r ℤ.* ↧ r)  ∎ where open ℤ.≤-Reasoning
-
-*-cancelˡ-≤-pos : ∀ r .{{_ : Positive r}} → r * p ≤ r * q → p ≤ q
-*-cancelˡ-≤-pos {p} {q} r rewrite *-comm-≡ r p | *-comm-≡ r q = *-cancelʳ-≤-pos r
-
-*-cancelʳ-≤-neg : ∀ r .{{_ : Negative r}} → p * r ≤ q * r → q ≤ p
-*-cancelʳ-≤-neg {p} {q} r@(mkℚᵘ -[1+ _ ] _) pr≤qr = neg-cancel-≤ (*-cancelʳ-≤-pos (- r) (begin
-  - p * - r    ≃˘⟨ neg-distribˡ-* p (- r) ⟩
-  - (p * - r)  ≃˘⟨ -‿cong (neg-distribʳ-* p r) ⟩
-  - - (p * r)  ≃⟨ neg-involutive (p * r) ⟩
-  p * r        ≤⟨ pr≤qr ⟩
-  q * r        ≃˘⟨ neg-involutive (q * r) ⟩
-  - - (q * r)  ≃⟨ -‿cong (neg-distribʳ-* q r) ⟩
-  - (q * - r)  ≃⟨ neg-distribˡ-* q (- r) ⟩
-  - q * - r    ∎))
-  where open ≤-Reasoning
-
-*-cancelˡ-≤-neg : ∀ r .{{_ : Negative r}} → r * p ≤ r * q → q ≤ p
-*-cancelˡ-≤-neg {p} {q} r rewrite *-comm-≡ r p | *-comm-≡ r q = *-cancelʳ-≤-neg r
-
-*-monoˡ-≤-nonNeg : ∀ r .{{_ : NonNegative r}} → (_* r) Preserves _≤_ ⟶ _≤_
-*-monoˡ-≤-nonNeg r@(mkℚᵘ (ℤ.+ n) _) {p@record{}} {q@record{}} (*≤* x<y) = *≤* $ begin
-  ↥ p ℤ.* ↥ r ℤ.* (↧ q   ℤ.* ↧ r)  ≡⟨  reorder₂ (↥ p) _ _ _ ⟩
-  l₁          ℤ.* (ℤ.+ n ℤ.* ↧ r)  ≡˘⟨  cong (l₁ ℤ.*_) (ℤ.pos-* n _) ⟩
-  l₁          ℤ.* ℤ.+ (n ℕ.* ↧ₙ r) ≤⟨  ℤ.*-monoʳ-≤-nonNeg (ℤ.+ (n ℕ.* ↧ₙ r)) x<y ⟩
-  l₂          ℤ.* ℤ.+ (n ℕ.* ↧ₙ r) ≡⟨ cong (l₂ ℤ.*_) (ℤ.pos-* n _) ⟩
-  l₂          ℤ.* (ℤ.+ n ℤ.* ↧ r)  ≡⟨  reorder₂ (↥ q) _ _ _ ⟩
-  ↥ q ℤ.* ↥ r ℤ.* (↧ p   ℤ.* ↧ r)  ∎
-  where open ℤ.≤-Reasoning; l₁ = ↥ p ℤ.* ↧ q ; l₂ = ↥ q ℤ.* ↧ p
-
-*-monoʳ-≤-nonNeg : ∀ r .{{_ :  NonNegative r}} → (r *_) Preserves _≤_ ⟶ _≤_
-*-monoʳ-≤-nonNeg r {p} {q} rewrite *-comm-≡ r p | *-comm-≡ r q = *-monoˡ-≤-nonNeg r
-
-*-mono-≤-nonNeg : ∀ {p q r s} .{{_ : NonNegative p}} .{{_ : NonNegative r}} →
-                  p ≤ q → r ≤ s → p * r ≤ q * s
-*-mono-≤-nonNeg {p} {q} {r} {s} p≤q r≤s = begin
-  p * r ≤⟨ *-monoˡ-≤-nonNeg r p≤q ⟩
-  q * r ≤⟨ *-monoʳ-≤-nonNeg q {{nonNeg≤⇒nonNeg p≤q}} r≤s ⟩
-  q * s ∎
-  where open ≤-Reasoning
-
-*-monoˡ-≤-nonPos : ∀ r .{{_ : NonPositive r}} → (_* r) Preserves _≤_ ⟶ _≥_
-*-monoˡ-≤-nonPos r {p} {q} p≤q = begin
-  q * r        ≃˘⟨ neg-involutive (q * r) ⟩
-  - - (q * r)  ≃⟨  -‿cong (neg-distribʳ-* q r) ⟩
-  - (q * - r)  ≤⟨  neg-mono-≤ (*-monoˡ-≤-nonNeg (- r) {{ -r≥0}} p≤q) ⟩
-  - (p * - r)  ≃˘⟨ -‿cong (neg-distribʳ-* p r) ⟩
-  - - (p * r)  ≃⟨  neg-involutive (p * r) ⟩
-  p * r        ∎
-  where open ≤-Reasoning; -r≥0 = nonNegative (neg-mono-≤ (nonPositive⁻¹ r))
-
-*-monoʳ-≤-nonPos : ∀ r .{{_ :  NonPositive r}} → (r *_) Preserves _≤_ ⟶ _≥_
-*-monoʳ-≤-nonPos r {p} {q} rewrite *-comm-≡ r q | *-comm-≡ r p = *-monoˡ-≤-nonPos r
-
-------------------------------------------------------------------------
--- Properties of _*_ and _<_
-
-*-monoˡ-<-pos : ∀ r .{{_ : Positive r}} → (_* r) Preserves _<_ ⟶ _<_
-*-monoˡ-<-pos r@record{} {p@record{}} {q@record{}} (*<* x<y) = *<* $ begin-strict
-  ↥ p ℤ.*  ↥ r ℤ.* (↧ q  ℤ.* ↧ r) ≡⟨ reorder₁ (↥ p) _ _ _ ⟩
-  ↥ p ℤ.*  ↧ q ℤ.*  ↥ r  ℤ.* ↧ r  <⟨ ℤ.*-monoʳ-<-pos (↧ r) (ℤ.*-monoʳ-<-pos (↥ r) x<y) ⟩
-  ↥ q ℤ.*  ↧ p ℤ.*  ↥ r  ℤ.* ↧ r  ≡˘⟨ reorder₁ (↥ q) _ _ _ ⟩
-  ↥ q ℤ.*  ↥ r ℤ.* (↧ p  ℤ.* ↧ r) ∎ where open ℤ.≤-Reasoning
-
-*-monoʳ-<-pos : ∀ r .{{_ : Positive r}} → (r *_) Preserves _<_ ⟶ _<_
-*-monoʳ-<-pos r {p} {q} rewrite *-comm-≡ r p | *-comm-≡ r q = *-monoˡ-<-pos r
-
-*-mono-<-nonNeg : ∀ {p q r s} .{{_ : NonNegative p}} .{{_ : NonNegative r}} →
-                  p < q → r < s → p * r < q * s
-*-mono-<-nonNeg {p} {q} {r} {s} p<q r<s = begin-strict
-  p * r ≤⟨ *-monoˡ-≤-nonNeg r (<⇒≤ p<q) ⟩
-  q * r <⟨ *-monoʳ-<-pos q {{nonNeg<⇒pos p<q}} r<s ⟩
-  q * s ∎
-  where open ≤-Reasoning
-
-*-cancelʳ-<-nonNeg : ∀ r .{{_ : NonNegative r}} → p * r < q * r → p < q
-*-cancelʳ-<-nonNeg {p@record{}} {q@record{}} r@(mkℚᵘ (ℤ.+ _) _) (*<* x<y) =
-  *<* $ ℤ.*-cancelʳ-<-nonNeg (↥ r ℤ.* ↧ r) {{+▹-nonNeg _}} $ begin-strict
-    (↥ p ℤ.* ↧ q) ℤ.* (↥ r ℤ.* ↧ r)  ≡⟨ reorder₂ (↥ p) _ _ (↧ r) ⟩
-    (↥ p ℤ.* ↥ r) ℤ.* (↧ q ℤ.* ↧ r)  <⟨ x<y ⟩
-    (↥ q ℤ.* ↥ r) ℤ.* (↧ p ℤ.* ↧ r)  ≡⟨ reorder₂ (↥ q) _ _ (↧ r) ⟩
-    (↥ q ℤ.* ↧ p) ℤ.* (↥ r ℤ.* ↧ r)  ∎ where open ℤ.≤-Reasoning
-
-*-cancelˡ-<-nonNeg : ∀ r .{{_ : NonNegative r}} → r * p < r * q → p < q
-*-cancelˡ-<-nonNeg {p} {q} r rewrite *-comm-≡ r p | *-comm-≡ r q = *-cancelʳ-<-nonNeg r
-
-*-monoˡ-<-neg : ∀ r .{{_ :  Negative r}} → (_* r) Preserves _<_ ⟶ _>_
-*-monoˡ-<-neg r {p} {q} p<q = begin-strict
-  q * r        ≃˘⟨ neg-involutive (q * r) ⟩
-  - - (q * r)  ≃⟨ -‿cong (neg-distribʳ-* q r) ⟩
-  - (q * - r)  <⟨ neg-mono-< (*-monoˡ-<-pos (- r) {{ -r>0}} p<q) ⟩
-  - (p * - r)  ≃˘⟨ -‿cong (neg-distribʳ-* p r) ⟩
-  - - (p * r)  ≃⟨ neg-involutive (p * r) ⟩
-  p * r        ∎
-  where open ≤-Reasoning; -r>0 = positive (neg-mono-< (negative⁻¹ r))
-
-*-monoʳ-<-neg : ∀ r .{{_ : Negative r}} → (r *_) Preserves _<_ ⟶ _>_
-*-monoʳ-<-neg r {p} {q} rewrite *-comm-≡ r q | *-comm-≡ r p = *-monoˡ-<-neg r
-
-*-cancelˡ-<-nonPos : ∀ r .{{_ : NonPositive r}} → r * p < r * q → q < p
-*-cancelˡ-<-nonPos {p} {q} r rp<rq =
-  *-cancelˡ-<-nonNeg (- r) {{ -r≥0}} $ begin-strict
-    - r * q    ≃˘⟨ neg-distribˡ-* r q ⟩
-    - (r * q)  <⟨ neg-mono-< rp<rq ⟩
-    - (r * p)  ≃⟨ neg-distribˡ-* r p ⟩
-    - r * p    ∎
-  where open ≤-Reasoning; -r≥0 = nonNegative (neg-mono-≤ (nonPositive⁻¹ r))
-
-*-cancelʳ-<-nonPos : ∀ r .{{_ : NonPositive r}} → p * r < q * r → q < p
-*-cancelʳ-<-nonPos {p} {q} r rewrite *-comm-≡ p r | *-comm-≡ q r = *-cancelˡ-<-nonPos r
-
------------------------------------------------------------------------
--- Properties of _*_ and predicates
-
-pos*pos⇒pos : ∀ p .{{_ : Positive p}} →
-              ∀ q .{{_ : Positive q}} →
-              Positive (p * q)
-pos*pos⇒pos p q = positive
-  (*-mono-<-nonNeg (positive⁻¹ p) (positive⁻¹ q))
-
-nonNeg*nonNeg⇒nonNeg : ∀ p .{{_ : NonNegative p}} →
-                       ∀ q .{{_ : NonNegative q}} →
-                       NonNegative (p * q)
-nonNeg*nonNeg⇒nonNeg p q = nonNegative
-  (*-mono-≤-nonNeg (nonNegative⁻¹ p) (nonNegative⁻¹ q))
-
-------------------------------------------------------------------------
--- 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
-  ; *-cong           = *-cong
-  ; *-assoc          = *-assoc
-  ; *-identity       = *-identity
-  ; 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
-  }
-
-------------------------------------------------------------------------
--- Properties of 1/_
-------------------------------------------------------------------------
-
-private
-  p>1⇒p≢0 : p > 1ℚᵘ → NonZero p
-  p>1⇒p≢0 {p} p>1 = pos⇒nonZero p {{positive (<-trans (*<* (ℤ.+<+ ℕ.≤-refl)) p>1)}}
-
-1/nonZero⇒nonZero : ∀ p .{{_ : NonZero p}} → NonZero (1/ p)
-1/nonZero⇒nonZero (mkℚᵘ (+[1+ _ ]) _) = _
-1/nonZero⇒nonZero (mkℚᵘ (-[1+ _ ]) _) = _
-
-1/-involutive-≡ : ∀ p .{{_ : NonZero p}} →
-                  (1/ (1/ p)) {{1/nonZero⇒nonZero p}} ≡ p
-1/-involutive-≡ (mkℚᵘ +[1+ n ] d-1) = refl
-1/-involutive-≡ (mkℚᵘ -[1+ n ] d-1) = refl
-
-1/-involutive : ∀ p .{{_ : NonZero p}} →
-                (1/ (1/ p)) {{1/nonZero⇒nonZero p}} ≃ p
-1/-involutive p = ≃-reflexive (1/-involutive-≡ p)
-
-1/pos⇒pos : ∀ p .{{p>0 : Positive p}} → Positive ((1/ p) {{pos⇒nonZero p}})
-1/pos⇒pos (mkℚᵘ +[1+ n ] d-1) = _
-
-1/neg⇒neg : ∀ p .{{p<0 : Negative p}} → Negative ((1/ p) {{neg⇒nonZero p}})
-1/neg⇒neg (mkℚᵘ -[1+ n ] d-1) = _
-
-p>1⇒1/p<1 : ∀ {p} → (p>1 : p > 1ℚᵘ) → (1/ p) {{p>1⇒p≢0 p>1}} < 1ℚᵘ
-p>1⇒1/p<1 {p} p>1 = lemma′ p (p>1⇒p≢0 p>1) p>1
-  where
-  lemma′ : ∀ p p≢0 → p > 1ℚᵘ → (1/ p) {{p≢0}} < 1ℚᵘ
-  lemma′ (mkℚᵘ n@(+[1+ _ ]) d-1) _ (*<* ↥p1>1↧p) = *<* (begin-strict
-    ↥ (1/ mkℚᵘ n d-1) ℤ.* 1ℤ         ≡⟨⟩
-    +[1+ d-1 ] ℤ.* 1ℤ                ≡⟨ ℤ.*-comm +[1+ d-1 ] 1ℤ ⟩
-    1ℤ ℤ.* +[1+ d-1 ]                <⟨ ↥p1>1↧p ⟩
-    n  ℤ.* 1ℤ                        ≡⟨ ℤ.*-comm n 1ℤ ⟩
-    1ℤ ℤ.* n                         ≡⟨⟩
-    (↥ 1ℚᵘ) ℤ.* (↧ (1/ mkℚᵘ n d-1))  ∎)
-    where open ℤ.≤-Reasoning
-
-1/-antimono-≤-pos : ∀ {p q} .{{_ : Positive p}} .{{_ : Positive q}} →
-                    p ≤ q → (1/ q) {{pos⇒nonZero q}} ≤ (1/ p) {{pos⇒nonZero p}}
-1/-antimono-≤-pos {p} {q} p≤q = begin
-  1/q              ≃˘⟨ *-identityˡ 1/q ⟩
-  1ℚᵘ * 1/q        ≃˘⟨ *-congʳ (*-inverseˡ p) ⟩
-  (1/p * p) * 1/q  ≤⟨  *-monoˡ-≤-nonNeg 1/q (*-monoʳ-≤-nonNeg 1/p p≤q) ⟩
-  (1/p * q) * 1/q  ≃⟨  *-assoc 1/p q 1/q ⟩
-  1/p * (q * 1/q)  ≃⟨  *-congˡ {1/p} (*-inverseʳ q) ⟩
-  1/p * 1ℚᵘ        ≃⟨  *-identityʳ (1/p) ⟩
-  1/p              ∎
-  where
-  open ≤-Reasoning
-  instance
-    _ = pos⇒nonZero p
-    _ = pos⇒nonZero q
-  1/p = 1/ p
-  1/q = 1/ q
-  instance
-    1/p≥0 : NonNegative 1/p
-    1/p≥0 = pos⇒nonNeg 1/p {{1/pos⇒pos p}}
-
-    1/q≥0 : NonNegative 1/q
-    1/q≥0 = pos⇒nonNeg 1/q {{1/pos⇒pos q}}
-
-------------------------------------------------------------------------
--- Properties of _⊓_ and _⊔_
-------------------------------------------------------------------------
--- Basic specification in terms of _≤_
-
-p≤q⇒p⊔q≃q : p ≤ q → p ⊔ q ≃ q
-p≤q⇒p⊔q≃q {p@record{}} {q@record{}} p≤q with p ≤ᵇ q | inspect (p ≤ᵇ_) q
-... | true  | _       = ≃-refl
-... | false | [ p≰q ] = contradiction (≤⇒≤ᵇ p≤q) (subst (¬_ ∘ T) (sym p≰q) λ())
-
-p≥q⇒p⊔q≃p : p ≥ q → p ⊔ q ≃ p
-p≥q⇒p⊔q≃p {p@record{}} {q@record{}} p≥q with p ≤ᵇ q | inspect (p ≤ᵇ_) q
-... | true  | [ p≤q ] = ≤-antisym p≥q (≤ᵇ⇒≤ (subst T (sym p≤q) _))
-... | false | [ p≤q ] = ≃-refl
-
-p≤q⇒p⊓q≃p : p ≤ q → p ⊓ q ≃ p
-p≤q⇒p⊓q≃p {p@record{}} {q@record{}} p≤q with p ≤ᵇ q | inspect (p ≤ᵇ_) q
-... | true  | _       = ≃-refl
-... | false | [ p≰q ] = contradiction (≤⇒≤ᵇ p≤q) (subst (¬_ ∘ T) (sym p≰q) λ())
-
-p≥q⇒p⊓q≃q : p ≥ q → p ⊓ q ≃ q
-p≥q⇒p⊓q≃q {p@record{}} {q@record{}} p≥q with p ≤ᵇ q | inspect (p ≤ᵇ_) q
-... | true  | [ p≤q ] = ≤-antisym (≤ᵇ⇒≤ (subst T (sym p≤q) _)) p≥q
-... | false | [ p≤q ] = ≃-refl
-
-⊓-operator : MinOperator ≤-totalPreorder
-⊓-operator = record
-  { x≤y⇒x⊓y≈x = p≤q⇒p⊓q≃p
-  ; x≥y⇒x⊓y≈y = p≥q⇒p⊓q≃q
-  }
-
-⊔-operator : MaxOperator ≤-totalPreorder
-⊔-operator = record
-  { x≤y⇒x⊔y≈y = p≤q⇒p⊔q≃q
-  ; x≥y⇒x⊔y≈x = p≥q⇒p⊔q≃p
-  }
-
-------------------------------------------------------------------------
--- Derived properties of _⊓_ and _⊔_
-
-private
-  module ⊓-⊔-properties        = MinMaxOp        ⊓-operator ⊔-operator
-  module ⊓-⊔-latticeProperties = LatticeMinMaxOp ⊓-operator ⊔-operator
-
-open ⊓-⊔-properties public
-  using
-  ( ⊓-congˡ                   -- : LeftCongruent _≃_ _⊓_
-  ; ⊓-congʳ                   -- : RightCongruent _≃_ _⊓_
-  ; ⊓-cong                    -- : Congruent₂ _≃_ _⊓_
-  ; ⊓-idem                    -- : Idempotent _≃_ _⊓_
-  ; ⊓-sel                     -- : Selective _≃_ _⊓_
-  ; ⊓-assoc                   -- : Associative _≃_ _⊓_
-  ; ⊓-comm                    -- : Commutative _≃_ _⊓_
-
-  ; ⊔-congˡ                   -- : LeftCongruent _≃_ _⊔_
-  ; ⊔-congʳ                   -- : RightCongruent _≃_ _⊔_
-  ; ⊔-cong                    -- : Congruent₂ _≃_ _⊔_
-  ; ⊔-idem                    -- : Idempotent _≃_ _⊔_
-  ; ⊔-sel                     -- : Selective _≃_ _⊔_
-  ; ⊔-assoc                   -- : Associative _≃_ _⊔_
-  ; ⊔-comm                    -- : Commutative _≃_ _⊔_
-
-  ; ⊓-distribˡ-⊔              -- : _DistributesOverˡ_ _≃_ _⊓_ _⊔_
-  ; ⊓-distribʳ-⊔              -- : _DistributesOverʳ_ _≃_ _⊓_ _⊔_
-  ; ⊓-distrib-⊔               -- : _DistributesOver_  _≃_ _⊓_ _⊔_
-  ; ⊔-distribˡ-⊓              -- : _DistributesOverˡ_ _≃_ _⊔_ _⊓_
-  ; ⊔-distribʳ-⊓              -- : _DistributesOverʳ_ _≃_ _⊔_ _⊓_
-  ; ⊔-distrib-⊓               -- : _DistributesOver_  _≃_ _⊔_ _⊓_
-  ; ⊓-absorbs-⊔               -- : _Absorbs_ _≃_ _⊓_ _⊔_
-  ; ⊔-absorbs-⊓               -- : _Absorbs_ _≃_ _⊔_ _⊓_
-  ; ⊔-⊓-absorptive            -- : Absorptive _≃_ _⊔_ _⊓_
-  ; ⊓-⊔-absorptive            -- : Absorptive _≃_ _⊓_ _⊔_
-
-  ; ⊓-isMagma                 -- : IsMagma _≃_ _⊓_
-  ; ⊓-isSemigroup             -- : IsSemigroup _≃_ _⊓_
-  ; ⊓-isCommutativeSemigroup  -- : IsCommutativeSemigroup _≃_ _⊓_
-  ; ⊓-isBand                  -- : IsBand _≃_ _⊓_
-  ; ⊓-isSelectiveMagma        -- : IsSelectiveMagma _≃_ _⊓_
-
-  ; ⊔-isMagma                 -- : IsMagma _≃_ _⊔_
-  ; ⊔-isSemigroup             -- : IsSemigroup _≃_ _⊔_
-  ; ⊔-isCommutativeSemigroup  -- : IsCommutativeSemigroup _≃_ _⊔_
-  ; ⊔-isBand                  -- : IsBand _≃_ _⊔_
-  ; ⊔-isSelectiveMagma        -- : IsSelectiveMagma _≃_ _⊔_
-
-  ; ⊓-magma                   -- : Magma _ _
-  ; ⊓-semigroup               -- : Semigroup _ _
-  ; ⊓-band                    -- : Band _ _
-  ; ⊓-commutativeSemigroup    -- : CommutativeSemigroup _ _
-  ; ⊓-selectiveMagma          -- : SelectiveMagma _ _
-
-  ; ⊔-magma                   -- : Magma _ _
-  ; ⊔-semigroup               -- : Semigroup _ _
-  ; ⊔-band                    -- : Band _ _
-  ; ⊔-commutativeSemigroup    -- : CommutativeSemigroup _ _
-  ; ⊔-selectiveMagma          -- : SelectiveMagma _ _
-
-  ; ⊓-triangulate             -- : ∀ p q r → p ⊓ q ⊓ r ≃ (p ⊓ q) ⊓ (q ⊓ r)
-  ; ⊔-triangulate             -- : ∀ p q r → p ⊔ q ⊔ r ≃ (p ⊔ q) ⊔ (q ⊔ r)
-
-  ; ⊓-glb                     -- : ∀ {p q r} → p ≥ r → q ≥ r → p ⊓ q ≥ r
-  ; ⊓-mono-≤                  -- : _⊓_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_
-  ; ⊓-monoˡ-≤                 -- : ∀ p → (_⊓ p) Preserves _≤_ ⟶ _≤_
-  ; ⊓-monoʳ-≤                 -- : ∀ p → (p ⊓_) Preserves _≤_ ⟶ _≤_
-
-  ; ⊔-lub                     -- : ∀ {p q r} → p ≤ r → q ≤ r → p ⊔ q ≤ r
-  ; ⊔-mono-≤                  -- : _⊔_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_
-  ; ⊔-monoˡ-≤                 -- : ∀ p → (_⊔ p) Preserves _≤_ ⟶ _≤_
-  ; ⊔-monoʳ-≤                 -- : ∀ p → (p ⊔_) Preserves _≤_ ⟶ _≤_
-  )
-  renaming
-  ( x⊓y≈y⇒y≤x  to p⊓q≃q⇒q≤p      -- : ∀ {p q} → p ⊓ q ≃ q → q ≤ p
-  ; x⊓y≈x⇒x≤y  to p⊓q≃p⇒p≤q      -- : ∀ {p q} → p ⊓ q ≃ p → p ≤ q
-  ; x⊔y≈y⇒x≤y  to p⊔q≃q⇒p≤q      -- : ∀ {p q} → p ⊔ q ≃ q → p ≤ q
-  ; x⊔y≈x⇒y≤x  to p⊔q≃p⇒q≤p      -- : ∀ {p q} → p ⊔ q ≃ p → q ≤ p
-
-  ; x⊓y≤x      to p⊓q≤p          -- : ∀ p q → p ⊓ q ≤ p
-  ; x⊓y≤y      to p⊓q≤q          -- : ∀ p q → p ⊓ q ≤ q
-  ; x≤y⇒x⊓z≤y  to p≤q⇒p⊓r≤q      -- : ∀ {p q} r → p ≤ q → p ⊓ r ≤ q
-  ; x≤y⇒z⊓x≤y  to p≤q⇒r⊓p≤q      -- : ∀ {p q} r → p ≤ q → r ⊓ p ≤ q
-  ; x≤y⊓z⇒x≤y  to p≤q⊓r⇒p≤q      -- : ∀ {p} q r → p ≤ q ⊓ r → p ≤ q
-  ; x≤y⊓z⇒x≤z  to p≤q⊓r⇒p≤r      -- : ∀ {p} q r → p ≤ q ⊓ r → p ≤ r
-
-  ; x≤x⊔y      to p≤p⊔q          -- : ∀ p q → p ≤ p ⊔ q
-  ; x≤y⊔x      to p≤q⊔p          -- : ∀ p q → p ≤ q ⊔ p
-  ; x≤y⇒x≤y⊔z  to p≤q⇒p≤q⊔r      -- : ∀ {p q} r → p ≤ q → p ≤ q ⊔ r
-  ; x≤y⇒x≤z⊔y  to p≤q⇒p≤r⊔q      -- : ∀ {p q} r → p ≤ q → p ≤ r ⊔ q
-  ; x⊔y≤z⇒x≤z  to p⊔q≤r⇒p≤r      -- : ∀ p q {r} → p ⊔ q ≤ r → p ≤ r
-  ; x⊔y≤z⇒y≤z  to p⊔q≤r⇒q≤r      -- : ∀ p q {r} → p ⊔ q ≤ r → q ≤ r
-
-  ; x⊓y≤x⊔y    to p⊓q≤p⊔q        -- : ∀ p q → p ⊓ q ≤ p ⊔ q
-  )
-
-open ⊓-⊔-latticeProperties public
-  using
-  ( ⊓-semilattice             -- : Semilattice _ _
-  ; ⊔-semilattice             -- : Semilattice _ _
-  ; ⊔-⊓-lattice               -- : Lattice _ _
-  ; ⊓-⊔-lattice               -- : Lattice _ _
-  ; ⊔-⊓-distributiveLattice   -- : DistributiveLattice _ _
-  ; ⊓-⊔-distributiveLattice   -- : DistributiveLattice _ _
-
-  ; ⊓-isSemilattice           -- : IsSemilattice _≃_ _⊓_
-  ; ⊔-isSemilattice           -- : IsSemilattice _≃_ _⊔_
-  ; ⊔-⊓-isLattice             -- : IsLattice _≃_ _⊔_ _⊓_
-  ; ⊓-⊔-isLattice             -- : IsLattice _≃_ _⊓_ _⊔_
-  ; ⊔-⊓-isDistributiveLattice -- : IsDistributiveLattice _≃_ _⊔_ _⊓_
-  ; ⊓-⊔-isDistributiveLattice -- : IsDistributiveLattice _≃_ _⊓_ _⊔_
-  )
-
-------------------------------------------------------------------------
--- Raw bundles
-
-⊓-rawMagma : RawMagma _ _
-⊓-rawMagma = Magma.rawMagma ⊓-magma
-
-⊔-rawMagma : RawMagma _ _
-⊔-rawMagma = Magma.rawMagma ⊔-magma
-
-⊔-⊓-rawLattice : RawLattice _ _
-⊔-⊓-rawLattice = Lattice.rawLattice ⊔-⊓-lattice
-
-------------------------------------------------------------------------
--- Monotonic or antimonotic functions distribute over _⊓_ and _⊔_
-
-mono-≤-distrib-⊔ : ∀ {f} → f Preserves _≤_ ⟶ _≤_ →
-                   ∀ m n → f (m ⊔ n) ≃ f m ⊔ f n
-mono-≤-distrib-⊔ pres = ⊓-⊔-properties.mono-≤-distrib-⊔ (mono⇒cong pres) pres
-
-mono-≤-distrib-⊓ : ∀ {f} → f Preserves _≤_ ⟶ _≤_ →
-                   ∀ m n → f (m ⊓ n) ≃ f m ⊓ f n
-mono-≤-distrib-⊓ pres = ⊓-⊔-properties.mono-≤-distrib-⊓ (mono⇒cong pres) pres
-
-antimono-≤-distrib-⊓ : ∀ {f} → f Preserves _≤_ ⟶ _≥_ →
-                       ∀ m n → f (m ⊓ n) ≃ f m ⊔ f n
-antimono-≤-distrib-⊓ pres = ⊓-⊔-properties.antimono-≤-distrib-⊓ (antimono⇒cong pres) pres
-
-antimono-≤-distrib-⊔ : ∀ {f} → f Preserves _≤_ ⟶ _≥_ →
-                       ∀ m n → f (m ⊔ n) ≃ f m ⊓ f n
-antimono-≤-distrib-⊔ pres = ⊓-⊔-properties.antimono-≤-distrib-⊔ (antimono⇒cong pres) pres
-
-------------------------------------------------------------------------
--- Properties of _⊓_, _⊔_ and -_
-
-neg-distrib-⊔-⊓ : ∀ p q → - (p ⊔ q) ≃ - p ⊓ - q
-neg-distrib-⊔-⊓ = antimono-≤-distrib-⊔ neg-mono-≤
-
-neg-distrib-⊓-⊔ : ∀ p q → - (p ⊓ q) ≃ - p ⊔ - q
-neg-distrib-⊓-⊔ = antimono-≤-distrib-⊓ neg-mono-≤
-
-------------------------------------------------------------------------
--- Properties of _⊓_, _⊔_ and _*_
-
-*-distribˡ-⊓-nonNeg : ∀ p .{{_ : NonNegative p}} → ∀ q r → p * (q ⊓ r) ≃ (p * q) ⊓ (p * r)
-*-distribˡ-⊓-nonNeg p = mono-≤-distrib-⊓ (*-monoʳ-≤-nonNeg p)
-
-*-distribʳ-⊓-nonNeg : ∀ p .{{_ : NonNegative p}} → ∀ q r → (q ⊓ r) * p ≃ (q * p) ⊓ (r * p)
-*-distribʳ-⊓-nonNeg p = mono-≤-distrib-⊓ (*-monoˡ-≤-nonNeg p)
-
-*-distribˡ-⊔-nonNeg : ∀ p .{{_ : NonNegative p}} → ∀ q r → p * (q ⊔ r) ≃ (p * q) ⊔ (p * r)
-*-distribˡ-⊔-nonNeg p = mono-≤-distrib-⊔ (*-monoʳ-≤-nonNeg p)
-
-*-distribʳ-⊔-nonNeg : ∀ p .{{_ : NonNegative p}} → ∀ q r → (q ⊔ r) * p ≃ (q * p) ⊔ (r * p)
-*-distribʳ-⊔-nonNeg p = mono-≤-distrib-⊔ (*-monoˡ-≤-nonNeg p)
-
-------------------------------------------------------------------------
--- Properties of _⊓_, _⊔_ and _*_
-
-*-distribˡ-⊔-nonPos : ∀ p .{{_ : NonPositive p}} → ∀ q r → p * (q ⊔ r) ≃ (p * q) ⊓ (p * r)
-*-distribˡ-⊔-nonPos p = antimono-≤-distrib-⊔ (*-monoʳ-≤-nonPos p)
-
-*-distribʳ-⊔-nonPos : ∀ p .{{_ : NonPositive p}} → ∀ q r → (q ⊔ r) * p ≃ (q * p) ⊓ (r * p)
-*-distribʳ-⊔-nonPos p = antimono-≤-distrib-⊔ (*-monoˡ-≤-nonPos p)
-
-*-distribˡ-⊓-nonPos : ∀ p .{{_ : NonPositive p}} → ∀ q r → p * (q ⊓ r) ≃ (p * q) ⊔ (p * r)
-*-distribˡ-⊓-nonPos p = antimono-≤-distrib-⊓ (*-monoʳ-≤-nonPos p)
-
-*-distribʳ-⊓-nonPos : ∀ p .{{_ : NonPositive p}} → ∀ q r → (q ⊓ r) * p ≃ (q * p) ⊔ (r * p)
-*-distribʳ-⊓-nonPos p = antimono-≤-distrib-⊓ (*-monoˡ-≤-nonPos p)
-
-------------------------------------------------------------------------
--- Properties of _⊓_, _⊔_ and _<_
-
-⊓-mono-< : _⊓_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_
-⊓-mono-< {p} {r} {q} {s} p<r q<s with ⊓-sel r s
-... | inj₁ r⊓s≃r = <-respʳ-≃ (≃-sym r⊓s≃r) (≤-<-trans (p⊓q≤p p q) p<r)
-... | inj₂ r⊓s≃s = <-respʳ-≃ (≃-sym r⊓s≃s) (≤-<-trans (p⊓q≤q p q) q<s)
-
-⊔-mono-< : _⊔_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_
-⊔-mono-< {p} {r} {q} {s} p<r q<s with ⊔-sel p q
-... | inj₁ p⊔q≃p = <-respˡ-≃ (≃-sym p⊔q≃p) (<-≤-trans p<r (p≤p⊔q r s))
-... | inj₂ p⊔q≃q = <-respˡ-≃ (≃-sym p⊔q≃q) (<-≤-trans q<s (p≤q⊔p r s))
-
-------------------------------------------------------------------------
--- Properties of _⊓_, _⊔_ and predicates
-
-pos⊓pos⇒pos : ∀ p .{{_ : Positive p}} →
-              ∀ q .{{_ : Positive q}} →
-              Positive (p ⊓ q)
-pos⊓pos⇒pos p q = positive (⊓-mono-< (positive⁻¹ p) (positive⁻¹ q))
-
-pos⊔pos⇒pos : ∀ p .{{_ : Positive p}} →
-              ∀ q .{{_ : Positive q}} →
-              Positive (p ⊔ q)
-pos⊔pos⇒pos p q = positive (⊔-mono-< (positive⁻¹ p) (positive⁻¹ q))
-
-------------------------------------------------------------------------
--- Properties of ∣_∣
-------------------------------------------------------------------------
-
-∣-∣-cong : p ≃ q → ∣ p ∣ ≃ ∣ q ∣
-∣-∣-cong p@{mkℚᵘ +[1+ _ ] _} q@{mkℚᵘ +[1+ _ ] _} (*≡* ↥p↧q≡↥q↧p) = *≡* ↥p↧q≡↥q↧p
-∣-∣-cong p@{mkℚᵘ +0       _} q@{mkℚᵘ +0       _} (*≡* ↥p↧q≡↥q↧p) = *≡* ↥p↧q≡↥q↧p
-∣-∣-cong p@{mkℚᵘ -[1+ _ ] _} q@{mkℚᵘ +0       _} (*≡* ())
-∣-∣-cong p@{mkℚᵘ -[1+ _ ] _} q@{mkℚᵘ -[1+ _ ] _} (*≡* ↥p↧q≡↥q↧p) = *≡* (begin
-  ↥ ∣ p ∣ ℤ.* ↧ q            ≡⟨ ℤ.neg-involutive _ ⟩
-  ℤ.- ℤ.- (↥ ∣ p ∣ ℤ.* ↧ q)  ≡⟨ cong ℤ.-_ (ℤ.neg-distribˡ-* (↥ ∣ p ∣) (↧ q)) ⟩
-  ℤ.- (↥ p ℤ.* ↧ q)          ≡⟨ cong ℤ.-_ ↥p↧q≡↥q↧p ⟩
-  ℤ.- (↥ q ℤ.* ↧ p)          ≡⟨ cong ℤ.-_ (ℤ.neg-distribˡ-* (↥ ∣ q ∣) (↧ p)) ⟩
-  ℤ.- ℤ.- (↥ ∣ q ∣ ℤ.* ↧ p)  ≡˘⟨ ℤ.neg-involutive _ ⟩
-  ↥ ∣ q ∣ ℤ.* ↧ p            ∎)
-  where open ≡-Reasoning
-
-∣p∣≃0⇒p≃0 : ∣ p ∣ ≃ 0ℚᵘ → p ≃ 0ℚᵘ
-∣p∣≃0⇒p≃0 {mkℚᵘ (ℤ.+ n)  d-1} p≃0ℚ = p≃0ℚ
-∣p∣≃0⇒p≃0 {mkℚᵘ -[1+ n ] d-1} (*≡* ())
-
-0≤∣p∣ : ∀ p → 0ℚᵘ ≤ ∣ p ∣
-0≤∣p∣ (mkℚᵘ +0       _) = *≤* (ℤ.+≤+ ℕ.z≤n)
-0≤∣p∣ (mkℚᵘ +[1+ _ ] _) = *≤* (ℤ.+≤+ ℕ.z≤n)
-0≤∣p∣ (mkℚᵘ -[1+ _ ] _) = *≤* (ℤ.+≤+ ℕ.z≤n)
-
-∣-p∣≡∣p∣ : ∀ p → ∣ - p ∣ ≡ ∣ p ∣
-∣-p∣≡∣p∣ (mkℚᵘ +[1+ n ] d) = refl
-∣-p∣≡∣p∣ (mkℚᵘ +0       d) = refl
-∣-p∣≡∣p∣ (mkℚᵘ -[1+ n ] d) = refl
-
-∣-p∣≃∣p∣ : ∀ p → ∣ - p ∣ ≃ ∣ p ∣
-∣-p∣≃∣p∣ = ≃-reflexive ∘ ∣-p∣≡∣p∣
-
-0≤p⇒∣p∣≡p : 0ℚᵘ ≤ p → ∣ p ∣ ≡ p
-0≤p⇒∣p∣≡p {mkℚᵘ (ℤ.+ n)  d-1} 0≤p = refl
-0≤p⇒∣p∣≡p {mkℚᵘ -[1+ n ] d-1} 0≤p = contradiction 0≤p (<⇒≱ (*<* ℤ.-<+))
-
-0≤p⇒∣p∣≃p : 0ℚᵘ ≤ p → ∣ p ∣ ≃ p
-0≤p⇒∣p∣≃p {p} = ≃-reflexive ∘ 0≤p⇒∣p∣≡p {p}
-
-∣p∣≡p⇒0≤p : ∣ p ∣ ≡ p → 0ℚᵘ ≤ p
-∣p∣≡p⇒0≤p {mkℚᵘ (ℤ.+ n) d-1} ∣p∣≡p = *≤* (begin
-  0ℤ ℤ.* +[1+ d-1 ]  ≡⟨ ℤ.*-zeroˡ (ℤ.+ d-1) ⟩
-  0ℤ                 ≤⟨ ℤ.+≤+ ℕ.z≤n ⟩
-  ℤ.+ n              ≡˘⟨ ℤ.*-identityʳ (ℤ.+ n) ⟩
-  ℤ.+ n ℤ.* 1ℤ       ∎)
-  where open ℤ.≤-Reasoning
-
-∣p∣≡p∨∣p∣≡-p : ∀ p → (∣ p ∣ ≡ p) ⊎ (∣ p ∣ ≡ - p)
-∣p∣≡p∨∣p∣≡-p (mkℚᵘ (ℤ.+ n)    d-1) = inj₁ refl
-∣p∣≡p∨∣p∣≡-p (mkℚᵘ (-[1+ n ]) d-1) = inj₂ refl
-
-∣p∣≃p⇒0≤p : ∣ p ∣ ≃ p → 0ℚᵘ ≤ p
-∣p∣≃p⇒0≤p {p} ∣p∣≃p with ∣p∣≡p∨∣p∣≡-p p
-... | inj₁ ∣p∣≡p  = ∣p∣≡p⇒0≤p ∣p∣≡p
-... | inj₂ ∣p∣≡-p rewrite ∣p∣≡-p = ≤-reflexive (≃-sym (p≃-p⇒p≃0 p (≃-sym ∣p∣≃p)))
-
-∣p+q∣≤∣p∣+∣q∣ : ∀ p q → ∣ p + q ∣ ≤ ∣ p ∣ + ∣ q ∣
-∣p+q∣≤∣p∣+∣q∣ p@record{} q@record{} = *≤* (begin
-  ↥ ∣ p + q ∣ ℤ.* ↧ (∣ p ∣ + ∣ q ∣)                ≡⟨⟩
-  ↥ ∣ (↥p↧q ℤ.+ ↥q↧p) / ↧p↧q ∣ ℤ.* ℤ.+ ↧p↧q        ≡⟨⟩
-  ↥ (ℤ.+ ℤ.∣ ↥p↧q ℤ.+ ↥q↧p ∣ / ↧p↧q) ℤ.* ℤ.+ ↧p↧q  ≡⟨ cong (ℤ._* ℤ.+ ↧p↧q) (↥[n/d]≡n (ℤ.+ ℤ.∣ ↥p↧q ℤ.+ ↥q↧p ∣) ↧p↧q) ⟩
-  ℤ.+ ℤ.∣ ↥p↧q ℤ.+ ↥q↧p ∣ ℤ.* ℤ.+ ↧p↧q             ≤⟨ ℤ.*-monoʳ-≤-nonNeg (ℤ.+ ↧p↧q) (ℤ.+≤+ (ℤ.∣i+j∣≤∣i∣+∣j∣ ↥p↧q ↥q↧p)) ⟩
-  (ℤ.+ ℤ.∣ ↥p↧q ∣ ℤ.+ ℤ.+ ℤ.∣ ↥q↧p ∣) ℤ.* ℤ.+ ↧p↧q ≡˘⟨ cong₂ (λ h₁ h₂ → (h₁ ℤ.+ h₂) ℤ.* ℤ.+ ↧p↧q) ∣↥p∣↧q≡∣↥p↧q∣ ∣↥q∣↧p≡∣↥q↧p∣ ⟩
-  (∣↥p∣↧q ℤ.+ ∣↥q∣↧p) ℤ.* ℤ.+ ↧p↧q                 ≡⟨⟩
-  (↥∣p∣↧q ℤ.+ ↥∣q∣↧p) ℤ.* ℤ.+ ↧p↧q                 ≡⟨ cong (ℤ._* ℤ.+ ↧p↧q) (↥[n/d]≡n (↥∣p∣↧q ℤ.+ ↥∣q∣↧p) ↧p↧q) ⟩
-  ↥ ((↥∣p∣↧q ℤ.+ ↥∣q∣↧p) / ↧p↧q) ℤ.* ℤ.+ ↧p↧q      ≡⟨⟩
-  ↥ (∣ p ∣ + ∣ q ∣) ℤ.* ↧ ∣ p + q ∣ ∎)
-  where
-    open ℤ.≤-Reasoning
-    ↥p↧q = ↥ p ℤ.* ↧ q
-    ↥q↧p = ↥ q ℤ.* ↧ p
-    ↥∣p∣↧q = ↥ ∣ p ∣ ℤ.* ↧ q
-    ↥∣q∣↧p = ↥ ∣ q ∣ ℤ.* ↧ p
-    ∣↥p∣↧q = ℤ.+ ℤ.∣ ↥ p ∣ ℤ.* ↧ q
-    ∣↥q∣↧p = ℤ.+ ℤ.∣ ↥ q ∣ ℤ.* ↧ p
-    ↧p↧q = ↧ₙ p ℕ.* ↧ₙ q
-    ∣m∣n≡∣mn∣ : ∀ m n → ℤ.+ ℤ.∣ m ∣ ℤ.* ℤ.+ n ≡ ℤ.+ ℤ.∣ m ℤ.* ℤ.+ n ∣
-    ∣m∣n≡∣mn∣ m n = begin-equality
-      ℤ.+ ℤ.∣ m ∣ ℤ.* ℤ.+ n                        ≡⟨⟩
-      ℤ.+ ℤ.∣ m ∣ ℤ.* ℤ.+ ℤ.∣ ℤ.+ n ∣              ≡˘⟨ ℤ.pos-* ℤ.∣ m ∣ ℤ.∣ ℤ.+ n ∣ ⟩
-      ℤ.+ (ℤ.∣ m ∣ ℕ.* n)                          ≡⟨⟩
-      ℤ.+ (ℤ.∣ m ∣ ℕ.* ℤ.∣ ℤ.+ n ∣)                ≡˘⟨ cong ℤ.+_ (ℤ.∣i*j∣≡∣i∣*∣j∣ m (ℤ.+ n)) ⟩
-      ℤ.+ (ℤ.∣ m ℤ.* ℤ.+ n ∣)                      ∎
-    ∣↥p∣↧q≡∣↥p↧q∣ : ∣↥p∣↧q ≡ ℤ.+ ℤ.∣ ↥p↧q ∣
-    ∣↥p∣↧q≡∣↥p↧q∣ = ∣m∣n≡∣mn∣ (↥ p) (↧ₙ q)
-    ∣↥q∣↧p≡∣↥q↧p∣ : ∣↥q∣↧p ≡ ℤ.+ ℤ.∣ ↥q↧p ∣
-    ∣↥q∣↧p≡∣↥q↧p∣ = ∣m∣n≡∣mn∣ (↥ q) (↧ₙ p)
-
-∣p-q∣≤∣p∣+∣q∣ : ∀ p q → ∣ p - q ∣ ≤ ∣ p ∣ + ∣ q ∣
-∣p-q∣≤∣p∣+∣q∣ p q = begin
-  ∣ p   -     q ∣  ≤⟨ ∣p+q∣≤∣p∣+∣q∣ p (- q) ⟩
-  ∣ p ∣ + ∣ - q ∣  ≡⟨ cong (∣ p ∣ +_) (∣-p∣≡∣p∣ q) ⟩
-  ∣ p ∣ + ∣   q ∣  ∎
-  where open ≤-Reasoning
-
-∣p*q∣≡∣p∣*∣q∣ : ∀ p q → ∣ p * q ∣ ≡ ∣ p ∣ * ∣ q ∣
-∣p*q∣≡∣p∣*∣q∣ p@record{} q@record{} = begin
-  ∣ p * q ∣                                           ≡⟨⟩
-  ∣ (↥ p ℤ.* ↥ q) / (↧ₙ p ℕ.* ↧ₙ q) ∣                 ≡⟨⟩
-  ℤ.+ ℤ.∣ ↥ p ℤ.* ↥ q ∣ / (↧ₙ p ℕ.* ↧ₙ q)             ≡⟨ cong (λ h → ℤ.+ h / ((↧ₙ p) ℕ.* (↧ₙ q))) (ℤ.∣i*j∣≡∣i∣*∣j∣ (↥ p) (↥ q)) ⟩
-  ℤ.+ (ℤ.∣ ↥ p ∣ ℕ.* ℤ.∣ ↥ q ∣) / (↧ₙ p ℕ.* ↧ₙ q)     ≡⟨ cong (_/ (↧ₙ p ℕ.* ↧ₙ q)) (ℤ.pos-* ℤ.∣ ↥ p ∣ ℤ.∣ ↥ q ∣) ⟩
-  (ℤ.+ ℤ.∣ ↥ p ∣ ℤ.* ℤ.+ ℤ.∣ ↥ q ∣) / (↧ₙ p ℕ.* ↧ₙ q) ≡⟨⟩
-  (ℤ.+ ℤ.∣ ↥ p ∣ / ↧ₙ p) * (ℤ.+ ℤ.∣ ↥ q ∣ / ↧ₙ q)     ≡⟨⟩
-  ∣ p ∣ * ∣ q ∣                                       ∎
-  where open ≡-Reasoning
-
-∣p*q∣≃∣p∣*∣q∣ : ∀ p q → ∣ p * q ∣ ≃ ∣ p ∣ * ∣ q ∣
-∣p*q∣≃∣p∣*∣q∣ p q = ≃-reflexive (∣p*q∣≡∣p∣*∣q∣ p q)
-
-∣∣p∣∣≡∣p∣ : ∀ p → ∣ ∣ p ∣ ∣ ≡ ∣ p ∣
-∣∣p∣∣≡∣p∣ p = 0≤p⇒∣p∣≡p (0≤∣p∣ p)
-
-∣∣p∣∣≃∣p∣ : ∀ p → ∣ ∣ p ∣ ∣ ≃ ∣ p ∣
-∣∣p∣∣≃∣p∣ p = ≃-reflexive (∣∣p∣∣≡∣p∣ p)
-
-∣-∣-nonNeg : ∀ p → NonNegative ∣ p ∣
-∣-∣-nonNeg (mkℚᵘ +[1+ _ ] _) = _
-∣-∣-nonNeg (mkℚᵘ +0       _) = _
-∣-∣-nonNeg (mkℚᵘ -[1+ _ ] _) = _
-
-
-------------------------------------------------------------------------
--- DEPRECATED NAMES
-------------------------------------------------------------------------
--- Please use the new names as continuing support for the old names is
--- not guaranteed.
-
--- Version 1.5
-
-neg-mono-<-> = neg-mono-<
-{-# WARNING_ON_USAGE neg-mono-<->
-"Warning: neg-mono-<-> was deprecated in v1.5.
++-assoc-↧ : Associative (_≡_ on ↧ₙ_) _+_
++-assoc-↧ p@record{} q@record{} r@record{} = ℕ.*-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@record{} q@record{} = ℤ.+-comm (↥ p ℤ.* ↧ q) (↥ q ℤ.* ↧ p)
+
++-comm-↧ : Commutative (_≡_ on ↧ₙ_) _+_
++-comm-↧ p@record{} q@record{} = ℕ.*-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@record{} = begin
+  0ℤ ℤ.* ↧ p ℤ.+ ↥ p ℤ.* 1ℤ ≡⟨ cong₂ ℤ._+_ (ℤ.*-zeroˡ (↧ p)) (ℤ.*-identityʳ (↥ p)) ⟩
+  0ℤ ℤ.+ ↥ p                ≡⟨ ℤ.+-identityˡ (↥ p) ⟩
+  ↥ p                       ∎ where open ≡-Reasoning
+
++-identityˡ-↧ : LeftIdentity (_≡_ on ↧ₙ_) 0ℚᵘ _+_
++-identityˡ-↧ p@record{} = ℕ.+-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@record{} = *≡* 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@record{} = *≡* 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ʳ
+
++-cancelˡ : ∀ {r p q} → r + p ≃ r + q → p ≃ q
++-cancelˡ {r} {p} {q} r+p≃r+q = begin-equality
+  p            ≃⟨ +-identityʳ p ⟨
+  p + 0ℚᵘ      ≃⟨ +-congʳ p (+-inverseʳ r) ⟨
+  p + (r - r)  ≃⟨ +-assoc p r (- r) ⟨
+  (p + r) - r  ≃⟨ +-congˡ (- r) (+-comm p r) ⟩
+  (r + p) - r  ≃⟨ +-congˡ (- r) r+p≃r+q ⟩
+  (r + q) - r  ≃⟨ +-congˡ (- r) (+-comm r q) ⟩
+  (q + r) - r  ≃⟨ +-assoc q r (- r) ⟩
+  q + (r - r)  ≃⟨ +-congʳ q (+-inverseʳ r) ⟩
+  q + 0ℚᵘ      ≃⟨ +-identityʳ q ⟩
+  q            ∎ where open ≤-Reasoning
+
++-cancelʳ : ∀ {r p q} → p + r ≃ q + r → p ≃ q
++-cancelʳ {r} {p} {q} p+r≃q+r = +-cancelˡ {r} $ begin-equality
+  r + p ≃⟨ +-comm r p ⟩
+  p + r ≃⟨ p+r≃q+r ⟩
+  q + r ≃⟨ +-comm q r ⟩
+  r + q ∎ where open ≤-Reasoning
+
+p+p≃0⇒p≃0 : ∀ p → p + p ≃ 0ℚᵘ → p ≃ 0ℚᵘ
+p+p≃0⇒p≃0 (mkℚᵘ ℤ.+0 _) (*≡* _) = *≡* refl
+
+------------------------------------------------------------------------
+-- Properties of _+_ and -_
+
+neg-distrib-+ : ∀ p q → - (p + q) ≡ (- p) + (- q)
+neg-distrib-+ p@record{} q@record{} = ↥↧≡⇒≡ (begin
+    ℤ.- (↥ p ℤ.* ↧ q ℤ.+ ↥ q ℤ.* ↧ p)       ≡⟨ ℤ.neg-distrib-+ (↥ p ℤ.* ↧ q) _ ⟩
+    ℤ.- (↥ p ℤ.* ↧ q) ℤ.+ ℤ.- (↥ q ℤ.* ↧ p) ≡⟨ cong₂ ℤ._+_ (ℤ.neg-distribˡ-* (↥ p) _)
+                                                           (ℤ.neg-distribˡ-* (↥ q) _) ⟩
+    (ℤ.- ↥ p) ℤ.* ↧ q ℤ.+ (ℤ.- ↥ q) ℤ.* ↧ p ∎
+  ) refl
+  where open ≡-Reasoning
+
+p≃-p⇒p≃0 : ∀ p → p ≃ - p → p ≃ 0ℚᵘ
+p≃-p⇒p≃0 p p≃-p = p+p≃0⇒p≃0 p (begin-equality
+  p + p  ≃⟨ +-congʳ p p≃-p ⟩
+  p - p  ≃⟨ +-inverseʳ p ⟩
+  0ℚᵘ    ∎)
+  where open ≤-Reasoning
+
+------------------------------------------------------------------------
+-- Properties of _+_ and _≤_
+
+private
+  lemma : ∀ r p q → (↥ r ℤ.* ↧ p ℤ.+ ↥ p ℤ.* ↧ r) ℤ.* (↧ r ℤ.* ↧ q)
+                    ≡ (↥ r ℤ.* ↧ r) ℤ.* (↧ p ℤ.* ↧ q) ℤ.+ (↧ r ℤ.* ↧ r) ℤ.* (↥ p ℤ.* ↧ q)
+  lemma r p q = solve 5 (λ ↥r ↧r ↧p ↥p ↧q →
+                          (↥r :* ↧p :+ ↥p :* ↧r) :* (↧r :* ↧q) :=
+                          (↥r :* ↧r) :* (↧p :* ↧q) :+ (↧r :* ↧r) :* (↥p :* ↧q))
+                      refl (↥ r) (↧ r) (↧ p) (↥ p) (↧ q)
+    where open ℤ-solver
+
++-monoʳ-≤ : ∀ r → (r +_) Preserves _≤_ ⟶ _≤_
++-monoʳ-≤ r@record{} {p@record{}} {q@record{}} (*≤* x≤y) = *≤* $ begin
+  ↥ (r + p) ℤ.* ↧ (r + q)                                  ≡⟨ lemma r p q ⟩
+  r₂ ℤ.* (↧ p ℤ.* ↧ q) ℤ.+ (↧ r ℤ.* ↧ r) ℤ.* (↥ p ℤ.* ↧ q) ≤⟨ leq ⟩
+  r₂ ℤ.* (↧ q ℤ.* ↧ p) ℤ.+ (↧ r ℤ.* ↧ r) ℤ.* (↥ q ℤ.* ↧ p) ≡⟨ sym $ lemma r q p ⟩
+  ↥ (r + q) ℤ.* (↧ (r + p))                                ∎
+  where
+  open ℤ.≤-Reasoning; r₂ = ↥ r ℤ.* ↧ r
+  leq = ℤ.+-mono-≤
+    (ℤ.≤-reflexive $ cong (r₂ ℤ.*_) (ℤ.*-comm (↧ p) (↧ q)))
+    (ℤ.*-monoˡ-≤-nonNeg (↧ r ℤ.* ↧ r) x≤y)
+
++-monoˡ-≤ : ∀ r → (_+ r) Preserves _≤_ ⟶ _≤_
++-monoˡ-≤ r {p} {q} rewrite +-comm-≡ p r | +-comm-≡ q r = +-monoʳ-≤ r
+
++-mono-≤ : _+_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_
++-mono-≤ {p} {q} {u} {v} p≤q u≤v = ≤-trans (+-monoˡ-≤ u p≤q) (+-monoʳ-≤ q u≤v)
+
+p≤q⇒p≤r+q : ∀ r .{{_ : NonNegative r}} → p ≤ q → p ≤ r + q
+p≤q⇒p≤r+q {p} {q} r p≤q = subst (_≤ r + q) (+-identityˡ-≡ p) (+-mono-≤ (nonNegative⁻¹ r) p≤q)
+
+p≤q+p : ∀ p q .{{_ : NonNegative q}} → p ≤ q + p
+p≤q+p p q = p≤q⇒p≤r+q q ≤-refl
+
+p≤p+q : ∀ p q .{{_ : NonNegative q}} → p ≤ p + q
+p≤p+q p q rewrite +-comm-≡ p q = p≤q+p p q
+
+------------------------------------------------------------------------
+-- Properties of _+_ and _<_
+
++-monoʳ-< : ∀ r → (r +_) Preserves _<_ ⟶ _<_
++-monoʳ-< r@record{} {p@record{}} {q@record{}} (*<* x<y) = *<* $ begin-strict
+  ↥ (r + p) ℤ.* (↧ (r + q))                          ≡⟨ lemma r p q ⟩
+  ↥r↧r ℤ.* (↧ p ℤ.* ↧ q) ℤ.+ ↧r↧r ℤ.* (↥ p ℤ.* ↧ q)  <⟨ leq ⟩
+  ↥r↧r ℤ.* (↧ q ℤ.* ↧ p) ℤ.+ ↧r↧r ℤ.* (↥ q ℤ.* ↧ p)  ≡⟨ sym $ lemma r q p ⟩
+  ↥ (r + q) ℤ.* (↧ (r + p))                          ∎
+  where
+  open ℤ.≤-Reasoning; ↥r↧r = ↥ r ℤ.* ↧ r; ↧r↧r = ↧ r ℤ.* ↧ r
+  leq = ℤ.+-mono-≤-<
+    (ℤ.≤-reflexive $ cong (↥r↧r ℤ.*_) (ℤ.*-comm (↧ p) (↧ q)))
+    (ℤ.*-monoˡ-<-pos ↧r↧r x<y)
+
++-monoˡ-< : ∀ r → (_+ r) Preserves _<_ ⟶ _<_
++-monoˡ-< r {p} {q} rewrite +-comm-≡ p r | +-comm-≡ q r = +-monoʳ-< r
+
++-mono-< : _+_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_
++-mono-< {p} {q} {u} {v} p<q u<v = <-trans (+-monoˡ-< u p<q) (+-monoʳ-< q u<v)
+
++-mono-≤-< : _+_ Preserves₂ _≤_ ⟶ _<_ ⟶ _<_
++-mono-≤-< {p} {q} {r} p≤q q<r = ≤-<-trans (+-monoˡ-≤ r p≤q) (+-monoʳ-< q q<r)
+
++-mono-<-≤ : _+_ Preserves₂ _<_ ⟶ _≤_ ⟶ _<_
++-mono-<-≤ {p} {q} {r} p<q q≤r = <-≤-trans (+-monoˡ-< r p<q) (+-monoʳ-≤ q q≤r)
+
+------------------------------------------------------------------------
+-- Properties of _+_ and predicates
+
+pos+pos⇒pos : ∀ p .{{_ : Positive p}} →
+              ∀ q .{{_ : Positive q}} →
+              Positive (p + q)
+pos+pos⇒pos p q = positive (+-mono-< (positive⁻¹ p) (positive⁻¹ q))
+
+nonNeg+nonNeg⇒nonNeg : ∀ p .{{_ : NonNegative p}} →
+                       ∀ q .{{_ : NonNegative q}} →
+                       NonNegative (p + q)
+nonNeg+nonNeg⇒nonNeg p q = nonNegative
+  (+-mono-≤ (nonNegative⁻¹ p) (nonNegative⁻¹ q))
+
+------------------------------------------------------------------------
+-- Properties of _-_
+
++-minus-telescope : ∀ p q r → (p - q) + (q - r) ≃ p - r
++-minus-telescope p q r = begin-equality
+  (p - q) + (q - r)   ≃⟨ ≃-sym (+-assoc (p - q) q (- r)) ⟩
+  (p - q) + q - r     ≃⟨ +-congˡ (- r) (+-assoc p (- q) q) ⟩
+  (p + (- q + q)) - r ≃⟨ +-congˡ (- r) (+-congʳ p (+-inverseˡ q)) ⟩
+  (p + 0ℚᵘ) - r       ≃⟨ +-congˡ (- r) (+-identityʳ p) ⟩
+  p - r               ∎ where open ≤-Reasoning
+
+p≃q⇒p-q≃0 : ∀ p q → p ≃ q → p - q ≃ 0ℚᵘ
+p≃q⇒p-q≃0 p q p≃q = begin-equality
+  p - q ≃⟨ +-congˡ (- q) p≃q ⟩
+  q - q ≃⟨ +-inverseʳ q ⟩
+  0ℚᵘ   ∎ where open ≤-Reasoning
+
+p-q≃0⇒p≃q : ∀ p q → p - q ≃ 0ℚᵘ → p ≃ q
+p-q≃0⇒p≃q p q p-q≃0 = begin-equality
+  p             ≡⟨ +-identityʳ-≡ p ⟨
+  p + 0ℚᵘ       ≃⟨ +-congʳ p (≃-sym (+-inverseˡ q)) ⟩
+  p + (- q + q) ≡⟨ +-assoc-≡ p (- q) q ⟨
+  (p - q) + q   ≃⟨ +-congˡ q p-q≃0 ⟩
+  0ℚᵘ + q       ≡⟨ +-identityˡ-≡ q ⟩
+  q             ∎ where open ≤-Reasoning
+
+neg-mono-≤ : -_ Preserves _≤_ ⟶ _≥_
+neg-mono-≤ {p@record{}} {q@record{}} (*≤* p≤q) = *≤* $ begin
+  ℤ.- ↥ q ℤ.* ↧ p   ≡⟨ ℤ.neg-distribˡ-* (↥ q) (↧ p) ⟨
+  ℤ.- (↥ q ℤ.* ↧ p) ≤⟨ ℤ.neg-mono-≤ p≤q ⟩
+  ℤ.- (↥ p ℤ.* ↧ q) ≡⟨ ℤ.neg-distribˡ-* (↥ p) (↧ q) ⟩
+  ℤ.- ↥ p ℤ.* ↧ q   ∎ where open ℤ.≤-Reasoning
+
+neg-cancel-≤ : ∀ {p q} → - p ≤ - q → q ≤ p
+neg-cancel-≤ {p@record{}} {q@record{}} (*≤* -↥p↧q≤-↥q↧p) = *≤* $ begin
+  ↥ q ℤ.* ↧ p             ≡⟨ ℤ.neg-involutive (↥ q ℤ.* ↧ p) ⟨
+  ℤ.- ℤ.- (↥ q ℤ.* ↧ p)   ≡⟨ cong ℤ.-_ (ℤ.neg-distribˡ-* (↥ q) (↧ p)) ⟩
+  ℤ.- ((ℤ.- ↥ q) ℤ.* ↧ p) ≤⟨ ℤ.neg-mono-≤ -↥p↧q≤-↥q↧p ⟩
+  ℤ.- ((ℤ.- ↥ p) ℤ.* ↧ q) ≡⟨ cong ℤ.-_ (ℤ.neg-distribˡ-* (↥ p) (↧ q)) ⟨
+  ℤ.- ℤ.- (↥ p ℤ.* ↧ q)   ≡⟨ ℤ.neg-involutive (↥ p ℤ.* ↧ q) ⟩
+  ↥ p ℤ.* ↧ q             ∎
+  where
+    open ℤ.≤-Reasoning
+
+p≤q⇒p-q≤0 : ∀ {p q} → p ≤ q → p - q ≤ 0ℚᵘ
+p≤q⇒p-q≤0 {p} {q} p≤q = begin
+  p - q ≤⟨ +-monoˡ-≤ (- q) p≤q ⟩
+  q - q ≃⟨ +-inverseʳ q ⟩
+  0ℚᵘ   ∎ where open ≤-Reasoning
+
+p-q≤0⇒p≤q : ∀ {p q} → p - q ≤ 0ℚᵘ → p ≤ q
+p-q≤0⇒p≤q {p} {q} p-q≤0 = begin
+  p             ≡⟨ +-identityʳ-≡ p ⟨
+  p + 0ℚᵘ       ≃⟨ +-congʳ p (≃-sym (+-inverseˡ q)) ⟩
+  p + (- q + q) ≡⟨ +-assoc-≡ p (- q) q ⟨
+  (p - q) + q   ≤⟨ +-monoˡ-≤ q p-q≤0 ⟩
+  0ℚᵘ + q       ≡⟨ +-identityˡ-≡ q ⟩
+  q             ∎ where open ≤-Reasoning
+
+p≤q⇒0≤q-p : ∀ {p q} → p ≤ q → 0ℚᵘ ≤ q - p
+p≤q⇒0≤q-p {p} {q} p≤q = begin
+  0ℚᵘ   ≃⟨ ≃-sym (+-inverseʳ p) ⟩
+  p - p ≤⟨ +-monoˡ-≤ (- p) p≤q ⟩
+  q - p ∎ where open ≤-Reasoning
+
+0≤q-p⇒p≤q : ∀ {p q} → 0ℚᵘ ≤ q - p → p ≤ q
+0≤q-p⇒p≤q {p} {q} 0≤p-q = begin
+  p             ≡⟨ +-identityˡ-≡ p ⟨
+  0ℚᵘ + p       ≤⟨ +-monoˡ-≤ p 0≤p-q ⟩
+  q - p + p     ≡⟨ +-assoc-≡ q (- p) p ⟩
+  q + (- p + p) ≃⟨ +-congʳ q (+-inverseˡ p) ⟩
+  q + 0ℚᵘ       ≡⟨ +-identityʳ-≡ q ⟩
+  q             ∎ 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 _*_
+------------------------------------------------------------------------
+
+------------------------------------------------------------------------
+-- Algebraic properties
+
+*-cong : Congruent₂ _≃_ _*_
+*-cong {x@record{}} {y@record{}} {u@record{}} {v@record{}} (*≡* ↥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
+
+*-congˡ : LeftCongruent _≃_ _*_
+*-congˡ {p} q≃r = *-cong (≃-refl {p}) q≃r
+
+*-congʳ : RightCongruent _≃_ _*_
+*-congʳ {p} q≃r = *-cong q≃r (≃-refl {p})
+
+-- Associativity
+
+*-assoc-↥ : Associative (_≡_ on ↥_) _*_
+*-assoc-↥ p@record{} q@record{} r@record{} = ℤ.*-assoc (↥ p) (↥ q) (↥ r)
+
+*-assoc-↧ : Associative (_≡_ on ↧ₙ_) _*_
+*-assoc-↧ p@record{} q@record{} r@record{} = ℕ.*-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@record{} q@record{} = ℤ.*-comm (↥ p) (↥ q)
+
+*-comm-↧ : Commutative (_≡_ on ↧ₙ_) _*_
+*-comm-↧ p@record{} q@record{} = ℕ.*-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@record{} = ↥↧≡⇒≡ (ℤ.*-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ʳ
+
+*-inverseˡ : ∀ p .{{_ : NonZero p}} → (1/ p) * p ≃ 1ℚᵘ
+*-inverseˡ p@(mkℚᵘ -[1+ n ] d) = *-inverseˡ (mkℚᵘ +[1+ n ] d)
+*-inverseˡ p@(mkℚᵘ +[1+ n ] d) = *≡* $ cong +[1+_] $ begin
+  (n ℕ.+ d ℕ.* suc n) ℕ.* 1 ≡⟨ ℕ.*-identityʳ _ ⟩
+  (n ℕ.+ d ℕ.* suc n)       ≡⟨ cong (n ℕ.+_) (ℕ.*-suc d n) ⟩
+  (n ℕ.+ (d ℕ.+ d ℕ.* n))   ≡⟨ solve 2 (λ n d → n :+ (d :+ d :* n) := d :+ (n :+ n :* d)) refl n d ⟩
+  (d ℕ.+ (n ℕ.+ n ℕ.* d))   ≡⟨ cong (d ℕ.+_) (sym (ℕ.*-suc n d)) ⟩
+  d ℕ.+ n ℕ.* suc d         ≡⟨ ℕ.+-identityʳ _ ⟨
+  d ℕ.+ n ℕ.* suc d ℕ.+ 0   ∎
+  where open ≡-Reasoning; open ℕ-solver
+
+*-inverseʳ : ∀ p .{{_ : NonZero p}} → p * 1/ p ≃ 1ℚᵘ
+*-inverseʳ p = ≃-trans (*-comm p (1/ p)) (*-inverseˡ p)
+
+≄⇒invertible : p ≄ q → Invertible _≃_ 1ℚᵘ _*_ (p - q)
+≄⇒invertible {p} {q} p≄q = _ , *-inverseˡ (p - q) , *-inverseʳ (p - q)
+  where instance
+  _ : NonZero (p - q)
+  _ = ≢-nonZero (p≄q ∘ p-q≃0⇒p≃q p q)
+
+*-zeroˡ : LeftZero _≃_ 0ℚᵘ _*_
+*-zeroˡ p@record{} = *≡* refl
+
+*-zeroʳ : RightZero _≃_ 0ℚᵘ _*_
+*-zeroʳ = Consequences.comm+zeˡ⇒zeʳ ≃-setoid *-comm *-zeroˡ
+
+*-zero : Zero _≃_ 0ℚᵘ _*_
+*-zero = *-zeroˡ , *-zeroʳ
+
+invertible⇒≄ : Invertible _≃_ 1ℚᵘ _*_ (p - q) → p ≄ q
+invertible⇒≄ {p} {q} (1/p-q , 1/x*x≃1 , x*1/x≃1) p≃q = 0≄1 (begin
+  0ℚᵘ             ≈⟨ *-zeroˡ 1/p-q ⟨
+  0ℚᵘ * 1/p-q     ≈⟨ *-congʳ (p≃q⇒p-q≃0 p q p≃q) ⟨
+  (p - q) * 1/p-q ≈⟨ x*1/x≃1 ⟩
+  1ℚᵘ             ∎)
+  where open ≃-Reasoning
+
+*-distribˡ-+ : _DistributesOverˡ_ _≃_ _*_ _+_
+*-distribˡ-+ p@record{} q@record{} r@record{} =
+  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ʳ-+ = Consequences.comm+distrˡ⇒distrʳ ≃-setoid +-cong *-comm *-distribˡ-+
+
+*-distrib-+ : _DistributesOver_ _≃_ _*_ _+_
+*-distrib-+ = *-distribˡ-+ , *-distribʳ-+
+
+------------------------------------------------------------------------
+-- Properties of _*_ and -_
+
+neg-distribˡ-* : ∀ p q → - (p * q) ≃ - p * q
+neg-distribˡ-* p@record{} q@record{} =
+  *≡* $ cong (ℤ._* (↧ p ℤ.* ↧ q)) $ ℤ.neg-distribˡ-* (↥ p) (↥ q)
+
+neg-distribʳ-* : ∀ p q → - (p * q) ≃ p * - q
+neg-distribʳ-* p@record{} q@record{} =
+  *≡* $ cong (ℤ._* (↧ p ℤ.* ↧ q)) $ ℤ.neg-distribʳ-* (↥ p) (↥ q)
+
+------------------------------------------------------------------------
+-- Properties of _*_ and _/_
+
+*-cancelˡ-/ : ∀ p {q r} .{{_ : ℕ.NonZero r}} .{{_ : ℕ.NonZero (p ℕ.* r)}} →
+              ((ℤ.+ p ℤ.* q) / (p ℕ.* r)) ≃ (q / r)
+*-cancelˡ-/ p {q} {r} = *≡* (begin-equality
+  (↥ ((ℤ.+ p ℤ.* q) / (p ℕ.* r))) ℤ.* (↧ (q / r)) ≡⟨  cong (ℤ._* ↧ (q / r)) (↥[n/d]≡n (ℤ.+ p ℤ.* q) (p ℕ.* r)) ⟩
+  (ℤ.+ p ℤ.* q) ℤ.* (↧ (q / r))                   ≡⟨  cong ((ℤ.+ p ℤ.* q) ℤ.*_) (↧[n/d]≡d q r) ⟩
+  (ℤ.+ p ℤ.* q) ℤ.* ℤ.+ r                         ≡⟨  xy∙z≈y∙xz (ℤ.+ p) q (ℤ.+ r) ⟩
+  (q ℤ.* (ℤ.+ p ℤ.* ℤ.+ r))                       ≡⟨ cong (ℤ._* (ℤ.+ p ℤ.* ℤ.+ r)) (↥[n/d]≡n q r) ⟨
+  (↥ (q / r)) ℤ.* (ℤ.+ p ℤ.* ℤ.+ r)               ≡⟨  cong (↥ (q / r) ℤ.*_) (ℤ.pos-* p r) ⟨
+  (↥ (q / r)) ℤ.* (ℤ.+ (p ℕ.* r))                 ≡⟨ cong (↥ (q / r) ℤ.*_) (↧[n/d]≡d (ℤ.+ p ℤ.* q) (p ℕ.* r)) ⟨
+  (↥ (q / r)) ℤ.* (↧ ((ℤ.+ p ℤ.* q) / (p ℕ.* r))) ∎)
+  where open ℤ.≤-Reasoning
+
+*-cancelʳ-/ : ∀ p {q r} .{{_ : ℕ.NonZero r}} .{{_ : ℕ.NonZero (r ℕ.* p)}} →
+              ((q ℤ.* ℤ.+ p) / (r ℕ.* p)) ≃ (q / r)
+*-cancelʳ-/ p {q} {r} rewrite ℕ.*-comm r p | ℤ.*-comm q (ℤ.+ p) = *-cancelˡ-/ p
+
+------------------------------------------------------------------------
+-- Properties of _*_ and _≤_
+
+private
+  reorder₁ : ∀ a b c d → a ℤ.* b ℤ.* (c ℤ.* d) ≡ a ℤ.* c ℤ.* b ℤ.* d
+  reorder₁ = solve 4 (λ a b c d → (a :* b) :* (c :* d) := (a :* c) :* b :* d) refl
+    where open ℤ-solver
+
+  reorder₂ : ∀ a b c d → a ℤ.* b ℤ.* (c ℤ.* d) ≡ a ℤ.* c ℤ.* (b ℤ.* d)
+  reorder₂ = solve 4 (λ a b c d → (a :* b) :* (c :* d) := (a :* c) :* (b :* d)) refl
+    where open ℤ-solver
+
+  +▹-nonNeg : ∀ n → ℤ.NonNegative (Sign.+ ℤ.◃ n)
+  +▹-nonNeg 0       = _
+  +▹-nonNeg (suc _) = _
+
+*-cancelʳ-≤-pos : ∀ r .{{_ : Positive r}} → p * r ≤ q * r → p ≤ q
+*-cancelʳ-≤-pos {p@record{}} {q@record{}} r@(mkℚᵘ +[1+ _ ] _) (*≤* x≤y) =
+ *≤* $ ℤ.*-cancelʳ-≤-pos _ _ (↥ r ℤ.* ↧ r) $ begin
+    (↥ p ℤ.* ↧ q) ℤ.* (↥ r ℤ.* ↧ r)  ≡⟨ reorder₂ (↥ p) _ _ (↧ r) ⟩
+    (↥ p ℤ.* ↥ r) ℤ.* (↧ q ℤ.* ↧ r)  ≤⟨ x≤y ⟩
+    (↥ q ℤ.* ↥ r) ℤ.* (↧ p ℤ.* ↧ r)  ≡⟨ reorder₂ (↥ q) _ _ (↧ r) ⟩
+    (↥ q ℤ.* ↧ p) ℤ.* (↥ r ℤ.* ↧ r)  ∎ where open ℤ.≤-Reasoning
+
+*-cancelˡ-≤-pos : ∀ r .{{_ : Positive r}} → r * p ≤ r * q → p ≤ q
+*-cancelˡ-≤-pos {p} {q} r rewrite *-comm-≡ r p | *-comm-≡ r q = *-cancelʳ-≤-pos r
+
+*-cancelʳ-≤-neg : ∀ r .{{_ : Negative r}} → p * r ≤ q * r → q ≤ p
+*-cancelʳ-≤-neg {p} {q} r@(mkℚᵘ -[1+ _ ] _) pr≤qr = neg-cancel-≤ (*-cancelʳ-≤-pos (- r) (begin
+  - p * - r    ≃⟨ neg-distribˡ-* p (- r) ⟨
+  - (p * - r)  ≃⟨ -‿cong (neg-distribʳ-* p r) ⟨
+  - - (p * r)  ≃⟨ neg-involutive (p * r) ⟩
+  p * r        ≤⟨ pr≤qr ⟩
+  q * r        ≃⟨ neg-involutive (q * r) ⟨
+  - - (q * r)  ≃⟨ -‿cong (neg-distribʳ-* q r) ⟩
+  - (q * - r)  ≃⟨ neg-distribˡ-* q (- r) ⟩
+  - q * - r    ∎))
+  where open ≤-Reasoning
+
+*-cancelˡ-≤-neg : ∀ r .{{_ : Negative r}} → r * p ≤ r * q → q ≤ p
+*-cancelˡ-≤-neg {p} {q} r rewrite *-comm-≡ r p | *-comm-≡ r q = *-cancelʳ-≤-neg r
+
+*-monoˡ-≤-nonNeg : ∀ r .{{_ : NonNegative r}} → (_* r) Preserves _≤_ ⟶ _≤_
+*-monoˡ-≤-nonNeg r@(mkℚᵘ (ℤ.+ n) _) {p@record{}} {q@record{}} (*≤* x<y) = *≤* $ begin
+  ↥ p ℤ.* ↥ r ℤ.* (↧ q   ℤ.* ↧ r)  ≡⟨  reorder₂ (↥ p) _ _ _ ⟩
+  l₁          ℤ.* (ℤ.+ n ℤ.* ↧ r)  ≡⟨  cong (l₁ ℤ.*_) (ℤ.pos-* n _) ⟨
+  l₁          ℤ.* ℤ.+ (n ℕ.* ↧ₙ r) ≤⟨  ℤ.*-monoʳ-≤-nonNeg (ℤ.+ (n ℕ.* ↧ₙ r)) x<y ⟩
+  l₂          ℤ.* ℤ.+ (n ℕ.* ↧ₙ r) ≡⟨ cong (l₂ ℤ.*_) (ℤ.pos-* n _) ⟩
+  l₂          ℤ.* (ℤ.+ n ℤ.* ↧ r)  ≡⟨  reorder₂ (↥ q) _ _ _ ⟩
+  ↥ q ℤ.* ↥ r ℤ.* (↧ p   ℤ.* ↧ r)  ∎
+  where open ℤ.≤-Reasoning; l₁ = ↥ p ℤ.* ↧ q ; l₂ = ↥ q ℤ.* ↧ p
+
+*-monoʳ-≤-nonNeg : ∀ r .{{_ :  NonNegative r}} → (r *_) Preserves _≤_ ⟶ _≤_
+*-monoʳ-≤-nonNeg r {p} {q} rewrite *-comm-≡ r p | *-comm-≡ r q = *-monoˡ-≤-nonNeg r
+
+*-mono-≤-nonNeg : ∀ {p q r s} .{{_ : NonNegative p}} .{{_ : NonNegative r}} →
+                  p ≤ q → r ≤ s → p * r ≤ q * s
+*-mono-≤-nonNeg {p} {q} {r} {s} p≤q r≤s = begin
+  p * r ≤⟨ *-monoˡ-≤-nonNeg r p≤q ⟩
+  q * r ≤⟨ *-monoʳ-≤-nonNeg q {{nonNeg≤⇒nonNeg p≤q}} r≤s ⟩
+  q * s ∎
+  where open ≤-Reasoning
+
+*-monoˡ-≤-nonPos : ∀ r .{{_ : NonPositive r}} → (_* r) Preserves _≤_ ⟶ _≥_
+*-monoˡ-≤-nonPos r {p} {q} p≤q = begin
+  q * r        ≃⟨ neg-involutive (q * r) ⟨
+  - - (q * r)  ≃⟨  -‿cong (neg-distribʳ-* q r) ⟩
+  - (q * - r)  ≤⟨  neg-mono-≤ (*-monoˡ-≤-nonNeg (- r) {{ -r≥0}} p≤q) ⟩
+  - (p * - r)  ≃⟨ -‿cong (neg-distribʳ-* p r) ⟨
+  - - (p * r)  ≃⟨  neg-involutive (p * r) ⟩
+  p * r        ∎
+  where open ≤-Reasoning; -r≥0 = nonNegative (neg-mono-≤ (nonPositive⁻¹ r))
+
+*-monoʳ-≤-nonPos : ∀ r .{{_ :  NonPositive r}} → (r *_) Preserves _≤_ ⟶ _≥_
+*-monoʳ-≤-nonPos r {p} {q} rewrite *-comm-≡ r q | *-comm-≡ r p = *-monoˡ-≤-nonPos r
+
+------------------------------------------------------------------------
+-- Properties of _*_ and _<_
+
+*-monoˡ-<-pos : ∀ r .{{_ : Positive r}} → (_* r) Preserves _<_ ⟶ _<_
+*-monoˡ-<-pos r@record{} {p@record{}} {q@record{}} (*<* x<y) = *<* $ begin-strict
+  ↥ p ℤ.*  ↥ r ℤ.* (↧ q  ℤ.* ↧ r) ≡⟨ reorder₁ (↥ p) _ _ _ ⟩
+  ↥ p ℤ.*  ↧ q ℤ.*  ↥ r  ℤ.* ↧ r  <⟨ ℤ.*-monoʳ-<-pos (↧ r) (ℤ.*-monoʳ-<-pos (↥ r) x<y) ⟩
+  ↥ q ℤ.*  ↧ p ℤ.*  ↥ r  ℤ.* ↧ r  ≡⟨ reorder₁ (↥ q) _ _ _ ⟨
+  ↥ q ℤ.*  ↥ r ℤ.* (↧ p  ℤ.* ↧ r) ∎ where open ℤ.≤-Reasoning
+
+*-monoʳ-<-pos : ∀ r .{{_ : Positive r}} → (r *_) Preserves _<_ ⟶ _<_
+*-monoʳ-<-pos r {p} {q} rewrite *-comm-≡ r p | *-comm-≡ r q = *-monoˡ-<-pos r
+
+*-mono-<-nonNeg : ∀ {p q r s} .{{_ : NonNegative p}} .{{_ : NonNegative r}} →
+                  p < q → r < s → p * r < q * s
+*-mono-<-nonNeg {p} {q} {r} {s} p<q r<s = begin-strict
+  p * r ≤⟨ *-monoˡ-≤-nonNeg r (<⇒≤ p<q) ⟩
+  q * r <⟨ *-monoʳ-<-pos q {{nonNeg<⇒pos p<q}} r<s ⟩
+  q * s ∎
+  where open ≤-Reasoning
+
+*-cancelʳ-<-nonNeg : ∀ r .{{_ : NonNegative r}} → p * r < q * r → p < q
+*-cancelʳ-<-nonNeg {p@record{}} {q@record{}} r@(mkℚᵘ (ℤ.+ _) _) (*<* x<y) =
+  *<* $ ℤ.*-cancelʳ-<-nonNeg (↥ r ℤ.* ↧ r) {{+▹-nonNeg _}} $ begin-strict
+    (↥ p ℤ.* ↧ q) ℤ.* (↥ r ℤ.* ↧ r)  ≡⟨ reorder₂ (↥ p) _ _ (↧ r) ⟩
+    (↥ p ℤ.* ↥ r) ℤ.* (↧ q ℤ.* ↧ r)  <⟨ x<y ⟩
+    (↥ q ℤ.* ↥ r) ℤ.* (↧ p ℤ.* ↧ r)  ≡⟨ reorder₂ (↥ q) _ _ (↧ r) ⟩
+    (↥ q ℤ.* ↧ p) ℤ.* (↥ r ℤ.* ↧ r)  ∎ where open ℤ.≤-Reasoning
+
+*-cancelˡ-<-nonNeg : ∀ r .{{_ : NonNegative r}} → r * p < r * q → p < q
+*-cancelˡ-<-nonNeg {p} {q} r rewrite *-comm-≡ r p | *-comm-≡ r q = *-cancelʳ-<-nonNeg r
+
+*-monoˡ-<-neg : ∀ r .{{_ :  Negative r}} → (_* r) Preserves _<_ ⟶ _>_
+*-monoˡ-<-neg r {p} {q} p<q = begin-strict
+  q * r        ≃⟨ neg-involutive (q * r) ⟨
+  - - (q * r)  ≃⟨ -‿cong (neg-distribʳ-* q r) ⟩
+  - (q * - r)  <⟨ neg-mono-< (*-monoˡ-<-pos (- r) {{ -r>0}} p<q) ⟩
+  - (p * - r)  ≃⟨ -‿cong (neg-distribʳ-* p r) ⟨
+  - - (p * r)  ≃⟨ neg-involutive (p * r) ⟩
+  p * r        ∎
+  where open ≤-Reasoning; -r>0 = positive (neg-mono-< (negative⁻¹ r))
+
+*-monoʳ-<-neg : ∀ r .{{_ : Negative r}} → (r *_) Preserves _<_ ⟶ _>_
+*-monoʳ-<-neg r {p} {q} rewrite *-comm-≡ r q | *-comm-≡ r p = *-monoˡ-<-neg r
+
+*-cancelˡ-<-nonPos : ∀ r .{{_ : NonPositive r}} → r * p < r * q → q < p
+*-cancelˡ-<-nonPos {p} {q} r rp<rq =
+  *-cancelˡ-<-nonNeg (- r) {{ -r≥0}} $ begin-strict
+    - r * q    ≃⟨ neg-distribˡ-* r q ⟨
+    - (r * q)  <⟨ neg-mono-< rp<rq ⟩
+    - (r * p)  ≃⟨ neg-distribˡ-* r p ⟩
+    - r * p    ∎
+  where open ≤-Reasoning; -r≥0 = nonNegative (neg-mono-≤ (nonPositive⁻¹ r))
+
+*-cancelʳ-<-nonPos : ∀ r .{{_ : NonPositive r}} → p * r < q * r → q < p
+*-cancelʳ-<-nonPos {p} {q} r rewrite *-comm-≡ p r | *-comm-≡ q r = *-cancelˡ-<-nonPos r
+
+------------------------------------------------------------------------
+-- Properties of _*_ and predicates
+
+pos*pos⇒pos : ∀ p .{{_ : Positive p}} →
+              ∀ q .{{_ : Positive q}} →
+              Positive (p * q)
+pos*pos⇒pos p q = positive
+  (*-mono-<-nonNeg (positive⁻¹ p) (positive⁻¹ q))
+
+nonNeg*nonNeg⇒nonNeg : ∀ p .{{_ : NonNegative p}} →
+                       ∀ q .{{_ : NonNegative q}} →
+                       NonNegative (p * q)
+nonNeg*nonNeg⇒nonNeg p q = nonNegative
+  (*-mono-≤-nonNeg (nonNegative⁻¹ p) (nonNegative⁻¹ q))
+
+------------------------------------------------------------------------
+-- 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
+  ; *-cong           = *-cong
+  ; *-assoc          = *-assoc
+  ; *-identity       = *-identity
+  ; distrib          = *-distrib-+
+  }
+
++-*-isCommutativeRing : IsCommutativeRing _≃_ _+_ _*_ -_ 0ℚᵘ 1ℚᵘ
++-*-isCommutativeRing = record
+  { isRing = +-*-isRing
+  ; *-comm = *-comm
+  }
+
++-*-isHeytingCommutativeRing : IsHeytingCommutativeRing _≃_ _≄_ _+_ _*_ -_ 0ℚᵘ 1ℚᵘ
++-*-isHeytingCommutativeRing = record
+  { isCommutativeRing   = +-*-isCommutativeRing
+  ; isApartnessRelation = ≄-isApartnessRelation
+  ; #⇒invertible        = ≄⇒invertible
+  ; invertible⇒#        = invertible⇒≄
+  }
+
++-*-isHeytingField : IsHeytingField _≃_ _≄_ _+_ _*_ -_ 0ℚᵘ 1ℚᵘ
++-*-isHeytingField = record
+  { isHeytingCommutativeRing = +-*-isHeytingCommutativeRing
+  ; tight                    = ≄-tight
+  }
+
+------------------------------------------------------------------------
+-- 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
+  }
+
++-*-heytingCommutativeRing : HeytingCommutativeRing 0ℓ 0ℓ 0ℓ
++-*-heytingCommutativeRing = record
+  { isHeytingCommutativeRing = +-*-isHeytingCommutativeRing
+  }
+
++-*-heytingField : HeytingField 0ℓ 0ℓ 0ℓ
++-*-heytingField = record
+  { isHeytingField = +-*-isHeytingField
+  }
+
+------------------------------------------------------------------------
+-- Properties of 1/_
+------------------------------------------------------------------------
+
+private
+  p>1⇒p≢0 : p > 1ℚᵘ → NonZero p
+  p>1⇒p≢0 {p} p>1 = pos⇒nonZero p {{positive (<-trans (*<* (ℤ.+<+ ℕ.≤-refl)) p>1)}}
+
+1/nonZero⇒nonZero : ∀ p .{{_ : NonZero p}} → NonZero (1/ p)
+1/nonZero⇒nonZero (mkℚᵘ (+[1+ _ ]) _) = _
+1/nonZero⇒nonZero (mkℚᵘ (-[1+ _ ]) _) = _
+
+1/-involutive-≡ : ∀ p .{{_ : NonZero p}} →
+                  (1/ (1/ p)) {{1/nonZero⇒nonZero p}} ≡ p
+1/-involutive-≡ (mkℚᵘ +[1+ n ] d-1) = refl
+1/-involutive-≡ (mkℚᵘ -[1+ n ] d-1) = refl
+
+1/-involutive : ∀ p .{{_ : NonZero p}} →
+                (1/ (1/ p)) {{1/nonZero⇒nonZero p}} ≃ p
+1/-involutive p = ≃-reflexive (1/-involutive-≡ p)
+
+1/pos⇒pos : ∀ p .{{p>0 : Positive p}} → Positive ((1/ p) {{pos⇒nonZero p}})
+1/pos⇒pos (mkℚᵘ +[1+ n ] d-1) = _
+
+1/neg⇒neg : ∀ p .{{p<0 : Negative p}} → Negative ((1/ p) {{neg⇒nonZero p}})
+1/neg⇒neg (mkℚᵘ -[1+ n ] d-1) = _
+
+p>1⇒1/p<1 : ∀ {p} → (p>1 : p > 1ℚᵘ) → (1/ p) {{p>1⇒p≢0 p>1}} < 1ℚᵘ
+p>1⇒1/p<1 {p} p>1 = lemma′ p (p>1⇒p≢0 p>1) p>1
+  where
+  lemma′ : ∀ p p≢0 → p > 1ℚᵘ → (1/ p) {{p≢0}} < 1ℚᵘ
+  lemma′ (mkℚᵘ n@(+[1+ _ ]) d-1) _ (*<* ↥p1>1↧p) = *<* (begin-strict
+    ↥ (1/ mkℚᵘ n d-1) ℤ.* 1ℤ         ≡⟨⟩
+    +[1+ d-1 ] ℤ.* 1ℤ                ≡⟨ ℤ.*-comm +[1+ d-1 ] 1ℤ ⟩
+    1ℤ ℤ.* +[1+ d-1 ]                <⟨ ↥p1>1↧p ⟩
+    n  ℤ.* 1ℤ                        ≡⟨ ℤ.*-comm n 1ℤ ⟩
+    1ℤ ℤ.* n                         ≡⟨⟩
+    (↥ 1ℚᵘ) ℤ.* (↧ (1/ mkℚᵘ n d-1))  ∎)
+    where open ℤ.≤-Reasoning
+
+1/-antimono-≤-pos : ∀ {p q} .{{_ : Positive p}} .{{_ : Positive q}} →
+                    p ≤ q → (1/ q) {{pos⇒nonZero q}} ≤ (1/ p) {{pos⇒nonZero p}}
+1/-antimono-≤-pos {p} {q} p≤q = begin
+  1/q              ≃⟨ *-identityˡ 1/q ⟨
+  1ℚᵘ * 1/q        ≃⟨ *-congʳ (*-inverseˡ p) ⟨
+  (1/p * p) * 1/q  ≤⟨  *-monoˡ-≤-nonNeg 1/q (*-monoʳ-≤-nonNeg 1/p p≤q) ⟩
+  (1/p * q) * 1/q  ≃⟨  *-assoc 1/p q 1/q ⟩
+  1/p * (q * 1/q)  ≃⟨  *-congˡ {1/p} (*-inverseʳ q) ⟩
+  1/p * 1ℚᵘ        ≃⟨  *-identityʳ (1/p) ⟩
+  1/p              ∎
+  where
+  open ≤-Reasoning
+  instance
+    _ = pos⇒nonZero p
+    _ = pos⇒nonZero q
+  1/p = 1/ p
+  1/q = 1/ q
+  instance
+    1/p≥0 : NonNegative 1/p
+    1/p≥0 = pos⇒nonNeg 1/p {{1/pos⇒pos p}}
+
+    1/q≥0 : NonNegative 1/q
+    1/q≥0 = pos⇒nonNeg 1/q {{1/pos⇒pos q}}
+
+------------------------------------------------------------------------
+-- Properties of _⊓_ and _⊔_
+------------------------------------------------------------------------
+-- Basic specification in terms of _≤_
+
+p≤q⇒p⊔q≃q : p ≤ q → p ⊔ q ≃ q
+p≤q⇒p⊔q≃q {p@record{}} {q@record{}} p≤q with p ≤ᵇ q | inspect (p ≤ᵇ_) q
+... | true  | _       = ≃-refl
+... | false | [ p≰q ] = contradiction (≤⇒≤ᵇ p≤q) (subst (¬_ ∘ T) (sym p≰q) λ())
+
+p≥q⇒p⊔q≃p : p ≥ q → p ⊔ q ≃ p
+p≥q⇒p⊔q≃p {p@record{}} {q@record{}} p≥q with p ≤ᵇ q | inspect (p ≤ᵇ_) q
+... | true  | [ p≤q ] = ≤-antisym p≥q (≤ᵇ⇒≤ (subst T (sym p≤q) _))
+... | false | [ p≤q ] = ≃-refl
+
+p≤q⇒p⊓q≃p : p ≤ q → p ⊓ q ≃ p
+p≤q⇒p⊓q≃p {p@record{}} {q@record{}} p≤q with p ≤ᵇ q | inspect (p ≤ᵇ_) q
+... | true  | _       = ≃-refl
+... | false | [ p≰q ] = contradiction (≤⇒≤ᵇ p≤q) (subst (¬_ ∘ T) (sym p≰q) λ())
+
+p≥q⇒p⊓q≃q : p ≥ q → p ⊓ q ≃ q
+p≥q⇒p⊓q≃q {p@record{}} {q@record{}} p≥q with p ≤ᵇ q | inspect (p ≤ᵇ_) q
+... | true  | [ p≤q ] = ≤-antisym (≤ᵇ⇒≤ (subst T (sym p≤q) _)) p≥q
+... | false | [ p≤q ] = ≃-refl
+
+⊓-operator : MinOperator ≤-totalPreorder
+⊓-operator = record
+  { x≤y⇒x⊓y≈x = p≤q⇒p⊓q≃p
+  ; x≥y⇒x⊓y≈y = p≥q⇒p⊓q≃q
+  }
+
+⊔-operator : MaxOperator ≤-totalPreorder
+⊔-operator = record
+  { x≤y⇒x⊔y≈y = p≤q⇒p⊔q≃q
+  ; x≥y⇒x⊔y≈x = p≥q⇒p⊔q≃p
+  }
+
+------------------------------------------------------------------------
+-- Derived properties of _⊓_ and _⊔_
+
+private
+  module ⊓-⊔-properties        = MinMaxOp        ⊓-operator ⊔-operator
+  module ⊓-⊔-latticeProperties = LatticeMinMaxOp ⊓-operator ⊔-operator
+
+open ⊓-⊔-properties public
+  using
+  ( ⊓-congˡ                   -- : LeftCongruent _≃_ _⊓_
+  ; ⊓-congʳ                   -- : RightCongruent _≃_ _⊓_
+  ; ⊓-cong                    -- : Congruent₂ _≃_ _⊓_
+  ; ⊓-idem                    -- : Idempotent _≃_ _⊓_
+  ; ⊓-sel                     -- : Selective _≃_ _⊓_
+  ; ⊓-assoc                   -- : Associative _≃_ _⊓_
+  ; ⊓-comm                    -- : Commutative _≃_ _⊓_
+
+  ; ⊔-congˡ                   -- : LeftCongruent _≃_ _⊔_
+  ; ⊔-congʳ                   -- : RightCongruent _≃_ _⊔_
+  ; ⊔-cong                    -- : Congruent₂ _≃_ _⊔_
+  ; ⊔-idem                    -- : Idempotent _≃_ _⊔_
+  ; ⊔-sel                     -- : Selective _≃_ _⊔_
+  ; ⊔-assoc                   -- : Associative _≃_ _⊔_
+  ; ⊔-comm                    -- : Commutative _≃_ _⊔_
+
+  ; ⊓-distribˡ-⊔              -- : _DistributesOverˡ_ _≃_ _⊓_ _⊔_
+  ; ⊓-distribʳ-⊔              -- : _DistributesOverʳ_ _≃_ _⊓_ _⊔_
+  ; ⊓-distrib-⊔               -- : _DistributesOver_  _≃_ _⊓_ _⊔_
+  ; ⊔-distribˡ-⊓              -- : _DistributesOverˡ_ _≃_ _⊔_ _⊓_
+  ; ⊔-distribʳ-⊓              -- : _DistributesOverʳ_ _≃_ _⊔_ _⊓_
+  ; ⊔-distrib-⊓               -- : _DistributesOver_  _≃_ _⊔_ _⊓_
+  ; ⊓-absorbs-⊔               -- : _Absorbs_ _≃_ _⊓_ _⊔_
+  ; ⊔-absorbs-⊓               -- : _Absorbs_ _≃_ _⊔_ _⊓_
+  ; ⊔-⊓-absorptive            -- : Absorptive _≃_ _⊔_ _⊓_
+  ; ⊓-⊔-absorptive            -- : Absorptive _≃_ _⊓_ _⊔_
+
+  ; ⊓-isMagma                 -- : IsMagma _≃_ _⊓_
+  ; ⊓-isSemigroup             -- : IsSemigroup _≃_ _⊓_
+  ; ⊓-isCommutativeSemigroup  -- : IsCommutativeSemigroup _≃_ _⊓_
+  ; ⊓-isBand                  -- : IsBand _≃_ _⊓_
+  ; ⊓-isSelectiveMagma        -- : IsSelectiveMagma _≃_ _⊓_
+
+  ; ⊔-isMagma                 -- : IsMagma _≃_ _⊔_
+  ; ⊔-isSemigroup             -- : IsSemigroup _≃_ _⊔_
+  ; ⊔-isCommutativeSemigroup  -- : IsCommutativeSemigroup _≃_ _⊔_
+  ; ⊔-isBand                  -- : IsBand _≃_ _⊔_
+  ; ⊔-isSelectiveMagma        -- : IsSelectiveMagma _≃_ _⊔_
+
+  ; ⊓-magma                   -- : Magma _ _
+  ; ⊓-semigroup               -- : Semigroup _ _
+  ; ⊓-band                    -- : Band _ _
+  ; ⊓-commutativeSemigroup    -- : CommutativeSemigroup _ _
+  ; ⊓-selectiveMagma          -- : SelectiveMagma _ _
+
+  ; ⊔-magma                   -- : Magma _ _
+  ; ⊔-semigroup               -- : Semigroup _ _
+  ; ⊔-band                    -- : Band _ _
+  ; ⊔-commutativeSemigroup    -- : CommutativeSemigroup _ _
+  ; ⊔-selectiveMagma          -- : SelectiveMagma _ _
+
+  ; ⊓-triangulate             -- : ∀ p q r → p ⊓ q ⊓ r ≃ (p ⊓ q) ⊓ (q ⊓ r)
+  ; ⊔-triangulate             -- : ∀ p q r → p ⊔ q ⊔ r ≃ (p ⊔ q) ⊔ (q ⊔ r)
+
+  ; ⊓-glb                     -- : ∀ {p q r} → p ≥ r → q ≥ r → p ⊓ q ≥ r
+  ; ⊓-mono-≤                  -- : _⊓_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_
+  ; ⊓-monoˡ-≤                 -- : ∀ p → (_⊓ p) Preserves _≤_ ⟶ _≤_
+  ; ⊓-monoʳ-≤                 -- : ∀ p → (p ⊓_) Preserves _≤_ ⟶ _≤_
+
+  ; ⊔-lub                     -- : ∀ {p q r} → p ≤ r → q ≤ r → p ⊔ q ≤ r
+  ; ⊔-mono-≤                  -- : _⊔_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_
+  ; ⊔-monoˡ-≤                 -- : ∀ p → (_⊔ p) Preserves _≤_ ⟶ _≤_
+  ; ⊔-monoʳ-≤                 -- : ∀ p → (p ⊔_) Preserves _≤_ ⟶ _≤_
+  )
+  renaming
+  ( x⊓y≈y⇒y≤x  to p⊓q≃q⇒q≤p      -- : ∀ {p q} → p ⊓ q ≃ q → q ≤ p
+  ; x⊓y≈x⇒x≤y  to p⊓q≃p⇒p≤q      -- : ∀ {p q} → p ⊓ q ≃ p → p ≤ q
+  ; x⊔y≈y⇒x≤y  to p⊔q≃q⇒p≤q      -- : ∀ {p q} → p ⊔ q ≃ q → p ≤ q
+  ; x⊔y≈x⇒y≤x  to p⊔q≃p⇒q≤p      -- : ∀ {p q} → p ⊔ q ≃ p → q ≤ p
+
+  ; x⊓y≤x      to p⊓q≤p          -- : ∀ p q → p ⊓ q ≤ p
+  ; x⊓y≤y      to p⊓q≤q          -- : ∀ p q → p ⊓ q ≤ q
+  ; x≤y⇒x⊓z≤y  to p≤q⇒p⊓r≤q      -- : ∀ {p q} r → p ≤ q → p ⊓ r ≤ q
+  ; x≤y⇒z⊓x≤y  to p≤q⇒r⊓p≤q      -- : ∀ {p q} r → p ≤ q → r ⊓ p ≤ q
+  ; x≤y⊓z⇒x≤y  to p≤q⊓r⇒p≤q      -- : ∀ {p} q r → p ≤ q ⊓ r → p ≤ q
+  ; x≤y⊓z⇒x≤z  to p≤q⊓r⇒p≤r      -- : ∀ {p} q r → p ≤ q ⊓ r → p ≤ r
+
+  ; x≤x⊔y      to p≤p⊔q          -- : ∀ p q → p ≤ p ⊔ q
+  ; x≤y⊔x      to p≤q⊔p          -- : ∀ p q → p ≤ q ⊔ p
+  ; x≤y⇒x≤y⊔z  to p≤q⇒p≤q⊔r      -- : ∀ {p q} r → p ≤ q → p ≤ q ⊔ r
+  ; x≤y⇒x≤z⊔y  to p≤q⇒p≤r⊔q      -- : ∀ {p q} r → p ≤ q → p ≤ r ⊔ q
+  ; x⊔y≤z⇒x≤z  to p⊔q≤r⇒p≤r      -- : ∀ p q {r} → p ⊔ q ≤ r → p ≤ r
+  ; x⊔y≤z⇒y≤z  to p⊔q≤r⇒q≤r      -- : ∀ p q {r} → p ⊔ q ≤ r → q ≤ r
+
+  ; x⊓y≤x⊔y    to p⊓q≤p⊔q        -- : ∀ p q → p ⊓ q ≤ p ⊔ q
+  )
+
+open ⊓-⊔-latticeProperties public
+  using
+  ( ⊓-semilattice             -- : Semilattice _ _
+  ; ⊔-semilattice             -- : Semilattice _ _
+  ; ⊔-⊓-lattice               -- : Lattice _ _
+  ; ⊓-⊔-lattice               -- : Lattice _ _
+  ; ⊔-⊓-distributiveLattice   -- : DistributiveLattice _ _
+  ; ⊓-⊔-distributiveLattice   -- : DistributiveLattice _ _
+
+  ; ⊓-isSemilattice           -- : IsSemilattice _≃_ _⊓_
+  ; ⊔-isSemilattice           -- : IsSemilattice _≃_ _⊔_
+  ; ⊔-⊓-isLattice             -- : IsLattice _≃_ _⊔_ _⊓_
+  ; ⊓-⊔-isLattice             -- : IsLattice _≃_ _⊓_ _⊔_
+  ; ⊔-⊓-isDistributiveLattice -- : IsDistributiveLattice _≃_ _⊔_ _⊓_
+  ; ⊓-⊔-isDistributiveLattice -- : IsDistributiveLattice _≃_ _⊓_ _⊔_
+  )
+
+------------------------------------------------------------------------
+-- Raw bundles
+
+⊓-rawMagma : RawMagma _ _
+⊓-rawMagma = Magma.rawMagma ⊓-magma
+
+⊔-rawMagma : RawMagma _ _
+⊔-rawMagma = Magma.rawMagma ⊔-magma
+
+⊔-⊓-rawLattice : RawLattice _ _
+⊔-⊓-rawLattice = Lattice.rawLattice ⊔-⊓-lattice
+
+------------------------------------------------------------------------
+-- Monotonic or antimonotic functions distribute over _⊓_ and _⊔_
+
+mono-≤-distrib-⊔ : ∀ {f} → f Preserves _≤_ ⟶ _≤_ →
+                   ∀ m n → f (m ⊔ n) ≃ f m ⊔ f n
+mono-≤-distrib-⊔ pres = ⊓-⊔-properties.mono-≤-distrib-⊔ (mono⇒cong pres) pres
+
+mono-≤-distrib-⊓ : ∀ {f} → f Preserves _≤_ ⟶ _≤_ →
+                   ∀ m n → f (m ⊓ n) ≃ f m ⊓ f n
+mono-≤-distrib-⊓ pres = ⊓-⊔-properties.mono-≤-distrib-⊓ (mono⇒cong pres) pres
+
+antimono-≤-distrib-⊓ : ∀ {f} → f Preserves _≤_ ⟶ _≥_ →
+                       ∀ m n → f (m ⊓ n) ≃ f m ⊔ f n
+antimono-≤-distrib-⊓ pres = ⊓-⊔-properties.antimono-≤-distrib-⊓ (antimono⇒cong pres) pres
+
+antimono-≤-distrib-⊔ : ∀ {f} → f Preserves _≤_ ⟶ _≥_ →
+                       ∀ m n → f (m ⊔ n) ≃ f m ⊓ f n
+antimono-≤-distrib-⊔ pres = ⊓-⊔-properties.antimono-≤-distrib-⊔ (antimono⇒cong pres) pres
+
+------------------------------------------------------------------------
+-- Properties of _⊓_, _⊔_ and -_
+
+neg-distrib-⊔-⊓ : ∀ p q → - (p ⊔ q) ≃ - p ⊓ - q
+neg-distrib-⊔-⊓ = antimono-≤-distrib-⊔ neg-mono-≤
+
+neg-distrib-⊓-⊔ : ∀ p q → - (p ⊓ q) ≃ - p ⊔ - q
+neg-distrib-⊓-⊔ = antimono-≤-distrib-⊓ neg-mono-≤
+
+------------------------------------------------------------------------
+-- Properties of _⊓_, _⊔_ and _*_
+
+*-distribˡ-⊓-nonNeg : ∀ p .{{_ : NonNegative p}} → ∀ q r → p * (q ⊓ r) ≃ (p * q) ⊓ (p * r)
+*-distribˡ-⊓-nonNeg p = mono-≤-distrib-⊓ (*-monoʳ-≤-nonNeg p)
+
+*-distribʳ-⊓-nonNeg : ∀ p .{{_ : NonNegative p}} → ∀ q r → (q ⊓ r) * p ≃ (q * p) ⊓ (r * p)
+*-distribʳ-⊓-nonNeg p = mono-≤-distrib-⊓ (*-monoˡ-≤-nonNeg p)
+
+*-distribˡ-⊔-nonNeg : ∀ p .{{_ : NonNegative p}} → ∀ q r → p * (q ⊔ r) ≃ (p * q) ⊔ (p * r)
+*-distribˡ-⊔-nonNeg p = mono-≤-distrib-⊔ (*-monoʳ-≤-nonNeg p)
+
+*-distribʳ-⊔-nonNeg : ∀ p .{{_ : NonNegative p}} → ∀ q r → (q ⊔ r) * p ≃ (q * p) ⊔ (r * p)
+*-distribʳ-⊔-nonNeg p = mono-≤-distrib-⊔ (*-monoˡ-≤-nonNeg p)
+
+------------------------------------------------------------------------
+-- Properties of _⊓_, _⊔_ and _*_
+
+*-distribˡ-⊔-nonPos : ∀ p .{{_ : NonPositive p}} → ∀ q r → p * (q ⊔ r) ≃ (p * q) ⊓ (p * r)
+*-distribˡ-⊔-nonPos p = antimono-≤-distrib-⊔ (*-monoʳ-≤-nonPos p)
+
+*-distribʳ-⊔-nonPos : ∀ p .{{_ : NonPositive p}} → ∀ q r → (q ⊔ r) * p ≃ (q * p) ⊓ (r * p)
+*-distribʳ-⊔-nonPos p = antimono-≤-distrib-⊔ (*-monoˡ-≤-nonPos p)
+
+*-distribˡ-⊓-nonPos : ∀ p .{{_ : NonPositive p}} → ∀ q r → p * (q ⊓ r) ≃ (p * q) ⊔ (p * r)
+*-distribˡ-⊓-nonPos p = antimono-≤-distrib-⊓ (*-monoʳ-≤-nonPos p)
+
+*-distribʳ-⊓-nonPos : ∀ p .{{_ : NonPositive p}} → ∀ q r → (q ⊓ r) * p ≃ (q * p) ⊔ (r * p)
+*-distribʳ-⊓-nonPos p = antimono-≤-distrib-⊓ (*-monoˡ-≤-nonPos p)
+
+------------------------------------------------------------------------
+-- Properties of _⊓_, _⊔_ and _<_
+
+⊓-mono-< : _⊓_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_
+⊓-mono-< {p} {r} {q} {s} p<r q<s with ⊓-sel r s
+... | inj₁ r⊓s≃r = <-respʳ-≃ (≃-sym r⊓s≃r) (≤-<-trans (p⊓q≤p p q) p<r)
+... | inj₂ r⊓s≃s = <-respʳ-≃ (≃-sym r⊓s≃s) (≤-<-trans (p⊓q≤q p q) q<s)
+
+⊔-mono-< : _⊔_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_
+⊔-mono-< {p} {r} {q} {s} p<r q<s with ⊔-sel p q
+... | inj₁ p⊔q≃p = <-respˡ-≃ (≃-sym p⊔q≃p) (<-≤-trans p<r (p≤p⊔q r s))
+... | inj₂ p⊔q≃q = <-respˡ-≃ (≃-sym p⊔q≃q) (<-≤-trans q<s (p≤q⊔p r s))
+
+------------------------------------------------------------------------
+-- Properties of _⊓_, _⊔_ and predicates
+
+pos⊓pos⇒pos : ∀ p .{{_ : Positive p}} →
+              ∀ q .{{_ : Positive q}} →
+              Positive (p ⊓ q)
+pos⊓pos⇒pos p q = positive (⊓-mono-< (positive⁻¹ p) (positive⁻¹ q))
+
+pos⊔pos⇒pos : ∀ p .{{_ : Positive p}} →
+              ∀ q .{{_ : Positive q}} →
+              Positive (p ⊔ q)
+pos⊔pos⇒pos p q = positive (⊔-mono-< (positive⁻¹ p) (positive⁻¹ q))
+
+------------------------------------------------------------------------
+-- Properties of ∣_∣
+------------------------------------------------------------------------
+
+∣-∣-cong : p ≃ q → ∣ p ∣ ≃ ∣ q ∣
+∣-∣-cong p@{mkℚᵘ +[1+ _ ] _} q@{mkℚᵘ +[1+ _ ] _} (*≡* ↥p↧q≡↥q↧p) = *≡* ↥p↧q≡↥q↧p
+∣-∣-cong p@{mkℚᵘ +0       _} q@{mkℚᵘ +0       _} (*≡* ↥p↧q≡↥q↧p) = *≡* ↥p↧q≡↥q↧p
+∣-∣-cong p@{mkℚᵘ -[1+ _ ] _} q@{mkℚᵘ +0       _} (*≡* ())
+∣-∣-cong p@{mkℚᵘ -[1+ _ ] _} q@{mkℚᵘ -[1+ _ ] _} (*≡* ↥p↧q≡↥q↧p) = *≡* (begin
+  ↥ ∣ p ∣ ℤ.* ↧ q            ≡⟨ ℤ.neg-involutive _ ⟩
+  ℤ.- ℤ.- (↥ ∣ p ∣ ℤ.* ↧ q)  ≡⟨ cong ℤ.-_ (ℤ.neg-distribˡ-* (↥ ∣ p ∣) (↧ q)) ⟩
+  ℤ.- (↥ p ℤ.* ↧ q)          ≡⟨ cong ℤ.-_ ↥p↧q≡↥q↧p ⟩
+  ℤ.- (↥ q ℤ.* ↧ p)          ≡⟨ cong ℤ.-_ (ℤ.neg-distribˡ-* (↥ ∣ q ∣) (↧ p)) ⟩
+  ℤ.- ℤ.- (↥ ∣ q ∣ ℤ.* ↧ p)  ≡⟨ ℤ.neg-involutive _ ⟨
+  ↥ ∣ q ∣ ℤ.* ↧ p            ∎)
+  where open ≡-Reasoning
+
+∣p∣≃0⇒p≃0 : ∣ p ∣ ≃ 0ℚᵘ → p ≃ 0ℚᵘ
+∣p∣≃0⇒p≃0 {mkℚᵘ (ℤ.+ n)  d-1} p≃0ℚ = p≃0ℚ
+∣p∣≃0⇒p≃0 {mkℚᵘ -[1+ n ] d-1} (*≡* ())
+
+0≤∣p∣ : ∀ p → 0ℚᵘ ≤ ∣ p ∣
+0≤∣p∣ (mkℚᵘ +0       _) = *≤* (ℤ.+≤+ ℕ.z≤n)
+0≤∣p∣ (mkℚᵘ +[1+ _ ] _) = *≤* (ℤ.+≤+ ℕ.z≤n)
+0≤∣p∣ (mkℚᵘ -[1+ _ ] _) = *≤* (ℤ.+≤+ ℕ.z≤n)
+
+∣-p∣≡∣p∣ : ∀ p → ∣ - p ∣ ≡ ∣ p ∣
+∣-p∣≡∣p∣ (mkℚᵘ +[1+ n ] d) = refl
+∣-p∣≡∣p∣ (mkℚᵘ +0       d) = refl
+∣-p∣≡∣p∣ (mkℚᵘ -[1+ n ] d) = refl
+
+∣-p∣≃∣p∣ : ∀ p → ∣ - p ∣ ≃ ∣ p ∣
+∣-p∣≃∣p∣ = ≃-reflexive ∘ ∣-p∣≡∣p∣
+
+0≤p⇒∣p∣≡p : 0ℚᵘ ≤ p → ∣ p ∣ ≡ p
+0≤p⇒∣p∣≡p {mkℚᵘ (ℤ.+ n)  d-1} 0≤p = refl
+0≤p⇒∣p∣≡p {mkℚᵘ -[1+ n ] d-1} 0≤p = contradiction 0≤p (<⇒≱ (*<* ℤ.-<+))
+
+0≤p⇒∣p∣≃p : 0ℚᵘ ≤ p → ∣ p ∣ ≃ p
+0≤p⇒∣p∣≃p {p} = ≃-reflexive ∘ 0≤p⇒∣p∣≡p {p}
+
+∣p∣≡p⇒0≤p : ∣ p ∣ ≡ p → 0ℚᵘ ≤ p
+∣p∣≡p⇒0≤p {mkℚᵘ (ℤ.+ n) d-1} ∣p∣≡p = *≤* (begin
+  0ℤ ℤ.* +[1+ d-1 ]  ≡⟨ ℤ.*-zeroˡ (ℤ.+ d-1) ⟩
+  0ℤ                 ≤⟨ ℤ.+≤+ ℕ.z≤n ⟩
+  ℤ.+ n              ≡⟨ ℤ.*-identityʳ (ℤ.+ n) ⟨
+  ℤ.+ n ℤ.* 1ℤ       ∎)
+  where open ℤ.≤-Reasoning
+
+∣p∣≡p∨∣p∣≡-p : ∀ p → (∣ p ∣ ≡ p) ⊎ (∣ p ∣ ≡ - p)
+∣p∣≡p∨∣p∣≡-p (mkℚᵘ (ℤ.+ n)    d-1) = inj₁ refl
+∣p∣≡p∨∣p∣≡-p (mkℚᵘ (-[1+ n ]) d-1) = inj₂ refl
+
+∣p∣≃p⇒0≤p : ∣ p ∣ ≃ p → 0ℚᵘ ≤ p
+∣p∣≃p⇒0≤p {p} ∣p∣≃p with ∣p∣≡p∨∣p∣≡-p p
+... | inj₁ ∣p∣≡p  = ∣p∣≡p⇒0≤p ∣p∣≡p
+... | inj₂ ∣p∣≡-p rewrite ∣p∣≡-p = ≤-reflexive (≃-sym (p≃-p⇒p≃0 p (≃-sym ∣p∣≃p)))
+
+∣p+q∣≤∣p∣+∣q∣ : ∀ p q → ∣ p + q ∣ ≤ ∣ p ∣ + ∣ q ∣
+∣p+q∣≤∣p∣+∣q∣ p@record{} q@record{} = *≤* (begin
+  ↥ ∣ p + q ∣ ℤ.* ↧ (∣ p ∣ + ∣ q ∣)                ≡⟨⟩
+  ↥ ∣ (↥p↧q ℤ.+ ↥q↧p) / ↧p↧q ∣ ℤ.* ℤ.+ ↧p↧q        ≡⟨⟩
+  ↥ (ℤ.+ ℤ.∣ ↥p↧q ℤ.+ ↥q↧p ∣ / ↧p↧q) ℤ.* ℤ.+ ↧p↧q  ≡⟨ cong (ℤ._* ℤ.+ ↧p↧q) (↥[n/d]≡n (ℤ.+ ℤ.∣ ↥p↧q ℤ.+ ↥q↧p ∣) ↧p↧q) ⟩
+  ℤ.+ ℤ.∣ ↥p↧q ℤ.+ ↥q↧p ∣ ℤ.* ℤ.+ ↧p↧q             ≤⟨ ℤ.*-monoʳ-≤-nonNeg (ℤ.+ ↧p↧q) (ℤ.+≤+ (ℤ.∣i+j∣≤∣i∣+∣j∣ ↥p↧q ↥q↧p)) ⟩
+  (ℤ.+ ℤ.∣ ↥p↧q ∣ ℤ.+ ℤ.+ ℤ.∣ ↥q↧p ∣) ℤ.* ℤ.+ ↧p↧q ≡⟨ cong₂ (λ h₁ h₂ → (h₁ ℤ.+ h₂) ℤ.* ℤ.+ ↧p↧q) ∣↥p∣↧q≡∣↥p↧q∣ ∣↥q∣↧p≡∣↥q↧p∣ ⟨
+  (∣↥p∣↧q ℤ.+ ∣↥q∣↧p) ℤ.* ℤ.+ ↧p↧q                 ≡⟨⟩
+  (↥∣p∣↧q ℤ.+ ↥∣q∣↧p) ℤ.* ℤ.+ ↧p↧q                 ≡⟨ cong (ℤ._* ℤ.+ ↧p↧q) (↥[n/d]≡n (↥∣p∣↧q ℤ.+ ↥∣q∣↧p) ↧p↧q) ⟩
+  ↥ ((↥∣p∣↧q ℤ.+ ↥∣q∣↧p) / ↧p↧q) ℤ.* ℤ.+ ↧p↧q      ≡⟨⟩
+  ↥ (∣ p ∣ + ∣ q ∣) ℤ.* ↧ ∣ p + q ∣ ∎)
+  where
+    open ℤ.≤-Reasoning
+    ↥p↧q = ↥ p ℤ.* ↧ q
+    ↥q↧p = ↥ q ℤ.* ↧ p
+    ↥∣p∣↧q = ↥ ∣ p ∣ ℤ.* ↧ q
+    ↥∣q∣↧p = ↥ ∣ q ∣ ℤ.* ↧ p
+    ∣↥p∣↧q = ℤ.+ ℤ.∣ ↥ p ∣ ℤ.* ↧ q
+    ∣↥q∣↧p = ℤ.+ ℤ.∣ ↥ q ∣ ℤ.* ↧ p
+    ↧p↧q = ↧ₙ p ℕ.* ↧ₙ q
+    ∣m∣n≡∣mn∣ : ∀ m n → ℤ.+ ℤ.∣ m ∣ ℤ.* ℤ.+ n ≡ ℤ.+ ℤ.∣ m ℤ.* ℤ.+ n ∣
+    ∣m∣n≡∣mn∣ m n = begin-equality
+      ℤ.+ ℤ.∣ m ∣ ℤ.* ℤ.+ n                        ≡⟨⟩
+      ℤ.+ ℤ.∣ m ∣ ℤ.* ℤ.+ ℤ.∣ ℤ.+ n ∣              ≡⟨ ℤ.pos-* ℤ.∣ m ∣ ℤ.∣ ℤ.+ n ∣ ⟨
+      ℤ.+ (ℤ.∣ m ∣ ℕ.* n)                          ≡⟨⟩
+      ℤ.+ (ℤ.∣ m ∣ ℕ.* ℤ.∣ ℤ.+ n ∣)                ≡⟨ cong ℤ.+_ (ℤ.∣i*j∣≡∣i∣*∣j∣ m (ℤ.+ n)) ⟨
+      ℤ.+ (ℤ.∣ m ℤ.* ℤ.+ n ∣)                      ∎
+    ∣↥p∣↧q≡∣↥p↧q∣ : ∣↥p∣↧q ≡ ℤ.+ ℤ.∣ ↥p↧q ∣
+    ∣↥p∣↧q≡∣↥p↧q∣ = ∣m∣n≡∣mn∣ (↥ p) (↧ₙ q)
+    ∣↥q∣↧p≡∣↥q↧p∣ : ∣↥q∣↧p ≡ ℤ.+ ℤ.∣ ↥q↧p ∣
+    ∣↥q∣↧p≡∣↥q↧p∣ = ∣m∣n≡∣mn∣ (↥ q) (↧ₙ p)
+
+∣p-q∣≤∣p∣+∣q∣ : ∀ p q → ∣ p - q ∣ ≤ ∣ p ∣ + ∣ q ∣
+∣p-q∣≤∣p∣+∣q∣ p q = begin
+  ∣ p   -     q ∣  ≤⟨ ∣p+q∣≤∣p∣+∣q∣ p (- q) ⟩
+  ∣ p ∣ + ∣ - q ∣  ≡⟨ cong (∣ p ∣ +_) (∣-p∣≡∣p∣ q) ⟩
+  ∣ p ∣ + ∣   q ∣  ∎
+  where open ≤-Reasoning
+
+∣p*q∣≡∣p∣*∣q∣ : ∀ p q → ∣ p * q ∣ ≡ ∣ p ∣ * ∣ q ∣
+∣p*q∣≡∣p∣*∣q∣ p@record{} q@record{} = begin
+  ∣ p * q ∣                                           ≡⟨⟩
+  ∣ (↥ p ℤ.* ↥ q) / (↧ₙ p ℕ.* ↧ₙ q) ∣                 ≡⟨⟩
+  ℤ.+ ℤ.∣ ↥ p ℤ.* ↥ q ∣ / (↧ₙ p ℕ.* ↧ₙ q)             ≡⟨ cong (λ h → ℤ.+ h / ((↧ₙ p) ℕ.* (↧ₙ q))) (ℤ.∣i*j∣≡∣i∣*∣j∣ (↥ p) (↥ q)) ⟩
+  ℤ.+ (ℤ.∣ ↥ p ∣ ℕ.* ℤ.∣ ↥ q ∣) / (↧ₙ p ℕ.* ↧ₙ q)     ≡⟨ cong (_/ (↧ₙ p ℕ.* ↧ₙ q)) (ℤ.pos-* ℤ.∣ ↥ p ∣ ℤ.∣ ↥ q ∣) ⟩
+  (ℤ.+ ℤ.∣ ↥ p ∣ ℤ.* ℤ.+ ℤ.∣ ↥ q ∣) / (↧ₙ p ℕ.* ↧ₙ q) ≡⟨⟩
+  (ℤ.+ ℤ.∣ ↥ p ∣ / ↧ₙ p) * (ℤ.+ ℤ.∣ ↥ q ∣ / ↧ₙ q)     ≡⟨⟩
+  ∣ p ∣ * ∣ q ∣                                       ∎
+  where open ≡-Reasoning
+
+∣p*q∣≃∣p∣*∣q∣ : ∀ p q → ∣ p * q ∣ ≃ ∣ p ∣ * ∣ q ∣
+∣p*q∣≃∣p∣*∣q∣ p q = ≃-reflexive (∣p*q∣≡∣p∣*∣q∣ p q)
+
+∣∣p∣∣≡∣p∣ : ∀ p → ∣ ∣ p ∣ ∣ ≡ ∣ p ∣
+∣∣p∣∣≡∣p∣ p = 0≤p⇒∣p∣≡p (0≤∣p∣ p)
+
+∣∣p∣∣≃∣p∣ : ∀ p → ∣ ∣ p ∣ ∣ ≃ ∣ p ∣
+∣∣p∣∣≃∣p∣ p = ≃-reflexive (∣∣p∣∣≡∣p∣ p)
+
+∣-∣-nonNeg : ∀ p → NonNegative ∣ p ∣
+∣-∣-nonNeg (mkℚᵘ +[1+ _ ] _) = _
+∣-∣-nonNeg (mkℚᵘ +0       _) = _
+∣-∣-nonNeg (mkℚᵘ -[1+ _ ] _) = _
+
+
+------------------------------------------------------------------------
+-- DEPRECATED NAMES
+------------------------------------------------------------------------
+-- Please use the new names as continuing support for the old names is
+-- not guaranteed.
+
+-- Version 1.5
+
+neg-mono-<-> = neg-mono-<
+{-# WARNING_ON_USAGE neg-mono-<->
+"Warning: neg-mono-<-> was deprecated in v1.5.
 Please use neg-mono-< instead."
-#-}
+#-}
 
--- Version 2.0
+-- Version 2.0
 
-↥[p/q]≡p = ↥[n/d]≡n
-{-# WARNING_ON_USAGE ↥[p/q]≡p
-"Warning: ↥[p/q]≡p was deprecated in v2.0.
+↥[p/q]≡p = ↥[n/d]≡n
+{-# WARNING_ON_USAGE ↥[p/q]≡p
+"Warning: ↥[p/q]≡p was deprecated in v2.0.
 Please use ↥[n/d]≡n instead."
-#-}
-↧[p/q]≡q = ↧[n/d]≡d
-{-# WARNING_ON_USAGE ↧[p/q]≡q
-"Warning: ↧[p/q]≡q was deprecated in v2.0.
+#-}
+↧[p/q]≡q = ↧[n/d]≡d
+{-# WARNING_ON_USAGE ↧[p/q]≡q
+"Warning: ↧[p/q]≡q was deprecated in v2.0.
 Please use ↧[n/d]≡d instead."
-#-}
-*-monoʳ-≤-pos : ∀ {r} → Positive r → (r *_) Preserves _≤_ ⟶ _≤_
-*-monoʳ-≤-pos r@{mkℚᵘ +[1+ _ ] _} _ = *-monoʳ-≤-nonNeg r
-{-# WARNING_ON_USAGE *-monoʳ-≤-pos
-"Warning: *-monoʳ-≤-pos was deprecated in v2.0.
+#-}
+*-monoʳ-≤-pos : ∀ {r} → Positive r → (r *_) Preserves _≤_ ⟶ _≤_
+*-monoʳ-≤-pos r@{mkℚᵘ +[1+ _ ] _} _ = *-monoʳ-≤-nonNeg r
+{-# WARNING_ON_USAGE *-monoʳ-≤-pos
+"Warning: *-monoʳ-≤-pos was deprecated in v2.0.
 Please use *-monoʳ-≤-nonNeg instead."
-#-}
-*-monoˡ-≤-pos : ∀ {r} → Positive r → (_* r) Preserves _≤_ ⟶ _≤_
-*-monoˡ-≤-pos r@{mkℚᵘ +[1+ _ ] _} _ = *-monoˡ-≤-nonNeg r
-{-# WARNING_ON_USAGE *-monoˡ-≤-pos
-"Warning: *-monoˡ-≤-nonNeg was deprecated in v2.0.
+#-}
+*-monoˡ-≤-pos : ∀ {r} → Positive r → (_* r) Preserves _≤_ ⟶ _≤_
+*-monoˡ-≤-pos r@{mkℚᵘ +[1+ _ ] _} _ = *-monoˡ-≤-nonNeg r
+{-# WARNING_ON_USAGE *-monoˡ-≤-pos
+"Warning: *-monoˡ-≤-nonNeg was deprecated in v2.0.
 Please use *-monoˡ-≤-nonNeg instead."
-#-}
-≤-steps = p≤q⇒p≤r+q
-{-# WARNING_ON_USAGE ≤-steps
-"Warning: ≤-steps was deprecated in v2.0
+#-}
+≤-steps = p≤q⇒p≤r+q
+{-# WARNING_ON_USAGE ≤-steps
+"Warning: ≤-steps was deprecated in v2.0
 Please use p≤q⇒p≤r+q instead."
-#-}
-*-monoˡ-≤-neg : ∀ r → Negative r → (_* r) Preserves _≤_ ⟶ _≥_
-*-monoˡ-≤-neg r@(mkℚᵘ -[1+ _ ] _) _ = *-monoˡ-≤-nonPos r
-{-# WARNING_ON_USAGE *-monoˡ-≤-neg
-"Warning: *-monoˡ-≤-neg was deprecated in v2.0.
+#-}
+*-monoˡ-≤-neg : ∀ r → Negative r → (_* r) Preserves _≤_ ⟶ _≥_
+*-monoˡ-≤-neg r@(mkℚᵘ -[1+ _ ] _) _ = *-monoˡ-≤-nonPos r
+{-# WARNING_ON_USAGE *-monoˡ-≤-neg
+"Warning: *-monoˡ-≤-neg was deprecated in v2.0.
 Please use *-monoˡ-≤-nonPos instead."
-#-}
-*-monoʳ-≤-neg : ∀ r → Negative r → (r *_) Preserves _≤_ ⟶ _≥_
-*-monoʳ-≤-neg r@(mkℚᵘ -[1+ _ ] _) _ = *-monoʳ-≤-nonPos r
-{-# WARNING_ON_USAGE *-monoʳ-≤-neg
-"Warning: *-monoʳ-≤-neg was deprecated in v2.0.
+#-}
+*-monoʳ-≤-neg : ∀ r → Negative r → (r *_) Preserves _≤_ ⟶ _≥_
+*-monoʳ-≤-neg r@(mkℚᵘ -[1+ _ ] _) _ = *-monoʳ-≤-nonPos r
+{-# WARNING_ON_USAGE *-monoʳ-≤-neg
+"Warning: *-monoʳ-≤-neg was deprecated in v2.0.
 Please use *-monoʳ-≤-nonPos instead."
-#-}
-*-cancelˡ-<-pos : ∀ r → Positive r → ∀ {p q} → r * p < r * q → p < q
-*-cancelˡ-<-pos r@(mkℚᵘ +[1+ _ ] _) r>0 = *-cancelˡ-<-nonNeg r
-{-# WARNING_ON_USAGE *-cancelˡ-<-pos
-"Warning: *-cancelˡ-<-pos was deprecated in v2.0.
+#-}
+*-cancelˡ-<-pos : ∀ r → Positive r → ∀ {p q} → r * p < r * q → p < q
+*-cancelˡ-<-pos r@(mkℚᵘ +[1+ _ ] _) r>0 = *-cancelˡ-<-nonNeg r
+{-# WARNING_ON_USAGE *-cancelˡ-<-pos
+"Warning: *-cancelˡ-<-pos was deprecated in v2.0.
 Please use *-cancelˡ-<-nonNeg instead."
-#-}
-*-cancelʳ-<-pos : ∀ r → Positive r → ∀ {p q} → p * r < q * r → p < q
-*-cancelʳ-<-pos r@(mkℚᵘ +[1+ _ ] _) r>0 = *-cancelʳ-<-nonNeg r
-{-# WARNING_ON_USAGE *-cancelʳ-<-pos
-"Warning: *-cancelʳ-<-pos was deprecated in v2.0.
+#-}
+*-cancelʳ-<-pos : ∀ r → Positive r → ∀ {p q} → p * r < q * r → p < q
+*-cancelʳ-<-pos r@(mkℚᵘ +[1+ _ ] _) r>0 = *-cancelʳ-<-nonNeg r
+{-# WARNING_ON_USAGE *-cancelʳ-<-pos
+"Warning: *-cancelʳ-<-pos was deprecated in v2.0.
 Please use *-cancelʳ-<-nonNeg instead."
-#-}
-*-cancelˡ-<-neg : ∀ r → Negative r → ∀ {p q} → r * p < r * q → q < p
-*-cancelˡ-<-neg r@(mkℚᵘ -[1+ _ ] _) _ = *-cancelˡ-<-nonPos r
-{-# WARNING_ON_USAGE *-cancelˡ-<-neg
-"Warning: *-cancelˡ-<-neg was deprecated in v2.0.
+#-}
+*-cancelˡ-<-neg : ∀ r → Negative r → ∀ {p q} → r * p < r * q → q < p
+*-cancelˡ-<-neg r@(mkℚᵘ -[1+ _ ] _) _ = *-cancelˡ-<-nonPos r
+{-# WARNING_ON_USAGE *-cancelˡ-<-neg
+"Warning: *-cancelˡ-<-neg was deprecated in v2.0.
 Please use *-cancelˡ-<-nonPos instead."
-#-}
-*-cancelʳ-<-neg : ∀ r → Negative r → ∀ {p q} → p * r < q * r → q < p
-*-cancelʳ-<-neg r@(mkℚᵘ -[1+ _ ] _) _ = *-cancelʳ-<-nonPos r
-{-# WARNING_ON_USAGE *-cancelʳ-<-neg
-"Warning: *-cancelʳ-<-neg was deprecated in v2.0.
+#-}
+*-cancelʳ-<-neg : ∀ r → Negative r → ∀ {p q} → p * r < q * r → q < p
+*-cancelʳ-<-neg r@(mkℚᵘ -[1+ _ ] _) _ = *-cancelʳ-<-nonPos r
+{-# WARNING_ON_USAGE *-cancelʳ-<-neg
+"Warning: *-cancelʳ-<-neg was deprecated in v2.0.
 Please use *-cancelʳ-<-nonPos instead."
-#-}
-positive⇒nonNegative : ∀ {p} → Positive p → NonNegative p
-positive⇒nonNegative {p} p>0 = pos⇒nonNeg p {{p>0}}
-{-# WARNING_ON_USAGE positive⇒nonNegative
-"Warning: positive⇒nonNegative was deprecated in v2.0.
+#-}
+positive⇒nonNegative : ∀ {p} → Positive p → NonNegative p
+positive⇒nonNegative {p} p>0 = pos⇒nonNeg p {{p>0}}
+{-# WARNING_ON_USAGE positive⇒nonNegative
+"Warning: positive⇒nonNegative was deprecated in v2.0.
 Please use pos⇒nonNeg instead."
-#-}
-negative⇒nonPositive : ∀ {p} → Negative p → NonPositive p
-negative⇒nonPositive {p} p<0 = neg⇒nonPos p {{p<0}}
-{-# WARNING_ON_USAGE negative⇒nonPositive
-"Warning: negative⇒nonPositive was deprecated in v2.0.
+#-}
+negative⇒nonPositive : ∀ {p} → Negative p → NonPositive p
+negative⇒nonPositive {p} p<0 = neg⇒nonPos p {{p<0}}
+{-# WARNING_ON_USAGE negative⇒nonPositive
+"Warning: negative⇒nonPositive was deprecated in v2.0.
 Please use neg⇒nonPos instead."
-#-}
-negative<positive : ∀ {p q} → .(Negative p) → .(Positive q) → p < q
-negative<positive {p} {q} p<0 q>0 = neg<pos p q {{p<0}} {{q>0}}
-{-# WARNING_ON_USAGE negative<positive
-"Warning: negative<positive was deprecated in v2.0.
+#-}
+negative<positive : ∀ {p q} → .(Negative p) → .(Positive q) → p < q
+negative<positive {p} {q} p<0 q>0 = neg<pos p q {{p<0}} {{q>0}}
+{-# WARNING_ON_USAGE negative<positive
+"Warning: negative<positive was deprecated in v2.0.
 Please use neg<pos instead."
-#-}
+#-}
 
-{- issue1865/issue1755: raw bundles have moved to `Data.X.Base` -}
-open Data.Rational.Unnormalised.Base public
-  using (+-rawMagma; +-0-rawGroup; *-rawMagma; +-*-rawNearSemiring; +-*-rawSemiring; +-*-rawRing)
-  renaming (+-0-rawMonoid to +-rawMonoid; *-1-rawMonoid to *-rawMonoid)
+{- issue1865/issue1755: raw bundles have moved to `Data.X.Base` -}
+open Data.Rational.Unnormalised.Base public
+  using (+-rawMagma; +-0-rawGroup; *-rawMagma; +-*-rawNearSemiring; +-*-rawSemiring; +-*-rawRing)
+  renaming (+-0-rawMonoid to +-rawMonoid; *-1-rawMonoid to *-rawMonoid)
 

\ No newline at end of file
diff --git a/Data.Rational.html b/Data.Rational.html
index ea693ed7..cad1ae47 100644
--- a/Data.Rational.html
+++ b/Data.Rational.html
@@ -14,7 +14,7 @@
 
 open import Data.Rational.Base public
 open import Data.Rational.Properties public
-  using (_≟_; _≤?_; _<?_; _≥?_; _>?_)
+  using (_≟_; _≤?_; _<?_; _≥?_; _>?_)
 
 ------------------------------------------------------------------------
 -- Deprecated
@@ -22,18 +22,18 @@
 -- Version 1.0
 
 open import Data.Rational.Properties public
-  using (drop-*≤*; ≃⇒≡; ≡⇒≃)
+  using (drop-*≤*; ≃⇒≡; ≡⇒≃)
 
 -- Version 1.5
 
 import Data.Integer.Show as ℤ
-open import Data.String using (String; _++_)
+open import Data.String.Base using (String; _++_)
 
-show : ℚ → String
-show p = ℤ.show (↥ p) ++ "/" ++ ℤ.show (↧ p)
+show : ℚ → String
+show p = ℤ.show (↥ p) ++ "/" ++ ℤ.show (↧ p)
 
-{-# WARNING_ON_USAGE show
-"Warning: show was deprecated in v1.5.
+{-# WARNING_ON_USAGE show
+"Warning: show was deprecated in v1.5.
 Please use Data.Rational.Show's show instead."
-#-}
+#-}
\ No newline at end of file diff --git a/Data.Sign.Properties.html b/Data.Sign.Properties.html index cd70af22..bc92b542 100644 --- a/Data.Sign.Properties.html +++ b/Data.Sign.Properties.html @@ -12,195 +12,196 @@ open import Algebra.Bundles open import Data.Empty open import Data.Sign.Base -open import Data.Product using (_,_) -open import Function hiding (Inverse) -open import Level using (0ℓ) -open import Relation.Binary - using (Decidable; DecidableEquality; Setoid; DecSetoid; IsDecEquivalence) -open import Relation.Binary.PropositionalEquality -open import Relation.Nullary.Decidable using (yes; no) +open import Data.Product.Base using (_,_) +open import Function.Base using (_$_; id) +open import Function.Definitions using (Injective) +open import Level using (0ℓ) +open import Relation.Binary + using (Decidable; DecidableEquality; Setoid; DecSetoid; IsDecEquivalence) +open import Relation.Binary.PropositionalEquality +open import Relation.Nullary.Decidable using (yes; no) -open import Algebra.Structures {A = Sign} _≡_ -open import Algebra.Definitions {A = Sign} _≡_ -open import Algebra.Consequences.Propositional - using (selfInverse⇒involutive; selfInverse⇒injective) +open import Algebra.Structures {A = Sign} _≡_ +open import Algebra.Definitions {A = Sign} _≡_ +open import Algebra.Consequences.Propositional + using (selfInverse⇒involutive; selfInverse⇒injective) ------------------------------------------------------------------------- --- Equality +------------------------------------------------------------------------ +-- Equality -infix 4 _≟_ +infix 4 _≟_ -_≟_ : DecidableEquality Sign -- ≟ - = yes refl -- ≟ + = no λ() -+ ≟ - = no λ() -+ ≟ + = yes refl +_≟_ : DecidableEquality Sign +- ≟ - = yes refl +- ≟ + = no λ() ++ ≟ - = no λ() ++ ≟ + = yes refl -≡-setoid : Setoid 0ℓ 0ℓ -≡-setoid = setoid Sign +≡-setoid : Setoid 0ℓ 0ℓ +≡-setoid = setoid Sign -≡-decSetoid : DecSetoid 0ℓ 0ℓ -≡-decSetoid = decSetoid _≟_ +≡-decSetoid : DecSetoid 0ℓ 0ℓ +≡-decSetoid = decSetoid _≟_ -≡-isDecEquivalence : IsDecEquivalence _≡_ -≡-isDecEquivalence = isDecEquivalence _≟_ +≡-isDecEquivalence : IsDecEquivalence _≡_ +≡-isDecEquivalence = isDecEquivalence _≟_ ------------------------------------------------------------------------- --- opposite - --- Algebraic properties of opposite +------------------------------------------------------------------------ +-- opposite + +-- Algebraic properties of opposite -opposite-selfInverse : SelfInverse opposite -opposite-selfInverse { - } { + } refl = refl -opposite-selfInverse { + } { - } refl = refl - -opposite-involutive : Involutive opposite -opposite-involutive = selfInverse⇒involutive opposite-selfInverse - -opposite-injective : Injective _≡_ _≡_ opposite -opposite-injective = selfInverse⇒injective opposite-selfInverse - - ------------------------------------------------------------------------- --- other properties of opposite - -s≢opposite[s] : ∀ s → s ≢ opposite s -s≢opposite[s] - () -s≢opposite[s] + () - ------------------------------------------------------------------------- --- _*_ - --- Algebraic properties of _*_ - -s*s≡+ : ∀ s → s * s ≡ + -s*s≡+ + = refl -s*s≡+ - = refl - -*-identityˡ : LeftIdentity + _*_ -*-identityˡ _ = refl - -*-identityʳ : RightIdentity + _*_ -*-identityʳ - = refl -*-identityʳ + = refl - -*-identity : Identity + _*_ -*-identity = *-identityˡ , *-identityʳ - -*-comm : Commutative _*_ -*-comm + + = refl -*-comm + - = refl -*-comm - + = refl -*-comm - - = refl - -*-assoc : Associative _*_ -*-assoc + + _ = refl -*-assoc + - _ = refl -*-assoc - + _ = refl -*-assoc - - + = refl -*-assoc - - - = refl - -*-cancelʳ-≡ : RightCancellative _*_ -*-cancelʳ-≡ _ - - _ = refl -*-cancelʳ-≡ _ - + eq = ⊥-elim (s≢opposite[s] _ $ sym eq) -*-cancelʳ-≡ _ + - eq = ⊥-elim (s≢opposite[s] _ eq) -*-cancelʳ-≡ _ + + _ = refl - -*-cancelˡ-≡ : LeftCancellative _*_ -*-cancelˡ-≡ - _ _ eq = opposite-injective eq -*-cancelˡ-≡ + _ _ eq = eq - -*-cancel-≡ : Cancellative _*_ -*-cancel-≡ = *-cancelˡ-≡ , *-cancelʳ-≡ - -*-inverse : Inverse + id _*_ -*-inverse = s*s≡+ , s*s≡+ - -*-isMagma : IsMagma _*_ -*-isMagma = record - { isEquivalence = isEquivalence - ; ∙-cong = cong₂ _*_ - } - -*-magma : Magma 0ℓ 0ℓ -*-magma = record - { isMagma = *-isMagma - } - -*-isSemigroup : IsSemigroup _*_ -*-isSemigroup = record - { isMagma = *-isMagma - ; assoc = *-assoc - } - -*-semigroup : Semigroup 0ℓ 0ℓ -*-semigroup = record - { isSemigroup = *-isSemigroup - } - -*-isCommutativeSemigroup : IsCommutativeSemigroup _*_ -*-isCommutativeSemigroup = record - { isSemigroup = *-isSemigroup - ; comm = *-comm - } - -*-commutativeSemigroup : CommutativeSemigroup 0ℓ 0ℓ -*-commutativeSemigroup = record - { isCommutativeSemigroup = *-isCommutativeSemigroup - } - -*-isMonoid : IsMonoid _*_ + -*-isMonoid = record - { isSemigroup = *-isSemigroup - ; identity = *-identity - } - -*-monoid : Monoid 0ℓ 0ℓ -*-monoid = record - { isMonoid = *-isMonoid - } - -*-isCommutativeMonoid : IsCommutativeMonoid _*_ + -*-isCommutativeMonoid = record - { isMonoid = *-isMonoid - ; comm = *-comm - } - -*-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ -*-commutativeMonoid = record - { isCommutativeMonoid = *-isCommutativeMonoid - } - -*-isGroup : IsGroup _*_ + id -*-isGroup = record - { isMonoid = *-isMonoid - ; inverse = *-inverse - ; ⁻¹-cong = id - } - -*-group : Group 0ℓ 0ℓ -*-group = record - { isGroup = *-isGroup - } - -*-isAbelianGroup : IsAbelianGroup _*_ + id -*-isAbelianGroup = record - { isGroup = *-isGroup - ; comm = *-comm - } - -*-abelianGroup : AbelianGroup 0ℓ 0ℓ -*-abelianGroup = record - { isAbelianGroup = *-isAbelianGroup - } - --- Other properties of _*_ - -s*opposite[s]≡- : ∀ s → s * opposite s ≡ - -s*opposite[s]≡- + = refl -s*opposite[s]≡- - = refl - -opposite[s]*s≡- : ∀ s → opposite s * s ≡ - -opposite[s]*s≡- + = refl -opposite[s]*s≡- - = refl +opposite-selfInverse : SelfInverse opposite +opposite-selfInverse { - } { + } refl = refl +opposite-selfInverse { + } { - } refl = refl + +opposite-involutive : Involutive opposite +opposite-involutive = selfInverse⇒involutive opposite-selfInverse + +opposite-injective : Injective _≡_ _≡_ opposite +opposite-injective = selfInverse⇒injective opposite-selfInverse + + +------------------------------------------------------------------------ +-- other properties of opposite + +s≢opposite[s] : ∀ s → s ≢ opposite s +s≢opposite[s] - () +s≢opposite[s] + () + +------------------------------------------------------------------------ +-- _*_ + +-- Algebraic properties of _*_ + +s*s≡+ : ∀ s → s * s ≡ + +s*s≡+ + = refl +s*s≡+ - = refl + +*-identityˡ : LeftIdentity + _*_ +*-identityˡ _ = refl + +*-identityʳ : RightIdentity + _*_ +*-identityʳ - = refl +*-identityʳ + = refl + +*-identity : Identity + _*_ +*-identity = *-identityˡ , *-identityʳ + +*-comm : Commutative _*_ +*-comm + + = refl +*-comm + - = refl +*-comm - + = refl +*-comm - - = refl + +*-assoc : Associative _*_ +*-assoc + + _ = refl +*-assoc + - _ = refl +*-assoc - + _ = refl +*-assoc - - + = refl +*-assoc - - - = refl + +*-cancelʳ-≡ : RightCancellative _*_ +*-cancelʳ-≡ _ - - _ = refl +*-cancelʳ-≡ _ - + eq = ⊥-elim (s≢opposite[s] _ $ sym eq) +*-cancelʳ-≡ _ + - eq = ⊥-elim (s≢opposite[s] _ eq) +*-cancelʳ-≡ _ + + _ = refl + +*-cancelˡ-≡ : LeftCancellative _*_ +*-cancelˡ-≡ - _ _ eq = opposite-injective eq +*-cancelˡ-≡ + _ _ eq = eq + +*-cancel-≡ : Cancellative _*_ +*-cancel-≡ = *-cancelˡ-≡ , *-cancelʳ-≡ + +*-inverse : Inverse + id _*_ +*-inverse = s*s≡+ , s*s≡+ + +*-isMagma : IsMagma _*_ +*-isMagma = record + { isEquivalence = isEquivalence + ; ∙-cong = cong₂ _*_ + } + +*-magma : Magma 0ℓ 0ℓ +*-magma = record + { isMagma = *-isMagma + } + +*-isSemigroup : IsSemigroup _*_ +*-isSemigroup = record + { isMagma = *-isMagma + ; assoc = *-assoc + } + +*-semigroup : Semigroup 0ℓ 0ℓ +*-semigroup = record + { isSemigroup = *-isSemigroup + } + +*-isCommutativeSemigroup : IsCommutativeSemigroup _*_ +*-isCommutativeSemigroup = record + { isSemigroup = *-isSemigroup + ; comm = *-comm + } + +*-commutativeSemigroup : CommutativeSemigroup 0ℓ 0ℓ +*-commutativeSemigroup = record + { isCommutativeSemigroup = *-isCommutativeSemigroup + } + +*-isMonoid : IsMonoid _*_ + +*-isMonoid = record + { isSemigroup = *-isSemigroup + ; identity = *-identity + } + +*-monoid : Monoid 0ℓ 0ℓ +*-monoid = record + { isMonoid = *-isMonoid + } + +*-isCommutativeMonoid : IsCommutativeMonoid _*_ + +*-isCommutativeMonoid = record + { isMonoid = *-isMonoid + ; comm = *-comm + } + +*-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ +*-commutativeMonoid = record + { isCommutativeMonoid = *-isCommutativeMonoid + } + +*-isGroup : IsGroup _*_ + id +*-isGroup = record + { isMonoid = *-isMonoid + ; inverse = *-inverse + ; ⁻¹-cong = id + } + +*-group : Group 0ℓ 0ℓ +*-group = record + { isGroup = *-isGroup + } + +*-isAbelianGroup : IsAbelianGroup _*_ + id +*-isAbelianGroup = record + { isGroup = *-isGroup + ; comm = *-comm + } + +*-abelianGroup : AbelianGroup 0ℓ 0ℓ +*-abelianGroup = record + { isAbelianGroup = *-isAbelianGroup + } + +-- Other properties of _*_ + +s*opposite[s]≡- : ∀ s → s * opposite s ≡ - +s*opposite[s]≡- + = refl +s*opposite[s]≡- - = refl + +opposite[s]*s≡- : ∀ s → opposite s * s ≡ - +opposite[s]*s≡- + = refl +opposite[s]*s≡- - = refl \ No newline at end of file diff --git a/Data.Sign.html b/Data.Sign.html index 7fea3050..d90a5afc 100644 --- a/Data.Sign.html +++ b/Data.Sign.html @@ -14,5 +14,5 @@ open import Data.Sign.Base public open import Data.Sign.Properties public - using (_≟_) + using (_≟_) \ No newline at end of file diff --git a/Data.String.Base.html b/Data.String.Base.html index 66ce5cbf..0b4a367f 100644 --- a/Data.String.Base.html +++ b/Data.String.Base.html @@ -9,182 +9,181 @@ module Data.String.Base where -open import Level using (zero) -open import Data.Bool.Base using (Bool; true; false) -open import Data.Char.Base as Char using (Char) -open import Data.List.Base as List using (List; [_]; _∷_; []) -open import Data.List.NonEmpty.Base as NE using (List⁺) -open import Data.List.Relation.Binary.Pointwise.Base using (Pointwise) -open import Data.List.Relation.Binary.Lex.Core using (Lex-<; Lex-≤) -open import Data.Maybe.Base as Maybe using (Maybe) -open import Data.Nat.Base using (ℕ; _∸_; ⌊_/2⌋; ⌈_/2⌉) -open import Data.Product using (proj₁; proj₂) -open import Function.Base using (_on_; _∘′_; _∘_) -open import Level using (Level) -open import Relation.Binary.Core using (Rel) -open import Relation.Binary.PropositionalEquality.Core using (_≡_; refl) -open import Relation.Unary using (Pred; Decidable) -open import Relation.Nullary.Decidable using (does) +open import Data.Bool.Base using (Bool; true; false) +open import Data.Char.Base as Char using (Char) +open import Data.List.Base as List using (List; [_]; _∷_; []) +open import Data.List.NonEmpty.Base as NE using (List⁺) +open import Data.List.Relation.Binary.Pointwise.Base using (Pointwise) +open import Data.List.Relation.Binary.Lex.Core using (Lex-<; Lex-≤) +open import Data.Maybe.Base as Maybe using (Maybe) +open import Data.Nat.Base using (ℕ; _∸_; ⌊_/2⌋; ⌈_/2⌉) +open import Data.Product.Base using (proj₁; proj₂) +open import Function.Base using (_on_; _∘′_; _∘_) +open import Level using (Level; 0ℓ) +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.PropositionalEquality.Core using (_≡_; refl) +open import Relation.Unary using (Pred; Decidable) +open import Relation.Nullary.Decidable.Core using (does; T?) ------------------------------------------------------------------------- --- From Agda.Builtin: type and renamed primitives +------------------------------------------------------------------------ +-- From Agda.Builtin: type and renamed primitives --- Note that we do not re-export primStringAppend because we want to --- give it an infix definition and be able to assign it a level. +-- Note that we do not re-export primStringAppend because we want to +-- give it an infix definition and be able to assign it a level. -import Agda.Builtin.String as String +import Agda.Builtin.String as String -open String public using ( String ) - renaming - ( primStringUncons to uncons - ; primStringToList to toList - ; primStringFromList to fromList - ; primShowString to show - ) +open String public using ( String ) + renaming + ( primStringUncons to uncons + ; primStringToList to toList + ; primStringFromList to fromList + ; primShowString to show + ) ------------------------------------------------------------------------- --- Relations +------------------------------------------------------------------------ +-- Relations --- Pointwise equality on Strings +-- Pointwise equality on Strings -infix 4 _≈_ -_≈_ : Rel String zero -_≈_ = Pointwise _≡_ on toList +infix 4 _≈_ +_≈_ : Rel String 0ℓ +_≈_ = Pointwise _≡_ on toList --- Lexicographic ordering on Strings +-- Lexicographic ordering on Strings -infix 4 _<_ -_<_ : Rel String zero -_<_ = Lex-< _≡_ Char._<_ on toList +infix 4 _<_ +_<_ : Rel String 0ℓ +_<_ = Lex-< _≡_ Char._<_ on toList -infix 4 _≤_ -_≤_ : Rel String zero -_≤_ = Lex-≤ _≡_ Char._<_ on toList +infix 4 _≤_ +_≤_ : Rel String 0ℓ +_≤_ = Lex-≤ _≡_ Char._<_ on toList ------------------------------------------------------------------------- --- Operations +------------------------------------------------------------------------ +-- Operations --- List-like operations +-- List-like operations -head : String → Maybe Char -head = Maybe.map proj₁ ∘′ uncons +head : String → Maybe Char +head = Maybe.map proj₁ ∘′ uncons -tail : String → Maybe String -tail = Maybe.map proj₂ ∘′ uncons +tail : String → Maybe String +tail = Maybe.map proj₂ ∘′ uncons --- Additional conversion functions +-- Additional conversion functions -fromChar : Char → String -fromChar = fromList ∘′ [_] +fromChar : Char → String +fromChar = fromList ∘′ [_] -fromList⁺ : List⁺ Char → String -fromList⁺ = fromList ∘′ NE.toList +fromList⁺ : List⁺ Char → String +fromList⁺ = fromList ∘′ NE.toList --- List-like functions +-- List-like functions -infixr 5 _++_ -_++_ : String → String → String -_++_ = String.primStringAppend +infixr 5 _++_ +_++_ : String → String → String +_++_ = String.primStringAppend -length : String → ℕ -length = List.length ∘ toList +length : String → ℕ +length = List.length ∘ toList -replicate : ℕ → Char → String -replicate n = fromList ∘ List.replicate n +replicate : ℕ → Char → String +replicate n = fromList ∘ List.replicate n -concat : List String → String -concat = List.foldr _++_ "" +concat : List String → String +concat = List.foldr _++_ "" -intersperse : String → List String → String -intersperse sep = concat ∘′ (List.intersperse sep) +intersperse : String → List String → String +intersperse sep = concat ∘′ (List.intersperse sep) -unwords : List String → String -unwords = intersperse " " +unwords : List String → String +unwords = intersperse " " -unlines : List String → String -unlines = intersperse "\n" +unlines : List String → String +unlines = intersperse "\n" -parens : String → String -parens s = "(" ++ s ++ ")" +parens : String → String +parens s = "(" ++ s ++ ")" -braces : String → String -braces s = "{" ++ s ++ "}" +braces : String → String +braces s = "{" ++ s ++ "}" --- append that also introduces spaces, if necessary -infixr 5 _<+>_ -_<+>_ : String → String → String -"" <+> b = b -a <+> "" = a -a <+> b = a ++ " " ++ b +-- append that also introduces spaces, if necessary +infixr 5 _<+>_ +_<+>_ : String → String → String +"" <+> b = b +a <+> "" = a +a <+> b = a ++ " " ++ b ------------------------------------------------------------------------- --- Padding +------------------------------------------------------------------------ +-- Padding --- Each one of the padding functions should verify the following --- invariant: --- If length str ≤ n then length (padLeft c n str) ≡ n --- and otherwise padLeft c n str ≡ str. +-- Each one of the padding functions should verify the following +-- invariant: +-- If length str ≤ n then length (padLeft c n str) ≡ n +-- and otherwise padLeft c n str ≡ str. --- Appending an empty string is expensive (append for Haskell's --- Text creates a fresh Text value in which both contents are --- copied) so we precompute `n ∸ length str` and check whether --- it is equal to 0. +-- Appending an empty string is expensive (append for Haskell's +-- Text creates a fresh Text value in which both contents are +-- copied) so we precompute `n ∸ length str` and check whether +-- it is equal to 0. -padLeft : Char → ℕ → String → String -padLeft c n str with n ∸ length str -... | 0 = str -... | l = replicate l c ++ str +padLeft : Char → ℕ → String → String +padLeft c n str with n ∸ length str +... | 0 = str +... | l = replicate l c ++ str -padRight : Char → ℕ → String → String -padRight c n str with n ∸ length str -... | 0 = str -... | l = str ++ replicate l c +padRight : Char → ℕ → String → String +padRight c n str with n ∸ length str +... | 0 = str +... | l = str ++ replicate l c -padBoth : Char → Char → ℕ → String → String -padBoth cₗ cᵣ n str with n ∸ length str -... | 0 = str -... | l = replicate ⌊ l /2⌋ cₗ ++ str ++ replicate ⌈ l /2⌉ cᵣ +padBoth : Char → Char → ℕ → String → String +padBoth cₗ cᵣ n str with n ∸ length str +... | 0 = str +... | l = replicate ⌊ l /2⌋ cₗ ++ str ++ replicate ⌈ l /2⌉ cᵣ ------------------------------------------------------------------------- --- Alignment +------------------------------------------------------------------------ +-- Alignment --- We can align a String left, center or right in a column of a given --- width by padding it with whitespace. +-- We can align a String left, center or right in a column of a given +-- width by padding it with whitespace. -data Alignment : Set where - Left Center Right : Alignment +data Alignment : Set where + Left Center Right : Alignment -fromAlignment : Alignment → ℕ → String → String -fromAlignment Left = padRight ' ' -fromAlignment Center = padBoth ' ' ' ' -fromAlignment Right = padLeft ' ' +fromAlignment : Alignment → ℕ → String → String +fromAlignment Left = padRight ' ' +fromAlignment Center = padBoth ' ' ' ' +fromAlignment Right = padLeft ' ' ------------------------------------------------------------------------- --- Splitting strings +------------------------------------------------------------------------ +-- Splitting strings -wordsByᵇ : (Char → Bool) → String → List String -wordsByᵇ p = List.map fromList ∘ List.wordsByᵇ p ∘ toList +wordsBy : ∀ {p} {P : Pred Char p} → Decidable P → String → List String +wordsBy P? = List.map fromList ∘ List.wordsBy P? ∘ toList -wordsBy : ∀ {p} {P : Pred Char p} → Decidable P → String → List String -wordsBy P? = wordsByᵇ (does ∘ P?) +wordsByᵇ : (Char → Bool) → String → List String +wordsByᵇ p = wordsBy (T? ∘ p) -words : String → List String -words = wordsByᵇ Char.isSpace +words : String → List String +words = wordsByᵇ Char.isSpace --- `words` ignores contiguous whitespace -_ : words " abc b " ≡ "abc" ∷ "b" ∷ [] -_ = refl +-- `words` ignores contiguous whitespace +_ : words " abc b " ≡ "abc" ∷ "b" ∷ [] +_ = refl -linesByᵇ : (Char → Bool) → String → List String -linesByᵇ p = List.map fromList ∘ List.linesByᵇ p ∘ toList +linesBy : ∀ {p} {P : Pred Char p} → Decidable P → String → List String +linesBy P? = List.map fromList ∘ List.linesBy P? ∘ toList -linesBy : ∀ {p} {P : Pred Char p} → Decidable P → String → List String -linesBy P? = linesByᵇ (does ∘ P?) +linesByᵇ : (Char → Bool) → String → List String +linesByᵇ p = linesBy (T? ∘ p) -lines : String → List String -lines = linesByᵇ ('\n' Char.≈ᵇ_) +lines : String → List String +lines = linesByᵇ ('\n' Char.≈ᵇ_) --- `lines` preserves empty lines -_ : lines "\nabc\n\nb\n\n\n" ≡ "" ∷ "abc" ∷ "" ∷ "b" ∷ "" ∷ "" ∷ [] -_ = refl +-- `lines` preserves empty lines +_ : lines "\nabc\n\nb\n\n\n" ≡ "" ∷ "abc" ∷ "" ∷ "b" ∷ "" ∷ "" ∷ [] +_ = refl \ No newline at end of file diff --git a/Data.String.Properties.html b/Data.String.Properties.html deleted file mode 100644 index 21730cbe..00000000 --- a/Data.String.Properties.html +++ /dev/null @@ -1,173 +0,0 @@ - -Data.String.Properties
------------------------------------------------------------------------
--- The Agda standard library
---
--- Properties of operations on strings
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-module Data.String.Properties where
-
-open import Data.Bool.Base using (Bool)
-import Data.Char.Properties as Charₚ
-import Data.List.Properties as Listₚ
-import Data.List.Relation.Binary.Pointwise as Pointwise
-import Data.List.Relation.Binary.Lex.Strict as StrictLex
-open import Data.String.Base
-open import Function.Base
-open import Relation.Nullary.Decidable using (yes; no)
-open import Relation.Nullary.Decidable using (map′; isYes)
-open import Relation.Binary
-open import Relation.Binary.PropositionalEquality.Core
-import Relation.Binary.Construct.On as On
-import Relation.Binary.PropositionalEquality as PropEq
-
-------------------------------------------------------------------------
--- Primitive properties
-
-open import Agda.Builtin.String.Properties public
-  renaming ( primStringToListInjective to toList-injective)
-
-------------------------------------------------------------------------
--- Properties of _≈_
-
-≈⇒≡ : _≈_ ⇒ _≡_
-≈⇒≡ = toList-injective _ _
-    ∘ Pointwise.Pointwise-≡⇒≡
-
-≈-reflexive : _≡_ ⇒ _≈_
-≈-reflexive = Pointwise.≡⇒Pointwise-≡
-            ∘ cong toList
-
-≈-refl : Reflexive _≈_
-≈-refl {x} = ≈-reflexive {x} {x} refl
-
-≈-sym : Symmetric _≈_
-≈-sym = Pointwise.symmetric sym
-
-≈-trans : Transitive _≈_
-≈-trans = Pointwise.transitive trans
-
-≈-subst : ∀ {ℓ} → Substitutive _≈_ ℓ
-≈-subst P x≈y p = subst P (≈⇒≡ x≈y) p
-
-infix 4 _≈?_
-_≈?_ : Decidable _≈_
-x ≈? y = Pointwise.decidable Charₚ._≟_ (toList x) (toList y)
-
-≈-isEquivalence : IsEquivalence _≈_
-≈-isEquivalence = record
-  { refl  = λ {i} → ≈-refl {i}
-  ; sym   = λ {i j} → ≈-sym {i} {j}
-  ; trans = λ {i j k} → ≈-trans {i} {j} {k}
-  }
-
-≈-setoid : Setoid _ _
-≈-setoid = record
-  { isEquivalence = ≈-isEquivalence
-  }
-
-≈-isDecEquivalence : IsDecEquivalence _≈_
-≈-isDecEquivalence = record
-  { isEquivalence = ≈-isEquivalence
-  ; _≟_           = _≈?_
-  }
-
-≈-decSetoid : DecSetoid _ _
-≈-decSetoid = record
-  { isDecEquivalence = ≈-isDecEquivalence
-  }
-
------------------------------------------------------------------------
--- Properties of _≡_
-
-infix 4 _≟_
-
-_≟_ : Decidable _≡_
-x ≟ y = map′ ≈⇒≡ ≈-reflexive $ x ≈? y
-
-≡-setoid : Setoid _ _
-≡-setoid = PropEq.setoid String
-
-≡-decSetoid : DecSetoid _ _
-≡-decSetoid = PropEq.decSetoid _≟_
-
-------------------------------------------------------------------------
--- Properties of _<_
-
-infix 4 _<?_
-_<?_ : Decidable _<_
-x <? y = StrictLex.<-decidable Charₚ._≟_ Charₚ._<?_ (toList x) (toList y)
-
-<-isStrictPartialOrder-≈ : IsStrictPartialOrder _≈_ _<_
-<-isStrictPartialOrder-≈ =
-  On.isStrictPartialOrder
-    toList
-    (StrictLex.<-isStrictPartialOrder Charₚ.<-isStrictPartialOrder)
-
-<-isStrictTotalOrder-≈ : IsStrictTotalOrder _≈_ _<_
-<-isStrictTotalOrder-≈ =
-  On.isStrictTotalOrder
-    toList
-    (StrictLex.<-isStrictTotalOrder Charₚ.<-isStrictTotalOrder)
-
-<-strictPartialOrder-≈ : StrictPartialOrder _ _ _
-<-strictPartialOrder-≈ =
-  On.strictPartialOrder
-    (StrictLex.<-strictPartialOrder Charₚ.<-strictPartialOrder)
-    toList
-
-<-strictTotalOrder-≈ : StrictTotalOrder _ _ _
-<-strictTotalOrder-≈ =
-  On.strictTotalOrder
-    (StrictLex.<-strictTotalOrder Charₚ.<-strictTotalOrder)
-    toList
-
-≤-isDecPartialOrder-≈ : IsDecPartialOrder _≈_ _≤_
-≤-isDecPartialOrder-≈ =
-  On.isDecPartialOrder
-    toList
-    (StrictLex.≤-isDecPartialOrder Charₚ.<-isStrictTotalOrder)
-
-≤-isDecTotalOrder-≈ : IsDecTotalOrder _≈_ _≤_
-≤-isDecTotalOrder-≈ =
-  On.isDecTotalOrder
-    toList
-    (StrictLex.≤-isDecTotalOrder Charₚ.<-isStrictTotalOrder)
-
-≤-decTotalOrder-≈ :  DecTotalOrder _ _ _
-≤-decTotalOrder-≈ =
-  On.decTotalOrder
-    (StrictLex.≤-decTotalOrder Charₚ.<-strictTotalOrder)
-    toList
-
-≤-decPoset-≈ : DecPoset _ _ _
-≤-decPoset-≈ =
-  On.decPoset
-    (StrictLex.≤-decPoset Charₚ.<-strictTotalOrder)
-    toList
-
-------------------------------------------------------------------------
--- Alternative Boolean equality test.
---
--- Why is the definition _==_ = primStringEquality not used? One
--- reason is that the present definition can sometimes improve type
--- inference, at least with the version of Agda that is current at the
--- time of writing: see unit-test below.
-
-infix 4 _==_
-_==_ : String → String → Bool
-s₁ == s₂ = isYes (s₁ ≟ s₂)
-
-private
-
-  -- The following unit test does not type-check (at the time of
-  -- writing) if _==_ is replaced by primStringEquality.
-
-  data P : (String → Bool) → Set where
-    p : (c : String) → P (_==_ c)
-
-  unit-test : P (_==_ "")
-  unit-test = p _
-
\ No newline at end of file diff --git a/Data.String.html b/Data.String.html deleted file mode 100644 index f63c46b2..00000000 --- a/Data.String.html +++ /dev/null @@ -1,82 +0,0 @@ - -Data.String
------------------------------------------------------------------------
--- The Agda standard library
---
--- Strings
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-module Data.String where
-
-open import Data.Bool using (true; false; T?)
-open import Data.Char as Char using (Char)
-open import Function.Base
-open import Data.Nat.Base as ℕ using (ℕ; _∸_; ⌊_/2⌋; ⌈_/2⌉)
-import Data.Nat.Properties as ℕₚ
-open import Data.List.Base as List using (List; _∷_; []; [_])
-open import Data.List.NonEmpty as NE using (List⁺)
-open import Data.List.Extrema ℕₚ.≤-totalOrder
-open import Data.List.Relation.Binary.Pointwise using (Pointwise)
-open import Data.List.Relation.Binary.Lex.Strict using (Lex-<; Lex-≤)
-open import Data.Vec.Base as Vec using (Vec)
-open import Data.Char.Base as Char using (Char)
-import Data.Char.Properties as Char using (_≟_)
-open import Function
-open import Relation.Binary using (Rel)
-open import Relation.Binary.PropositionalEquality using (_≡_; refl)
-open import Relation.Nullary.Decidable using (does)
-open import Relation.Unary using (Pred; Decidable)
-
-open import Data.List.Membership.DecPropositional Char._≟_
-
-
-
-------------------------------------------------------------------------
--- Re-export contents of base, and decidability of equality
-
-open import Data.String.Base public
-open import Data.String.Properties using (_≈?_; _≟_; _<?_; _==_) public
-
-------------------------------------------------------------------------
--- Conversion functions
-
-toVec : (s : String) → Vec Char (length s)
-toVec s = Vec.fromList (toList s)
-
-fromVec : ∀ {n} → Vec Char n → String
-fromVec = fromList ∘ Vec.toList
-
-
--- enclose string with parens if it contains a space character
-parensIfSpace : String → String
-parensIfSpace s with does (' ' ∈? toList s)
-... | true  = parens s
-... | false = s
-
-
-------------------------------------------------------------------------
--- Rectangle
-
--- Build a rectangular column by:
--- Given a vector of cells and a padding function for each one
--- Compute the max of the widths, and pad the strings accordingly.
-
-rectangle : ∀ {n} → Vec (ℕ → String → String) n →
-            Vec String n → Vec String n
-rectangle pads cells = Vec.zipWith (λ p c → p width c) pads cells where
-
-  sizes = List.map length (Vec.toList cells)
-  width = max 0 sizes
-
--- Special cases for left, center, and right alignment
-
-rectangleˡ : ∀ {n} → Char → Vec String n → Vec String n
-rectangleˡ c = rectangle (Vec.replicate $ padLeft c)
-
-rectangleʳ : ∀ {n} → Char → Vec String n → Vec String n
-rectangleʳ c = rectangle (Vec.replicate $ padRight c)
-
-rectangleᶜ : ∀ {n} → Char → Char → Vec String n → Vec String n
-rectangleᶜ cₗ cᵣ = rectangle (Vec.replicate $ padBoth cₗ cᵣ)
-
\ No newline at end of file diff --git a/Data.Sum.Algebra.html b/Data.Sum.Algebra.html index 5f72bbb1..163665e9 100644 --- a/Data.Sum.Algebra.html +++ b/Data.Sum.Algebra.html @@ -11,115 +11,108 @@ open import Algebra open import Data.Empty.Polymorphic using (⊥) -open import Data.Product using (_,_) -open import Data.Sum.Base -open import Data.Sum.Properties -open import Data.Unit.Polymorphic using (⊤; tt) -open import Function.Base using (id; _∘_) -open import Function.Properties.Inverse using (↔-isEquivalence) -open import Function.Bundles using (_↔_; Inverse; mk↔′) -open import Level using (Level; suc) -open import Relation.Binary.PropositionalEquality.Core - using (_≡_; refl; cong; cong′) - -import Function.Definitions as FuncDef - ------------------------------------------------------------------------- --- Setup - -private - variable - a b c d : Level - A : Set a - B : Set b - C : Set c - D : Set d - - -- The module is needed because we need to pass `A` and `B` to `FuncDef` - module _ {A : Set a} {B : Set b} where - open FuncDef {A = A} {B} _≡_ _≡_ - - ♯ : {B : ⊥ {a} → Set b} → (w : ⊥) → B w - ♯ () - ------------------------------------------------------------------------- --- Algebraic properties - -⊎-cong : A ↔ B → C ↔ D → (A ⊎ C) ↔ (B ⊎ D) -⊎-cong i j = mk↔′ (map I.to J.to) (map I.from J.from) - [ cong inj₁ ∘ I.inverseˡ , cong inj₂ ∘ J.inverseˡ ] - [ cong inj₁ ∘ I.inverseʳ , cong inj₂ ∘ J.inverseʳ ] - where module I = Inverse i; module J = Inverse j - --- ⊎ is commutative. --- We don't use Commutative because it isn't polymorphic enough. -⊎-comm : (A : Set a) (B : Set b) → (A ⊎ B) ↔ (B ⊎ A) -⊎-comm _ _ = mk↔′ swap swap swap-involutive swap-involutive - -module _ (ℓ : Level) where - - -- ⊎ is associative - ⊎-assoc : Associative {ℓ = ℓ} _↔_ _⊎_ - ⊎-assoc _ _ _ = mk↔′ assocʳ assocˡ - [ cong′ , [ cong′ , cong′ ] ] [ [ cong′ , cong′ ] , cong′ ] - - -- ⊥ is an identity for ⊎ - ⊎-identityˡ : LeftIdentity {ℓ = ℓ} _↔_ ⊥ _⊎_ - ⊎-identityˡ A = mk↔′ [ ♯ , id ] inj₂ cong′ [ ♯ , cong′ ] - - ⊎-identityʳ : RightIdentity {ℓ = ℓ} _↔_ ⊥ _⊎_ - ⊎-identityʳ _ = mk↔′ [ id , ♯ ] inj₁ cong′ [ cong′ , ♯ ] - - ⊎-identity : Identity _↔_ ⊥ _⊎_ - ⊎-identity = ⊎-identityˡ , ⊎-identityʳ - ------------------------------------------------------------------------- --- Algebraic structures - - ⊎-isMagma : IsMagma {ℓ = ℓ} _↔_ _⊎_ - ⊎-isMagma = record - { isEquivalence = ↔-isEquivalence - ; ∙-cong = ⊎-cong - } - - ⊎-isSemigroup : IsSemigroup _↔_ _⊎_ - ⊎-isSemigroup = record - { isMagma = ⊎-isMagma - ; assoc = ⊎-assoc - } - - ⊎-isMonoid : IsMonoid _↔_ _⊎_ ⊥ - ⊎-isMonoid = record - { isSemigroup = ⊎-isSemigroup - ; identity = ⊎-identityˡ , ⊎-identityʳ - } - - ⊎-isCommutativeMonoid : IsCommutativeMonoid _↔_ _⊎_ ⊥ - ⊎-isCommutativeMonoid = record - { isMonoid = ⊎-isMonoid - ; comm = ⊎-comm - } - ------------------------------------------------------------------------- --- Algebraic bundles - - ⊎-magma : Magma (suc ℓ) ℓ - ⊎-magma = record - { isMagma = ⊎-isMagma - } - - ⊎-semigroup : Semigroup (suc ℓ) ℓ - ⊎-semigroup = record - { isSemigroup = ⊎-isSemigroup - } - - ⊎-monoid : Monoid (suc ℓ) ℓ - ⊎-monoid = record - { isMonoid = ⊎-isMonoid - } - - ⊎-commutativeMonoid : CommutativeMonoid (suc ℓ) ℓ - ⊎-commutativeMonoid = record - { isCommutativeMonoid = ⊎-isCommutativeMonoid - } +open import Data.Product.Base using (_,_) +open import Data.Sum.Base +open import Data.Sum.Properties +open import Data.Unit.Polymorphic using (⊤; tt) +open import Function.Base using (id; _∘_) +open import Function.Properties.Inverse using (↔-isEquivalence) +open import Function.Bundles using (_↔_; Inverse; mk↔ₛ′) +open import Level using (Level; suc) +open import Relation.Binary.PropositionalEquality.Core + using (_≡_; refl; cong; cong′) + +import Function.Definitions as FuncDef + +------------------------------------------------------------------------ +-- Setup + +private + variable + a b c d : Level + A B C D : Set a + + ♯ : {B : ⊥ {a} → Set b} → (w : ⊥) → B w + ♯ () + +------------------------------------------------------------------------ +-- Algebraic properties + +⊎-cong : A ↔ B → C ↔ D → (A ⊎ C) ↔ (B ⊎ D) +⊎-cong i j = mk↔ₛ′ (map I.to J.to) (map I.from J.from) + [ cong inj₁ ∘ I.strictlyInverseˡ , cong inj₂ ∘ J.strictlyInverseˡ ] + [ cong inj₁ ∘ I.strictlyInverseʳ , cong inj₂ ∘ J.strictlyInverseʳ ] + where module I = Inverse i; module J = Inverse j + +-- ⊎ is commutative. +-- We don't use Commutative because it isn't polymorphic enough. +⊎-comm : (A : Set a) (B : Set b) → (A ⊎ B) ↔ (B ⊎ A) +⊎-comm _ _ = mk↔ₛ′ swap swap swap-involutive swap-involutive + +module _ (ℓ : Level) where + + -- ⊎ is associative + ⊎-assoc : Associative {ℓ = ℓ} _↔_ _⊎_ + ⊎-assoc _ _ _ = mk↔ₛ′ assocʳ assocˡ + [ cong′ , [ cong′ , cong′ ] ] [ [ cong′ , cong′ ] , cong′ ] + + -- ⊥ is an identity for ⊎ + ⊎-identityˡ : LeftIdentity {ℓ = ℓ} _↔_ ⊥ _⊎_ + ⊎-identityˡ A = mk↔ₛ′ [ ♯ , id ] inj₂ cong′ [ ♯ , cong′ ] + + ⊎-identityʳ : RightIdentity {ℓ = ℓ} _↔_ ⊥ _⊎_ + ⊎-identityʳ _ = mk↔ₛ′ [ id , ♯ ] inj₁ cong′ [ cong′ , ♯ ] + + ⊎-identity : Identity _↔_ ⊥ _⊎_ + ⊎-identity = ⊎-identityˡ , ⊎-identityʳ + +------------------------------------------------------------------------ +-- Algebraic structures + + ⊎-isMagma : IsMagma {ℓ = ℓ} _↔_ _⊎_ + ⊎-isMagma = record + { isEquivalence = ↔-isEquivalence + ; ∙-cong = ⊎-cong + } + + ⊎-isSemigroup : IsSemigroup _↔_ _⊎_ + ⊎-isSemigroup = record + { isMagma = ⊎-isMagma + ; assoc = ⊎-assoc + } + + ⊎-isMonoid : IsMonoid _↔_ _⊎_ ⊥ + ⊎-isMonoid = record + { isSemigroup = ⊎-isSemigroup + ; identity = ⊎-identityˡ , ⊎-identityʳ + } + + ⊎-isCommutativeMonoid : IsCommutativeMonoid _↔_ _⊎_ ⊥ + ⊎-isCommutativeMonoid = record + { isMonoid = ⊎-isMonoid + ; comm = ⊎-comm + } + +------------------------------------------------------------------------ +-- Algebraic bundles + + ⊎-magma : Magma (suc ℓ) ℓ + ⊎-magma = record + { isMagma = ⊎-isMagma + } + + ⊎-semigroup : Semigroup (suc ℓ) ℓ + ⊎-semigroup = record + { isSemigroup = ⊎-isSemigroup + } + + ⊎-monoid : Monoid (suc ℓ) ℓ + ⊎-monoid = record + { isMonoid = ⊎-isMonoid + } + + ⊎-commutativeMonoid : CommutativeMonoid (suc ℓ) ℓ + ⊎-commutativeMonoid = record + { isCommutativeMonoid = ⊎-isCommutativeMonoid + } \ No newline at end of file diff --git a/Data.Sum.Base.html b/Data.Sum.Base.html index 61a8a81c..a2bbad4c 100644 --- a/Data.Sum.Base.html +++ b/Data.Sum.Base.html @@ -10,7 +10,7 @@ module Data.Sum.Base where open import Data.Bool.Base using (true; false) -open import Function.Base using (_∘_; _∘′_; _-⟪_⟫-_ ; id) +open import Function.Base using (_∘_; _∘′_; _-⟪_⟫-_ ; id) open import Level using (Level; _⊔_) private @@ -65,12 +65,12 @@ map₂ = map id assocʳ : (A ⊎ B) ⊎ C → A ⊎ B ⊎ C -assocʳ = [ map₂ inj₁ , inj₂ ∘′ inj₂ ]′ +assocʳ = [ map₂ inj₁ , inj₂ ∘′ inj₂ ]′ assocˡ : A ⊎ B ⊎ C → (A ⊎ B) ⊎ C -assocˡ = [ inj₁ ∘′ inj₁ , map₁ inj₂ ]′ +assocˡ = [ inj₁ ∘′ inj₁ , map₁ inj₂ ]′ infixr 1 _-⊎-_ _-⊎-_ : (A → B → Set c) → (A → B → Set d) → (A → B → Set (c ⊔ d)) -f -⊎- g = f -⟪ _⊎_ ⟫- g +f -⊎- g = f -⟪ _⊎_ ⟫- g \ No newline at end of file diff --git a/Data.Sum.Function.Propositional.html b/Data.Sum.Function.Propositional.html index 149fc6bb..e069698d 100644 --- a/Data.Sum.Function.Propositional.html +++ b/Data.Sum.Function.Propositional.html @@ -11,64 +11,73 @@ open import Data.Sum.Base open import Data.Sum.Function.Setoid -open import Data.Sum.Relation.Binary.Pointwise using (Pointwise-≡↔≡) -open import Function.Equivalence as Eq using (_⇔_; module Equivalence) -open import Function.Injection as Inj using (_↣_; module Injection) -open import Function.Inverse as Inv using (_↔_; module Inverse) -open import Function.LeftInverse as LeftInv - using (_↞_; _LeftInverseOf_; module LeftInverse) -open import Function.Related -open import Function.Surjection as Surj using (_↠_; module Surjection) - ------------------------------------------------------------------------- --- Combinators for various function types - -module _ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d} where - - _⊎-⇔_ : A ⇔ B → C ⇔ D → (A ⊎ C) ⇔ (B ⊎ D) - _⊎-⇔_ A⇔B C⇔D = - Inverse.equivalence (Pointwise-≡↔≡ B D) ⟨∘⟩ - (A⇔B ⊎-equivalence C⇔D) ⟨∘⟩ - Eq.sym (Inverse.equivalence (Pointwise-≡↔≡ A C)) - where open Eq using () renaming (_∘_ to _⟨∘⟩_) - - _⊎-↣_ : A ↣ B → C ↣ D → (A ⊎ C) ↣ (B ⊎ D) - _⊎-↣_ A↣B C↣D = - Inverse.injection (Pointwise-≡↔≡ B D) ⟨∘⟩ - (A↣B ⊎-injection C↣D) ⟨∘⟩ - Inverse.injection (Inv.sym (Pointwise-≡↔≡ A C)) - where open Inj using () renaming (_∘_ to _⟨∘⟩_) - - _⊎-↞_ : A ↞ B → C ↞ D → (A ⊎ C) ↞ (B ⊎ D) - _⊎-↞_ A↞B C↞D = - Inverse.left-inverse (Pointwise-≡↔≡ B D) ⟨∘⟩ - (A↞B ⊎-left-inverse C↞D) ⟨∘⟩ - Inverse.left-inverse (Inv.sym (Pointwise-≡↔≡ A C)) - where open LeftInv using () renaming (_∘_ to _⟨∘⟩_) - - _⊎-↠_ : A ↠ B → C ↠ D → (A ⊎ C) ↠ (B ⊎ D) - _⊎-↠_ A↠B C↠D = - Inverse.surjection (Pointwise-≡↔≡ B D) ⟨∘⟩ - (A↠B ⊎-surjection C↠D) ⟨∘⟩ - Inverse.surjection (Inv.sym (Pointwise-≡↔≡ A C)) - where open Surj using () renaming (_∘_ to _⟨∘⟩_) - - _⊎-↔_ : A ↔ B → C ↔ D → (A ⊎ C) ↔ (B ⊎ D) - _⊎-↔_ A↔B C↔D = - Pointwise-≡↔≡ B D ⟨∘⟩ - (A↔B ⊎-inverse C↔D) ⟨∘⟩ - Inv.sym (Pointwise-≡↔≡ A C) - where open Inv using () renaming (_∘_ to _⟨∘⟩_) - -module _ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d} where - - _⊎-cong_ : ∀ {k} → A ∼[ k ] B → C ∼[ k ] D → (A ⊎ C) ∼[ k ] (B ⊎ D) - _⊎-cong_ {implication} = map - _⊎-cong_ {reverse-implication} = λ f g → lam (map (app-← f) (app-← g)) - _⊎-cong_ {equivalence} = _⊎-⇔_ - _⊎-cong_ {injection} = _⊎-↣_ - _⊎-cong_ {reverse-injection} = λ f g → lam (app-↢ f ⊎-↣ app-↢ g) - _⊎-cong_ {left-inverse} = _⊎-↞_ - _⊎-cong_ {surjection} = _⊎-↠_ - _⊎-cong_ {bijection} = _⊎-↔_ +open import Data.Sum.Relation.Binary.Pointwise using (Pointwise-≡↔≡; _⊎ₛ_) +open import Function.Construct.Composition as Compose +open import Function.Related.Propositional +open import Function +open import Function.Properties.Inverse as Inv +open import Level using (Level; _⊔_) +open import Relation.Binary using (REL; Setoid) +open import Relation.Binary.PropositionalEquality using (setoid) + +private + variable + a b c d : Level + A B C D : Set a + + +------------------------------------------------------------------------ +-- Helper lemma + +private + liftViaInverse : {R : ∀ {a b ℓ₁ ℓ₂} → REL (Setoid a ℓ₁) (Setoid b ℓ₂) (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂)} → + (∀ {a b c ℓ₁ ℓ₂ ℓ₃} {S : Setoid a ℓ₁} {T : Setoid b ℓ₂} {U : Setoid c ℓ₃} → R S T → R T U → R S U) → + (∀ {a b ℓ₁ ℓ₂} {S : Setoid a ℓ₁} {T : Setoid b ℓ₂} → Inverse S T → R S T) → + (R (setoid A) (setoid C) → R (setoid B) (setoid D) → R (setoid A ⊎ₛ setoid B) (setoid C ⊎ₛ setoid D)) → + R (setoid A) (setoid C) → R (setoid B) (setoid D) → + R (setoid (A ⊎ B)) (setoid (C ⊎ D)) + liftViaInverse trans inv⇒R lift RAC RBD = + Inv.transportVia trans inv⇒R (Inv.sym (Pointwise-≡↔≡ _ _)) (lift RAC RBD) (Pointwise-≡↔≡ _ _) + +------------------------------------------------------------------------ +-- Combinators for various function types + +infixr 1 _⊎-⟶_ _⊎-⇔_ _⊎-↣_ _⊎-↩_ _⊎-↪_ _⊎-↔_ + +_⊎-⟶_ : A ⟶ B → C ⟶ D → (A ⊎ C) ⟶ (B ⊎ D) +_⊎-⟶_ = liftViaInverse Compose.function Inv.toFunction _⊎-function_ + + +_⊎-⇔_ : A ⇔ B → C ⇔ D → (A ⊎ C) ⇔ (B ⊎ D) +_⊎-⇔_ = liftViaInverse Compose.equivalence Inverse⇒Equivalence _⊎-equivalence_ + +_⊎-↣_ : A ↣ B → C ↣ D → (A ⊎ C) ↣ (B ⊎ D) +_⊎-↣_ = liftViaInverse Compose.injection Inverse⇒Injection _⊎-injection_ + +_⊎-↠_ : A ↠ B → C ↠ D → (A ⊎ C) ↠ (B ⊎ D) +_⊎-↠_ = liftViaInverse Compose.surjection Inverse⇒Surjection _⊎-surjection_ + +_⊎-↩_ : A ↩ B → C ↩ D → (A ⊎ C) ↩ (B ⊎ D) +_⊎-↩_ = liftViaInverse Compose.leftInverse Inverse.leftInverse _⊎-leftInverse_ + +_⊎-↪_ : A ↪ B → C ↪ D → (A ⊎ C) ↪ (B ⊎ D) +_⊎-↪_ = liftViaInverse Compose.rightInverse Inverse.rightInverse _⊎-rightInverse_ + +_⊎-⤖_ : A ⤖ B → C ⤖ D → (A ⊎ C) ⤖ (B ⊎ D) +_⊎-⤖_ = liftViaInverse Compose.bijection Inverse⇒Bijection _⊎-bijection_ + +_⊎-↔_ : A ↔ B → C ↔ D → (A ⊎ C) ↔ (B ⊎ D) +_⊎-↔_ = liftViaInverse Compose.inverse id _⊎-inverse_ + +infixr 1 _⊎-cong_ + +_⊎-cong_ : ∀ {k} → A ∼[ k ] B → C ∼[ k ] D → (A ⊎ C) ∼[ k ] (B ⊎ D) +_⊎-cong_ {k = implication} = _⊎-⟶_ +_⊎-cong_ {k = reverseImplication} = _⊎-⟶_ +_⊎-cong_ {k = equivalence} = _⊎-⇔_ +_⊎-cong_ {k = injection} = _⊎-↣_ +_⊎-cong_ {k = reverseInjection} = _⊎-↣_ +_⊎-cong_ {k = leftInverse} = _⊎-↪_ +_⊎-cong_ {k = surjection} = _⊎-↠_ +_⊎-cong_ {k = bijection} = _⊎-↔_ \ No newline at end of file diff --git a/Data.Sum.Function.Setoid.html b/Data.Sum.Function.Setoid.html index aa841397..ca750e5c 100644 --- a/Data.Sum.Function.Setoid.html +++ b/Data.Sum.Function.Setoid.html @@ -9,144 +9,168 @@ module Data.Sum.Function.Setoid where -open import Data.Sum.Base -open import Data.Sum.Relation.Binary.Pointwise -open import Relation.Binary -open import Function.Equality as F using (_⟶_; _⟨$⟩_) -open import Function.Equivalence as Eq - using (Equivalence; _⇔_; module Equivalence) -open import Function.Injection as Inj - using (Injection; _↣_; module Injection) -open import Function.Inverse as Inv - using (Inverse; _↔_; module Inverse) -open import Function.LeftInverse as LeftInv - using (LeftInverse; _↞_; _LeftInverseOf_; module LeftInverse) -open import Function.Related -open import Function.Surjection as Surj - using (Surjection; _↠_; module Surjection) - ------------------------------------------------------------------------- --- Combinators for equality preserving functions - -module _ {a₁ a₂ b₁ b₂ c₁ c₂ d₁ d₂} - {A : Setoid a₁ a₂} {B : Setoid b₁ b₂} - {C : Setoid c₁ c₂} {D : Setoid d₁ d₂} - where - - _⊎-⟶_ : (A ⟶ B) → (C ⟶ D) → (A ⊎ₛ C) ⟶ (B ⊎ₛ D) - _⊎-⟶_ f g = record - { _⟨$⟩_ = fg - ; cong = fg-cong - } - where - open Setoid (A ⊎ₛ C) using () renaming (_≈_ to _≈AC_) - open Setoid (B ⊎ₛ D) using () renaming (_≈_ to _≈BD_) - - fg = map (_⟨$⟩_ f) (_⟨$⟩_ g) - - fg-cong : _≈AC_ =[ fg ]⇒ _≈BD_ - fg-cong (inj₁ x∼₁y) = inj₁ (F.cong f x∼₁y) - fg-cong (inj₂ x∼₂y) = inj₂ (F.cong g x∼₂y) - -module _ {a₁ a₂ b₁ b₂} {A : Setoid a₁ a₂} {B : Setoid b₁ b₂} where - - inj₁ₛ : A ⟶ (A ⊎ₛ B) - inj₁ₛ = record { _⟨$⟩_ = inj₁ ; cong = inj₁ } - - inj₂ₛ : B ⟶ (A ⊎ₛ B) - inj₂ₛ = record { _⟨$⟩_ = inj₂ ; cong = inj₂ } - - [_,_]ₛ : ∀ {c₁ c₂} {C : Setoid c₁ c₂} → - (A ⟶ C) → (B ⟶ C) → (A ⊎ₛ B) ⟶ C - [ f , g ]ₛ = record - { _⟨$⟩_ = [ f ⟨$⟩_ , g ⟨$⟩_ ] - ; cong = λ where - (inj₁ x∼₁y) → F.cong f x∼₁y - (inj₂ x∼₂y) → F.cong g x∼₂y - } - -module _ {a₁ a₂ b₁ b₂} {A : Setoid a₁ a₂} {B : Setoid b₁ b₂} where - - swapₛ : (A ⊎ₛ B) ⟶ (B ⊎ₛ A) - swapₛ = [ inj₂ₛ , inj₁ₛ ]ₛ - ------------------------------------------------------------------------- --- Combinators for more complex function types - -module _ {a₁ a₂ b₁ b₂ c₁ c₂ d₁ d₂} - {A : Setoid a₁ a₂} {B : Setoid b₁ b₂} - {C : Setoid c₁ c₂} {D : Setoid d₁ d₂} - where - - _⊎-equivalence_ : Equivalence A B → Equivalence C D → - Equivalence (A ⊎ₛ C) (B ⊎ₛ D) - A⇔B ⊎-equivalence C⇔D = record - { to = to A⇔B ⊎-⟶ to C⇔D - ; from = from A⇔B ⊎-⟶ from C⇔D - } where open Equivalence - - _⊎-injection_ : Injection A B → Injection C D → - Injection (A ⊎ₛ C) (B ⊎ₛ D) - _⊎-injection_ A↣B C↣D = record - { to = to A↣B ⊎-⟶ to C↣D - ; injective = inj _ _ - } - where - open Injection - open Setoid (A ⊎ₛ C) using () renaming (_≈_ to _≈AC_) - open Setoid (B ⊎ₛ D) using () renaming (_≈_ to _≈BD_) - - inj : ∀ x y → - (to A↣B ⊎-⟶ to C↣D) ⟨$⟩ x ≈BD (to A↣B ⊎-⟶ to C↣D) ⟨$⟩ y → - x ≈AC y - inj (inj₁ x) (inj₁ y) (inj₁ x∼₁y) = inj₁ (injective A↣B x∼₁y) - inj (inj₂ x) (inj₂ y) (inj₂ x∼₂y) = inj₂ (injective C↣D x∼₂y) - - _⊎-left-inverse_ : LeftInverse A B → LeftInverse C D → - LeftInverse (A ⊎ₛ C) (B ⊎ₛ D) - A↞B ⊎-left-inverse C↞D = record - { to = Equivalence.to eq - ; from = Equivalence.from eq - ; left-inverse-of = [ (λ x → inj₁ (left-inverse-of A↞B x)) - , (λ x → inj₂ (left-inverse-of C↞D x)) ] - } - where - open LeftInverse - eq = LeftInverse.equivalence A↞B ⊎-equivalence - LeftInverse.equivalence C↞D - -module _ {a₁ a₂ b₁ b₂ c₁ c₂ d₁ d₂} - {A : Setoid a₁ a₂} {B : Setoid b₁ b₂} - {C : Setoid c₁ c₂} {D : Setoid d₁ d₂} - where - - _⊎-surjection_ : Surjection A B → Surjection C D → - Surjection (A ⊎ₛ C) (B ⊎ₛ D) - A↠B ⊎-surjection C↠D = record - { to = LeftInverse.from inv - ; surjective = record - { from = LeftInverse.to inv - ; right-inverse-of = LeftInverse.left-inverse-of inv - } - } - where - open Surjection - inv = right-inverse A↠B ⊎-left-inverse right-inverse C↠D - - _⊎-inverse_ : Inverse A B → Inverse C D → - Inverse (A ⊎ₛ C) (B ⊎ₛ D) - A↔B ⊎-inverse C↔D = record - { to = Surjection.to surj - ; from = Surjection.from surj - ; inverse-of = record - { left-inverse-of = LeftInverse.left-inverse-of inv - ; right-inverse-of = Surjection.right-inverse-of surj - } - } - where - open Inverse - surj = Inverse.surjection A↔B ⊎-surjection - Inverse.surjection C↔D - inv = Inverse.left-inverse A↔B ⊎-left-inverse - Inverse.left-inverse C↔D +open import Data.Product.Base as Prod using (_,_) +open import Data.Sum.Base as Sum +open import Data.Sum.Relation.Binary.Pointwise as Pointwise +open import Relation.Binary +open import Function.Base +open import Function.Bundles +open import Function.Definitions +open import Level + +private + variable + a₁ a₂ b₁ b₂ c₁ c₂ d₁ d₂ : Level + a ℓ : Level + A B C D : Set a + ≈₁ ≈₂ ≈₃ ≈₄ : Rel A ℓ + S T U V : Setoid a ℓ + +------------------------------------------------------------------------ +-- Combinators for equality preserving functions + +inj₁ₛ : Func S (S ⊎ₛ T) +inj₁ₛ = record { to = inj₁ ; cong = inj₁ } + +inj₂ₛ : Func T (S ⊎ₛ T) +inj₂ₛ = record { to = inj₂ ; cong = inj₂ } + +[_,_]ₛ : Func S U → Func T U → Func (S ⊎ₛ T) U +[ f , g ]ₛ = record + { to = [ to f , to g ] + ; cong = λ where + (inj₁ x∼₁y) → cong f x∼₁y + (inj₂ x∼₂y) → cong g x∼₂y + } where open Func + +swapₛ : Func (S ⊎ₛ T) (T ⊎ₛ S) +swapₛ = [ inj₂ₛ , inj₁ₛ ]ₛ + +------------------------------------------------------------------------ +-- Definitions + +⊎-injective : ∀ {f g} → + Injective ≈₁ ≈₂ f → + Injective ≈₃ ≈₄ g → + Injective (Pointwise ≈₁ ≈₃) (Pointwise ≈₂ ≈₄) (Sum.map f g) +⊎-injective f-inj g-inj {inj₁ x} {inj₁ y} (inj₁ x∼₁y) = inj₁ (f-inj x∼₁y) +⊎-injective f-inj g-inj {inj₂ x} {inj₂ y} (inj₂ x∼₂y) = inj₂ (g-inj x∼₂y) + +⊎-strictlySurjective : ∀ {f : A → B} {g : C → D} → + StrictlySurjective ≈₁ f → + StrictlySurjective ≈₂ g → + StrictlySurjective (Pointwise ≈₁ ≈₂) (Sum.map f g) +⊎-strictlySurjective f-sur g-sur = + [ Prod.map inj₁ inj₁ ∘ f-sur + , Prod.map inj₂ inj₂ ∘ g-sur + ] + +⊎-surjective : ∀ {f : A → B} {g : C → D} → + Surjective ≈₁ ≈₂ f → + Surjective ≈₃ ≈₄ g → + Surjective (Pointwise ≈₁ ≈₃) (Pointwise ≈₂ ≈₄) (Sum.map f g) +⊎-surjective f-sur g-sur = + [ Prod.map inj₁ (λ { fwd (inj₁ x) → inj₁ (fwd x)}) ∘ f-sur + , Prod.map inj₂ (λ { fwd (inj₂ y) → inj₂ (fwd y)}) ∘ g-sur + ] + + +infixr 1 _⊎-equivalence_ _⊎-injection_ _⊎-left-inverse_ + +------------------------------------------------------------------------ +-- Function bundles + +_⊎-function_ : Func S T → Func U V → Func (S ⊎ₛ U) (T ⊎ₛ V) +S→T ⊎-function U→V = record + { to = Sum.map (to S→T) (to U→V) + ; cong = Pointwise.map (cong S→T) (cong U→V) + } where open Func + +_⊎-equivalence_ : Equivalence S T → Equivalence U V → + Equivalence (S ⊎ₛ U) (T ⊎ₛ V) +S⇔T ⊎-equivalence U⇔V = record + { to = Sum.map (to S⇔T) (to U⇔V) + ; from = Sum.map (from S⇔T) (from U⇔V) + ; to-cong = Pointwise.map (to-cong S⇔T) (to-cong U⇔V) + ; from-cong = Pointwise.map (from-cong S⇔T) (from-cong U⇔V) + } where open Equivalence + +_⊎-injection_ : Injection S T → Injection U V → + Injection (S ⊎ₛ U) (T ⊎ₛ V) +S↣T ⊎-injection U↣V = record + { to = Sum.map (to S↣T) (to U↣V) + ; cong = Pointwise.map (cong S↣T) (cong U↣V) + ; injective = ⊎-injective (injective S↣T) (injective U↣V) + } where open Injection + +infixr 1 _⊎-surjection_ _⊎-inverse_ +_⊎-surjection_ : Surjection S T → Surjection U V → + Surjection (S ⊎ₛ U) (T ⊎ₛ V) +S↠T ⊎-surjection U↠V = record + { to = Sum.map (to S↠T) (to U↠V) + ; cong = Pointwise.map (cong S↠T) (cong U↠V) + ; surjective = ⊎-surjective (surjective S↠T) (surjective U↠V) + } where open Surjection + +_⊎-bijection_ : Bijection S T → Bijection U V → + Bijection (S ⊎ₛ U) (T ⊎ₛ V) +S⤖T ⊎-bijection U⤖V = record + { to = Sum.map (to S⤖T) (to U⤖V) + ; cong = Pointwise.map (cong S⤖T) (cong U⤖V) + ; bijective = ⊎-injective (injective S⤖T) (injective U⤖V) , + ⊎-surjective (surjective S⤖T) (surjective U⤖V) + } where open Bijection + +_⊎-leftInverse_ : LeftInverse S T → LeftInverse U V → + LeftInverse (S ⊎ₛ U) (T ⊎ₛ V) +S↩T ⊎-leftInverse U↩V = record + { to = Sum.map (to S↩T) (to U↩V) + ; from = Sum.map (from S↩T) (from U↩V) + ; to-cong = Pointwise.map (to-cong S↩T) (to-cong U↩V) + ; from-cong = Pointwise.map (from-cong S↩T) (from-cong U↩V) + ; inverseˡ = λ { {inj₁ _} {.(inj₁ _)} (inj₁ x) → inj₁ (inverseˡ S↩T x) + ; {inj₂ _} {.(inj₂ _)} (inj₂ x) → inj₂ (inverseˡ U↩V x)} + } where open LeftInverse + +_⊎-rightInverse_ : RightInverse S T → RightInverse U V → + RightInverse (S ⊎ₛ U) (T ⊎ₛ V) +S↪T ⊎-rightInverse U↪V = record + { to = Sum.map (to S↪T) (to U↪V) + ; from = Sum.map (from S↪T) (from U↪V) + ; to-cong = Pointwise.map (to-cong S↪T) (to-cong U↪V) + ; from-cong = Pointwise.map (from-cong S↪T) (from-cong U↪V) + ; inverseʳ = λ { {inj₁ _} (inj₁ x) → inj₁ (inverseʳ S↪T x) + ; {inj₂ _} (inj₂ x) → inj₂ (inverseʳ U↪V x) + } + } where open RightInverse + +_⊎-inverse_ : Inverse S T → Inverse U V → + Inverse (S ⊎ₛ U) (T ⊎ₛ V) +S↔T ⊎-inverse U↔V = record + { to = Sum.map (to S↔T) (to U↔V) + ; from = Sum.map (from S↔T) (from U↔V) + ; to-cong = Pointwise.map (to-cong S↔T) (to-cong U↔V) + ; from-cong = Pointwise.map (from-cong S↔T) (from-cong U↔V) + ; inverse = (λ { {inj₁ _} (inj₁ x) → inj₁ (inverseˡ S↔T x) + ; {inj₂ _} (inj₂ x) → inj₂ (inverseˡ U↔V x)}) , + λ { {inj₁ _} (inj₁ x) → inj₁ (inverseʳ S↔T x) + ; {inj₂ _} (inj₂ x) → inj₂ (inverseʳ U↔V x) + } + } where open Inverse + + + +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 2.0 + +_⊎-left-inverse_ = _⊎-leftInverse_ +{-# WARNING_ON_USAGE _⊎-left-inverse_ +"Warning: _⊎-left-inverse_ was deprecated in v2.0. +Please use _⊎-leftInverse_ instead." +#-} \ No newline at end of file diff --git a/Data.Sum.Properties.html b/Data.Sum.Properties.html index cbc0d468..84c06565 100644 --- a/Data.Sum.Properties.html +++ b/Data.Sum.Properties.html @@ -11,144 +11,144 @@ open import Level open import Data.Sum.Base -open import Function -open import Function.Bundles using (mk↔′) -open import Relation.Binary using (Decidable) -open import Relation.Binary.PropositionalEquality -open import Relation.Nullary.Decidable using (yes; no) -open import Relation.Nullary.Decidable using (map′) - - -private - variable - a b c d e f : Level - A : Set a - B : Set b - C : Set c - D : Set d - E : Set e - F : Set f - -inj₁-injective : ∀ {x y} → (A ⊎ B ∋ inj₁ x) ≡ inj₁ y → x ≡ y -inj₁-injective refl = refl - -inj₂-injective : ∀ {x y} → (A ⊎ B ∋ inj₂ x) ≡ inj₂ y → x ≡ y -inj₂-injective refl = refl - -module _ (dec₁ : Decidable {A = A} {B = A} _≡_) - (dec₂ : Decidable {A = B} {B = B} _≡_) where - - ≡-dec : Decidable {A = A ⊎ B} _≡_ - ≡-dec (inj₁ x) (inj₁ y) = map′ (cong inj₁) inj₁-injective (dec₁ x y) - ≡-dec (inj₁ x) (inj₂ y) = no λ() - ≡-dec (inj₂ x) (inj₁ y) = no λ() - ≡-dec (inj₂ x) (inj₂ y) = map′ (cong inj₂) inj₂-injective (dec₂ x y) - -swap-involutive : swap {A = A} {B = B} ∘ swap ≗ id -swap-involutive = [ (λ _ → refl) , (λ _ → refl) ] - -swap-↔ : (A ⊎ B) ↔ (B ⊎ A) -swap-↔ = mk↔′ swap swap swap-involutive swap-involutive - -map-id : map {A = A} {B = B} id id ≗ id -map-id (inj₁ _) = refl -map-id (inj₂ _) = refl - -[,]-∘ : (f : A → B) - {g : C → A} {h : D → A} → - f ∘ [ g , h ] ≗ [ f ∘ g , f ∘ h ] -[,]-∘ _ (inj₁ _) = refl -[,]-∘ _ (inj₂ _) = refl - -[,]-map : {f : A → B} {g : C → D} - {f′ : B → E} {g′ : D → E} → - [ f′ , g′ ] ∘ map f g ≗ [ f′ ∘ f , g′ ∘ g ] -[,]-map (inj₁ _) = refl -[,]-map (inj₂ _) = refl - -map-map : {f : A → B} {g : C → D} - {f′ : B → E} {g′ : D → F} → - map f′ g′ ∘ map f g ≗ map (f′ ∘ f) (g′ ∘ g) -map-map (inj₁ _) = refl -map-map (inj₂ _) = refl - -map₁₂-map₂₁ : {f : A → B} {g : C → D} → - map₁ f ∘ map₂ g ≗ map₂ g ∘ map₁ f -map₁₂-map₂₁ (inj₁ _) = refl -map₁₂-map₂₁ (inj₂ _) = refl - -map-assocˡ : (f : A → C) (g : B → D) (h : C → F) → - map (map f g) h ∘ assocˡ ≗ assocˡ ∘ map f (map g h) -map-assocˡ _ _ _ (inj₁ x ) = refl -map-assocˡ _ _ _ (inj₂ (inj₁ y)) = refl -map-assocˡ _ _ _ (inj₂ (inj₂ z)) = refl - -map-assocʳ : (f : A → C) (g : B → D) (h : C → F) → - map f (map g h) ∘ assocʳ ≗ assocʳ ∘ map (map f g) h -map-assocʳ _ _ _ (inj₁ (inj₁ x)) = refl -map-assocʳ _ _ _ (inj₁ (inj₂ y)) = refl -map-assocʳ _ _ _ (inj₂ z ) = refl - -[,]-cong : {f f′ : A → B} {g g′ : C → B} → - f ≗ f′ → g ≗ g′ → - [ f , g ] ≗ [ f′ , g′ ] -[,]-cong = [_,_] - -[-,]-cong : {f f′ : A → B} {g : C → B} → - f ≗ f′ → - [ f , g ] ≗ [ f′ , g ] -[-,]-cong = [_, (λ _ → refl) ] - -[,-]-cong : {f : A → B} {g g′ : C → B} → - g ≗ g′ → - [ f , g ] ≗ [ f , g′ ] -[,-]-cong = [ (λ _ → refl) ,_] - -map-cong : {f f′ : A → B} {g g′ : C → D} → - f ≗ f′ → g ≗ g′ → - map f g ≗ map f′ g′ -map-cong f≗f′ g≗g′ (inj₁ x) = cong inj₁ (f≗f′ x) -map-cong f≗f′ g≗g′ (inj₂ x) = cong inj₂ (g≗g′ x) - -map₁-cong : {f f′ : A → B} → - f ≗ f′ → - map₁ {B = C} f ≗ map₁ f′ -map₁-cong f≗f′ = [-,]-cong ((cong inj₁) ∘ f≗f′) - -map₂-cong : {g g′ : C → D} → - g ≗ g′ → - map₂ {A = A} g ≗ map₂ g′ -map₂-cong g≗g′ = [,-]-cong ((cong inj₂) ∘ g≗g′) - ------------------------------------------------------------------------- --- DEPRECATED NAMES ------------------------------------------------------------------------- --- Please use the new names as continuing support for the old names is --- not guaranteed. - --- Version 2.0 - -[,]-∘-distr = [,]-∘ -{-# WARNING_ON_USAGE [,]-∘-distr -"Warning: [,]-∘-distr was deprecated in v2.0. +open import Function.Base using (_∋_; _∘_; id) +open import Function.Bundles using (mk↔ₛ′; _↔_) +open import Relation.Binary.Definitions using (Decidable) +open import Relation.Binary.PropositionalEquality +open import Relation.Nullary.Decidable using (yes; no) +open import Relation.Nullary.Decidable using (map′) + + +private + variable + a b c d e f : Level + A : Set a + B : Set b + C : Set c + D : Set d + E : Set e + F : Set f + +inj₁-injective : ∀ {x y} → (A ⊎ B ∋ inj₁ x) ≡ inj₁ y → x ≡ y +inj₁-injective refl = refl + +inj₂-injective : ∀ {x y} → (A ⊎ B ∋ inj₂ x) ≡ inj₂ y → x ≡ y +inj₂-injective refl = refl + +module _ (dec₁ : Decidable {A = A} {B = A} _≡_) + (dec₂ : Decidable {A = B} {B = B} _≡_) where + + ≡-dec : Decidable {A = A ⊎ B} _≡_ + ≡-dec (inj₁ x) (inj₁ y) = map′ (cong inj₁) inj₁-injective (dec₁ x y) + ≡-dec (inj₁ x) (inj₂ y) = no λ() + ≡-dec (inj₂ x) (inj₁ y) = no λ() + ≡-dec (inj₂ x) (inj₂ y) = map′ (cong inj₂) inj₂-injective (dec₂ x y) + +swap-involutive : swap {A = A} {B = B} ∘ swap ≗ id +swap-involutive = [ (λ _ → refl) , (λ _ → refl) ] + +swap-↔ : (A ⊎ B) ↔ (B ⊎ A) +swap-↔ = mk↔ₛ′ swap swap swap-involutive swap-involutive + +map-id : map {A = A} {B = B} id id ≗ id +map-id (inj₁ _) = refl +map-id (inj₂ _) = refl + +[,]-∘ : (f : A → B) + {g : C → A} {h : D → A} → + f ∘ [ g , h ] ≗ [ f ∘ g , f ∘ h ] +[,]-∘ _ (inj₁ _) = refl +[,]-∘ _ (inj₂ _) = refl + +[,]-map : {f : A → B} {g : C → D} + {f′ : B → E} {g′ : D → E} → + [ f′ , g′ ] ∘ map f g ≗ [ f′ ∘ f , g′ ∘ g ] +[,]-map (inj₁ _) = refl +[,]-map (inj₂ _) = refl + +map-map : {f : A → B} {g : C → D} + {f′ : B → E} {g′ : D → F} → + map f′ g′ ∘ map f g ≗ map (f′ ∘ f) (g′ ∘ g) +map-map (inj₁ _) = refl +map-map (inj₂ _) = refl + +map₁₂-map₂₁ : {f : A → B} {g : C → D} → + map₁ f ∘ map₂ g ≗ map₂ g ∘ map₁ f +map₁₂-map₂₁ (inj₁ _) = refl +map₁₂-map₂₁ (inj₂ _) = refl + +map-assocˡ : (f : A → C) (g : B → D) (h : C → F) → + map (map f g) h ∘ assocˡ ≗ assocˡ ∘ map f (map g h) +map-assocˡ _ _ _ (inj₁ x ) = refl +map-assocˡ _ _ _ (inj₂ (inj₁ y)) = refl +map-assocˡ _ _ _ (inj₂ (inj₂ z)) = refl + +map-assocʳ : (f : A → C) (g : B → D) (h : C → F) → + map f (map g h) ∘ assocʳ ≗ assocʳ ∘ map (map f g) h +map-assocʳ _ _ _ (inj₁ (inj₁ x)) = refl +map-assocʳ _ _ _ (inj₁ (inj₂ y)) = refl +map-assocʳ _ _ _ (inj₂ z ) = refl + +[,]-cong : {f f′ : A → B} {g g′ : C → B} → + f ≗ f′ → g ≗ g′ → + [ f , g ] ≗ [ f′ , g′ ] +[,]-cong = [_,_] + +[-,]-cong : {f f′ : A → B} {g : C → B} → + f ≗ f′ → + [ f , g ] ≗ [ f′ , g ] +[-,]-cong = [_, (λ _ → refl) ] + +[,-]-cong : {f : A → B} {g g′ : C → B} → + g ≗ g′ → + [ f , g ] ≗ [ f , g′ ] +[,-]-cong = [ (λ _ → refl) ,_] + +map-cong : {f f′ : A → B} {g g′ : C → D} → + f ≗ f′ → g ≗ g′ → + map f g ≗ map f′ g′ +map-cong f≗f′ g≗g′ (inj₁ x) = cong inj₁ (f≗f′ x) +map-cong f≗f′ g≗g′ (inj₂ x) = cong inj₂ (g≗g′ x) + +map₁-cong : {f f′ : A → B} → + f ≗ f′ → + map₁ {B = C} f ≗ map₁ f′ +map₁-cong f≗f′ = [-,]-cong ((cong inj₁) ∘ f≗f′) + +map₂-cong : {g g′ : C → D} → + g ≗ g′ → + map₂ {A = A} g ≗ map₂ g′ +map₂-cong g≗g′ = [,-]-cong ((cong inj₂) ∘ g≗g′) + +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 2.0 + +[,]-∘-distr = [,]-∘ +{-# WARNING_ON_USAGE [,]-∘-distr +"Warning: [,]-∘-distr was deprecated in v2.0. Please use [,]-∘ instead." -#-} +#-} -[,]-map-commute = [,]-map -{-# WARNING_ON_USAGE [,]-map-commute -"Warning: [,]-map-commute was deprecated in v2.0. +[,]-map-commute = [,]-map +{-# WARNING_ON_USAGE [,]-map-commute +"Warning: [,]-map-commute was deprecated in v2.0. Please use [,]-map instead." -#-} +#-} -map-commute = map-map -{-# WARNING_ON_USAGE map-commute -"Warning: map-commute was deprecated in v2.0. +map-commute = map-map +{-# WARNING_ON_USAGE map-commute +"Warning: map-commute was deprecated in v2.0. Please use map-map instead." -#-} +#-} -map₁₂-commute = map₁₂-map₂₁ -{-# WARNING_ON_USAGE map₁₂-commute -"Warning: map₁₂-commute was deprecated in v2.0. +map₁₂-commute = map₁₂-map₂₁ +{-# WARNING_ON_USAGE map₁₂-commute +"Warning: map₁₂-commute was deprecated in v2.0. Please use map₁₂-map₂₁ instead." -#-} +#-} \ No newline at end of file diff --git a/Data.Sum.Relation.Binary.Pointwise.html b/Data.Sum.Relation.Binary.Pointwise.html index 9702c693..67070937 100644 --- a/Data.Sum.Relation.Binary.Pointwise.html +++ b/Data.Sum.Relation.Binary.Pointwise.html @@ -9,225 +9,212 @@ module Data.Sum.Relation.Binary.Pointwise where -open import Data.Product using (_,_) -open import Data.Sum.Base as Sum -open import Data.Sum.Properties -open import Level using (_⊔_) -open import Function.Base using (_∘_; id) -open import Function.Inverse using (Inverse) -open import Relation.Nullary -import Relation.Nullary.Decidable as Dec -open import Relation.Binary -open import Relation.Binary.PropositionalEquality as P using (_≡_) - ----------------------------------------------------------------------- --- Definition - -data Pointwise {a b c d r s} - {A : Set a} {B : Set b} {C : Set c} {D : Set d} - (R : REL A C r) (S : REL B D s) - : REL (A ⊎ B) (C ⊎ D) (a ⊔ b ⊔ c ⊔ d ⊔ r ⊔ s) where - inj₁ : ∀ {a c} → R a c → Pointwise R S (inj₁ a) (inj₁ c) - inj₂ : ∀ {b d} → S b d → Pointwise R S (inj₂ b) (inj₂ d) - ----------------------------------------------------------------------- --- Relational properties - -module _ {a₁ a₂ ℓ₁ ℓ₂} {A₁ : Set a₁} {A₂ : Set a₂} - {∼₁ : Rel A₁ ℓ₁} {∼₂ : Rel A₂ ℓ₂} - where - - drop-inj₁ : ∀ {x y} → Pointwise ∼₁ ∼₂ (inj₁ x) (inj₁ y) → ∼₁ x y - drop-inj₁ (inj₁ x) = x - - drop-inj₂ : ∀ {x y} → Pointwise ∼₁ ∼₂ (inj₂ x) (inj₂ y) → ∼₂ x y - drop-inj₂ (inj₂ x) = x - - ⊎-refl : Reflexive ∼₁ → Reflexive ∼₂ → - Reflexive (Pointwise ∼₁ ∼₂) - ⊎-refl refl₁ refl₂ {inj₁ x} = inj₁ refl₁ - ⊎-refl refl₁ refl₂ {inj₂ y} = inj₂ refl₂ - - ⊎-symmetric : Symmetric ∼₁ → Symmetric ∼₂ → - Symmetric (Pointwise ∼₁ ∼₂) - ⊎-symmetric sym₁ sym₂ (inj₁ x) = inj₁ (sym₁ x) - ⊎-symmetric sym₁ sym₂ (inj₂ x) = inj₂ (sym₂ x) - - ⊎-transitive : Transitive ∼₁ → Transitive ∼₂ → - Transitive (Pointwise ∼₁ ∼₂) - ⊎-transitive trans₁ trans₂ (inj₁ x) (inj₁ y) = inj₁ (trans₁ x y) - ⊎-transitive trans₁ trans₂ (inj₂ x) (inj₂ y) = inj₂ (trans₂ x y) - - ⊎-asymmetric : Asymmetric ∼₁ → Asymmetric ∼₂ → - Asymmetric (Pointwise ∼₁ ∼₂) - ⊎-asymmetric asym₁ asym₂ (inj₁ x) = λ { (inj₁ y) → asym₁ x y } - ⊎-asymmetric asym₁ asym₂ (inj₂ x) = λ { (inj₂ y) → asym₂ x y } - - ⊎-substitutive : ∀ {ℓ₃} → Substitutive ∼₁ ℓ₃ → Substitutive ∼₂ ℓ₃ → - Substitutive (Pointwise ∼₁ ∼₂) ℓ₃ - ⊎-substitutive subst₁ subst₂ P (inj₁ x) = subst₁ (P ∘ inj₁) x - ⊎-substitutive subst₁ subst₂ P (inj₂ x) = subst₂ (P ∘ inj₂) x - - ⊎-decidable : Decidable ∼₁ → Decidable ∼₂ → - Decidable (Pointwise ∼₁ ∼₂) - ⊎-decidable _≟₁_ _≟₂_ (inj₁ x) (inj₁ y) = Dec.map′ inj₁ drop-inj₁ (x ≟₁ y) - ⊎-decidable _≟₁_ _≟₂_ (inj₁ x) (inj₂ y) = no λ() - ⊎-decidable _≟₁_ _≟₂_ (inj₂ x) (inj₁ y) = no λ() - ⊎-decidable _≟₁_ _≟₂_ (inj₂ x) (inj₂ y) = Dec.map′ inj₂ drop-inj₂ (x ≟₂ y) - -module _ {a₁ a₂} {A₁ : Set a₁} {A₂ : Set a₂} - {ℓ₁ ℓ₂} {∼₁ : Rel A₁ ℓ₁} {≈₁ : Rel A₁ ℓ₂} - {ℓ₃ ℓ₄} {∼₂ : Rel A₂ ℓ₃} {≈₂ : Rel A₂ ℓ₄} where - - ⊎-reflexive : ≈₁ ⇒ ∼₁ → ≈₂ ⇒ ∼₂ → - (Pointwise ≈₁ ≈₂) ⇒ (Pointwise ∼₁ ∼₂) - ⊎-reflexive refl₁ refl₂ (inj₁ x) = inj₁ (refl₁ x) - ⊎-reflexive refl₁ refl₂ (inj₂ x) = inj₂ (refl₂ x) - - ⊎-irreflexive : Irreflexive ≈₁ ∼₁ → Irreflexive ≈₂ ∼₂ → - Irreflexive (Pointwise ≈₁ ≈₂) (Pointwise ∼₁ ∼₂) - ⊎-irreflexive irrefl₁ irrefl₂ (inj₁ x) (inj₁ y) = irrefl₁ x y - ⊎-irreflexive irrefl₁ irrefl₂ (inj₂ x) (inj₂ y) = irrefl₂ x y - - ⊎-antisymmetric : Antisymmetric ≈₁ ∼₁ → Antisymmetric ≈₂ ∼₂ → - Antisymmetric (Pointwise ≈₁ ≈₂) (Pointwise ∼₁ ∼₂) - ⊎-antisymmetric antisym₁ antisym₂ (inj₁ x) (inj₁ y) = inj₁ (antisym₁ x y) - ⊎-antisymmetric antisym₁ antisym₂ (inj₂ x) (inj₂ y) = inj₂ (antisym₂ x y) - - ⊎-respectsˡ : ∼₁ Respectsˡ ≈₁ → ∼₂ Respectsˡ ≈₂ → - (Pointwise ∼₁ ∼₂) Respectsˡ (Pointwise ≈₁ ≈₂) - ⊎-respectsˡ resp₁ resp₂ (inj₁ x) (inj₁ y) = inj₁ (resp₁ x y) - ⊎-respectsˡ resp₁ resp₂ (inj₂ x) (inj₂ y) = inj₂ (resp₂ x y) - - ⊎-respectsʳ : ∼₁ Respectsʳ ≈₁ → ∼₂ Respectsʳ ≈₂ → - (Pointwise ∼₁ ∼₂) Respectsʳ (Pointwise ≈₁ ≈₂) - ⊎-respectsʳ resp₁ resp₂ (inj₁ x) (inj₁ y) = inj₁ (resp₁ x y) - ⊎-respectsʳ resp₁ resp₂ (inj₂ x) (inj₂ y) = inj₂ (resp₂ x y) - - ⊎-respects₂ : ∼₁ Respects₂ ≈₁ → ∼₂ Respects₂ ≈₂ → - (Pointwise ∼₁ ∼₂) Respects₂ (Pointwise ≈₁ ≈₂) - ⊎-respects₂ (r₁ , l₁) (r₂ , l₂) = ⊎-respectsʳ r₁ r₂ , ⊎-respectsˡ l₁ l₂ - ----------------------------------------------------------------------- --- Structures - -module _ {a₁ a₂} {A₁ : Set a₁} {A₂ : Set a₂} - {ℓ₁ ℓ₂} {≈₁ : Rel A₁ ℓ₁} {≈₂ : Rel A₂ ℓ₂} - where - - ⊎-isEquivalence : IsEquivalence ≈₁ → IsEquivalence ≈₂ → - IsEquivalence (Pointwise ≈₁ ≈₂) - ⊎-isEquivalence eq₁ eq₂ = record - { refl = ⊎-refl (refl eq₁) (refl eq₂) - ; sym = ⊎-symmetric (sym eq₁) (sym eq₂) - ; trans = ⊎-transitive (trans eq₁) (trans eq₂) - } - where open IsEquivalence - - ⊎-isDecEquivalence : IsDecEquivalence ≈₁ → IsDecEquivalence ≈₂ → - IsDecEquivalence (Pointwise ≈₁ ≈₂) - ⊎-isDecEquivalence eq₁ eq₂ = record - { isEquivalence = - ⊎-isEquivalence (isEquivalence eq₁) (isEquivalence eq₂) - ; _≟_ = ⊎-decidable (_≟_ eq₁) (_≟_ eq₂) - } - where open IsDecEquivalence - -module _ {a₁ a₂} {A₁ : Set a₁} {A₂ : Set a₂} - {ℓ₁ ℓ₂} {≈₁ : Rel A₁ ℓ₁} {∼₁ : Rel A₁ ℓ₂} - {ℓ₃ ℓ₄} {≈₂ : Rel A₂ ℓ₃} {∼₂ : Rel A₂ ℓ₄} where - - ⊎-isPreorder : IsPreorder ≈₁ ∼₁ → IsPreorder ≈₂ ∼₂ → - IsPreorder (Pointwise ≈₁ ≈₂) (Pointwise ∼₁ ∼₂) - ⊎-isPreorder pre₁ pre₂ = record - { isEquivalence = - ⊎-isEquivalence (isEquivalence pre₁) (isEquivalence pre₂) - ; reflexive = ⊎-reflexive (reflexive pre₁) (reflexive pre₂) - ; trans = ⊎-transitive (trans pre₁) (trans pre₂) - } - where open IsPreorder - - ⊎-isPartialOrder : IsPartialOrder ≈₁ ∼₁ → - IsPartialOrder ≈₂ ∼₂ → - IsPartialOrder - (Pointwise ≈₁ ≈₂) (Pointwise ∼₁ ∼₂) - ⊎-isPartialOrder po₁ po₂ = record - { isPreorder = ⊎-isPreorder (isPreorder po₁) (isPreorder po₂) - ; antisym = ⊎-antisymmetric (antisym po₁) (antisym po₂) - } - where open IsPartialOrder - - ⊎-isStrictPartialOrder : IsStrictPartialOrder ≈₁ ∼₁ → - IsStrictPartialOrder ≈₂ ∼₂ → - IsStrictPartialOrder - (Pointwise ≈₁ ≈₂) (Pointwise ∼₁ ∼₂) - ⊎-isStrictPartialOrder spo₁ spo₂ = record - { isEquivalence = - ⊎-isEquivalence (isEquivalence spo₁) (isEquivalence spo₂) - ; irrefl = ⊎-irreflexive (irrefl spo₁) (irrefl spo₂) - ; trans = ⊎-transitive (trans spo₁) (trans spo₂) - ; <-resp-≈ = ⊎-respects₂ (<-resp-≈ spo₁) (<-resp-≈ spo₂) - } - where open IsStrictPartialOrder - ------------------------------------------------------------------------- --- Bundles - -module _ {a b c d} where - - ⊎-setoid : Setoid a b → Setoid c d → Setoid _ _ - ⊎-setoid s₁ s₂ = record - { isEquivalence = - ⊎-isEquivalence (isEquivalence s₁) (isEquivalence s₂) - } where open Setoid - - ⊎-decSetoid : DecSetoid a b → DecSetoid c d → DecSetoid _ _ - ⊎-decSetoid ds₁ ds₂ = record - { isDecEquivalence = - ⊎-isDecEquivalence (isDecEquivalence ds₁) (isDecEquivalence ds₂) - } where open DecSetoid - - -- Some additional notation for combining setoids - infix 4 _⊎ₛ_ - _⊎ₛ_ : Setoid a b → Setoid c d → Setoid _ _ - _⊎ₛ_ = ⊎-setoid - -module _ {a b c d e f} where - - ⊎-preorder : Preorder a b c → Preorder d e f → Preorder _ _ _ - ⊎-preorder p₁ p₂ = record - { isPreorder = - ⊎-isPreorder (isPreorder p₁) (isPreorder p₂) - } where open Preorder - - ⊎-poset : Poset a b c → Poset a b c → Poset _ _ _ - ⊎-poset po₁ po₂ = record - { isPartialOrder = - ⊎-isPartialOrder (isPartialOrder po₁) (isPartialOrder po₂) - } where open Poset - ------------------------------------------------------------------------- --- The propositional equality setoid over products can be --- decomposed using Pointwise - -module _ {a b} {A : Set a} {B : Set b} where - - Pointwise-≡⇒≡ : (Pointwise _≡_ _≡_) ⇒ _≡_ {A = A ⊎ B} - Pointwise-≡⇒≡ (inj₁ x) = P.cong inj₁ x - Pointwise-≡⇒≡ (inj₂ x) = P.cong inj₂ x - - ≡⇒Pointwise-≡ : _≡_ {A = A ⊎ B} ⇒ (Pointwise _≡_ _≡_) - ≡⇒Pointwise-≡ P.refl = ⊎-refl P.refl P.refl - -Pointwise-≡↔≡ : ∀ {a b} (A : Set a) (B : Set b) → - Inverse (P.setoid A ⊎ₛ P.setoid B) - (P.setoid (A ⊎ B)) -Pointwise-≡↔≡ _ _ = record - { to = record { _⟨$⟩_ = id; cong = Pointwise-≡⇒≡ } - ; from = record { _⟨$⟩_ = id; cong = ≡⇒Pointwise-≡ } - ; inverse-of = record - { left-inverse-of = λ _ → ⊎-refl P.refl P.refl - ; right-inverse-of = λ _ → P.refl - } - } +open import Data.Product.Base using (_,_) +open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂) +open import Data.Sum.Properties +open import Level using (Level; _⊔_) +open import Function.Base using (const; _∘_; id) +open import Function.Bundles using (Inverse; mk↔) +open import Relation.Nullary +import Relation.Nullary.Decidable as Dec +open import Relation.Binary +open import Relation.Binary.PropositionalEquality.Core as P using (_≡_) +import Relation.Binary.PropositionalEquality.Properties as P + +private + variable + a b c d ℓ₁ ℓ₂ ℓ₃ ℓ : Level + A B C D : Set ℓ + R S T U : REL A B ℓ + ≈₁ ≈₂ : Rel A ℓ + +------------------------------------------------------------------------ +-- Definition + +data Pointwise {A : Set a} {B : Set b} {C : Set c} {D : Set d} + (R : REL A C ℓ₁) (S : REL B D ℓ₂) + : REL (A ⊎ B) (C ⊎ D) (a ⊔ b ⊔ c ⊔ d ⊔ ℓ₁ ⊔ ℓ₂) where + inj₁ : ∀ {a c} → R a c → Pointwise R S (inj₁ a) (inj₁ c) + inj₂ : ∀ {b d} → S b d → Pointwise R S (inj₂ b) (inj₂ d) + +---------------------------------------------------------------------- +-- Functions + +map : ∀ {f : A → C} {g : B → D} → + R =[ f ]⇒ T → S =[ g ]⇒ U → + Pointwise R S =[ Sum.map f g ]⇒ Pointwise T U +map R⇒T _ (inj₁ x) = inj₁ (R⇒T x) +map _ S⇒U (inj₂ x) = inj₂ (S⇒U x) + +------------------------------------------------------------------------ +-- Relational properties + +drop-inj₁ : ∀ {x y} → Pointwise R S (inj₁ x) (inj₁ y) → R x y +drop-inj₁ (inj₁ x) = x + +drop-inj₂ : ∀ {x y} → Pointwise R S (inj₂ x) (inj₂ y) → S x y +drop-inj₂ (inj₂ x) = x + +⊎-refl : Reflexive R → Reflexive S → Reflexive (Pointwise R S) +⊎-refl refl₁ refl₂ {inj₁ x} = inj₁ refl₁ +⊎-refl refl₁ refl₂ {inj₂ y} = inj₂ refl₂ + +⊎-symmetric : Symmetric R → Symmetric S → + Symmetric (Pointwise R S) +⊎-symmetric sym₁ sym₂ (inj₁ x) = inj₁ (sym₁ x) +⊎-symmetric sym₁ sym₂ (inj₂ x) = inj₂ (sym₂ x) + +⊎-transitive : Transitive R → Transitive S → + Transitive (Pointwise R S) +⊎-transitive trans₁ trans₂ (inj₁ x) (inj₁ y) = inj₁ (trans₁ x y) +⊎-transitive trans₁ trans₂ (inj₂ x) (inj₂ y) = inj₂ (trans₂ x y) + +⊎-asymmetric : Asymmetric R → Asymmetric S → + Asymmetric (Pointwise R S) +⊎-asymmetric asym₁ asym₂ (inj₁ x) = λ { (inj₁ y) → asym₁ x y } +⊎-asymmetric asym₁ asym₂ (inj₂ x) = λ { (inj₂ y) → asym₂ x y } + +⊎-substitutive : Substitutive R ℓ₃ → Substitutive S ℓ₃ → + Substitutive (Pointwise R S) ℓ₃ +⊎-substitutive subst₁ subst₂ P (inj₁ x) = subst₁ (P ∘ inj₁) x +⊎-substitutive subst₁ subst₂ P (inj₂ x) = subst₂ (P ∘ inj₂) x + +⊎-decidable : Decidable R → Decidable S → Decidable (Pointwise R S) +⊎-decidable _≟₁_ _≟₂_ (inj₁ x) (inj₁ y) = Dec.map′ inj₁ drop-inj₁ (x ≟₁ y) +⊎-decidable _≟₁_ _≟₂_ (inj₁ x) (inj₂ y) = no λ() +⊎-decidable _≟₁_ _≟₂_ (inj₂ x) (inj₁ y) = no λ() +⊎-decidable _≟₁_ _≟₂_ (inj₂ x) (inj₂ y) = Dec.map′ inj₂ drop-inj₂ (x ≟₂ y) + +⊎-reflexive : ≈₁ ⇒ R → ≈₂ ⇒ S → + (Pointwise ≈₁ ≈₂) ⇒ (Pointwise R S) +⊎-reflexive refl₁ refl₂ (inj₁ x) = inj₁ (refl₁ x) +⊎-reflexive refl₁ refl₂ (inj₂ x) = inj₂ (refl₂ x) + +⊎-irreflexive : Irreflexive ≈₁ R → Irreflexive ≈₂ S → + Irreflexive (Pointwise ≈₁ ≈₂) (Pointwise R S) +⊎-irreflexive irrefl₁ irrefl₂ (inj₁ x) (inj₁ y) = irrefl₁ x y +⊎-irreflexive irrefl₁ irrefl₂ (inj₂ x) (inj₂ y) = irrefl₂ x y + +⊎-antisymmetric : Antisymmetric ≈₁ R → Antisymmetric ≈₂ S → + Antisymmetric (Pointwise ≈₁ ≈₂) (Pointwise R S) +⊎-antisymmetric antisym₁ antisym₂ (inj₁ x) (inj₁ y) = inj₁ (antisym₁ x y) +⊎-antisymmetric antisym₁ antisym₂ (inj₂ x) (inj₂ y) = inj₂ (antisym₂ x y) + +⊎-respectsˡ : R Respectsˡ ≈₁ → S Respectsˡ ≈₂ → + (Pointwise R S) Respectsˡ (Pointwise ≈₁ ≈₂) +⊎-respectsˡ resp₁ resp₂ (inj₁ x) (inj₁ y) = inj₁ (resp₁ x y) +⊎-respectsˡ resp₁ resp₂ (inj₂ x) (inj₂ y) = inj₂ (resp₂ x y) + +⊎-respectsʳ : R Respectsʳ ≈₁ → S Respectsʳ ≈₂ → + (Pointwise R S) Respectsʳ (Pointwise ≈₁ ≈₂) +⊎-respectsʳ resp₁ resp₂ (inj₁ x) (inj₁ y) = inj₁ (resp₁ x y) +⊎-respectsʳ resp₁ resp₂ (inj₂ x) (inj₂ y) = inj₂ (resp₂ x y) + +⊎-respects₂ : R Respects₂ ≈₁ → S Respects₂ ≈₂ → + (Pointwise R S) Respects₂ (Pointwise ≈₁ ≈₂) +⊎-respects₂ (r₁ , l₁) (r₂ , l₂) = ⊎-respectsʳ r₁ r₂ , ⊎-respectsˡ l₁ l₂ + +------------------------------------------------------------------------ +-- Structures + +⊎-isEquivalence : IsEquivalence ≈₁ → IsEquivalence ≈₂ → + IsEquivalence (Pointwise ≈₁ ≈₂) +⊎-isEquivalence eq₁ eq₂ = record + { refl = ⊎-refl (refl eq₁) (refl eq₂) + ; sym = ⊎-symmetric (sym eq₁) (sym eq₂) + ; trans = ⊎-transitive (trans eq₁) (trans eq₂) + } where open IsEquivalence + +⊎-isDecEquivalence : IsDecEquivalence ≈₁ → IsDecEquivalence ≈₂ → + IsDecEquivalence (Pointwise ≈₁ ≈₂) +⊎-isDecEquivalence eq₁ eq₂ = record + { isEquivalence = + ⊎-isEquivalence (isEquivalence eq₁) (isEquivalence eq₂) + ; _≟_ = ⊎-decidable (_≟_ eq₁) (_≟_ eq₂) + } where open IsDecEquivalence + +⊎-isPreorder : IsPreorder ≈₁ R → IsPreorder ≈₂ S → + IsPreorder (Pointwise ≈₁ ≈₂) (Pointwise R S) +⊎-isPreorder pre₁ pre₂ = record + { isEquivalence = + ⊎-isEquivalence (isEquivalence pre₁) (isEquivalence pre₂) + ; reflexive = ⊎-reflexive (reflexive pre₁) (reflexive pre₂) + ; trans = ⊎-transitive (trans pre₁) (trans pre₂) + } where open IsPreorder + +⊎-isPartialOrder : IsPartialOrder ≈₁ R → IsPartialOrder ≈₂ S → + IsPartialOrder + (Pointwise ≈₁ ≈₂) (Pointwise R S) +⊎-isPartialOrder po₁ po₂ = record + { isPreorder = ⊎-isPreorder (isPreorder po₁) (isPreorder po₂) + ; antisym = ⊎-antisymmetric (antisym po₁) (antisym po₂) + } where open IsPartialOrder + +⊎-isStrictPartialOrder : IsStrictPartialOrder ≈₁ R → + IsStrictPartialOrder ≈₂ S → + IsStrictPartialOrder + (Pointwise ≈₁ ≈₂) (Pointwise R S) +⊎-isStrictPartialOrder spo₁ spo₂ = record + { isEquivalence = + ⊎-isEquivalence (isEquivalence spo₁) (isEquivalence spo₂) + ; irrefl = ⊎-irreflexive (irrefl spo₁) (irrefl spo₂) + ; trans = ⊎-transitive (trans spo₁) (trans spo₂) + ; <-resp-≈ = ⊎-respects₂ (<-resp-≈ spo₁) (<-resp-≈ spo₂) + } where open IsStrictPartialOrder + +------------------------------------------------------------------------ +-- Bundles + +⊎-setoid : Setoid a b → Setoid c d → Setoid _ _ +⊎-setoid s₁ s₂ = record + { isEquivalence = + ⊎-isEquivalence (isEquivalence s₁) (isEquivalence s₂) + } where open Setoid + +⊎-decSetoid : DecSetoid a b → DecSetoid c d → DecSetoid _ _ +⊎-decSetoid ds₁ ds₂ = record + { isDecEquivalence = + ⊎-isDecEquivalence (isDecEquivalence ds₁) (isDecEquivalence ds₂) + } where open DecSetoid + +⊎-preorder : Preorder a b ℓ₁ → Preorder c d ℓ₂ → Preorder _ _ _ +⊎-preorder p₁ p₂ = record + { isPreorder = + ⊎-isPreorder (isPreorder p₁) (isPreorder p₂) + } where open Preorder + +⊎-poset : Poset a b c → Poset a b c → Poset _ _ _ +⊎-poset po₁ po₂ = record + { isPartialOrder = + ⊎-isPartialOrder (isPartialOrder po₁) (isPartialOrder po₂) + } where open Poset + +------------------------------------------------------------------------ +-- Additional notation + +-- Infix combining setoids +infix 4 _⊎ₛ_ +_⊎ₛ_ : Setoid a b → Setoid c d → Setoid _ _ +_⊎ₛ_ = ⊎-setoid + +------------------------------------------------------------------------ +-- The propositional equality setoid over products can be +-- decomposed using Pointwise + +Pointwise-≡⇒≡ : (Pointwise _≡_ _≡_) ⇒ _≡_ {A = A ⊎ B} +Pointwise-≡⇒≡ (inj₁ x) = P.cong inj₁ x +Pointwise-≡⇒≡ (inj₂ x) = P.cong inj₂ x + +≡⇒Pointwise-≡ : _≡_ {A = A ⊎ B} ⇒ (Pointwise _≡_ _≡_) +≡⇒Pointwise-≡ P.refl = ⊎-refl P.refl P.refl + +Pointwise-≡↔≡ : (A : Set a) (B : Set b) → + Inverse (P.setoid A ⊎ₛ P.setoid B) (P.setoid (A ⊎ B)) +Pointwise-≡↔≡ _ _ = record + { to = id + ; from = id + ; to-cong = Pointwise-≡⇒≡ + ; from-cong = ≡⇒Pointwise-≡ + ; inverse = Pointwise-≡⇒≡ , ≡⇒Pointwise-≡ + } \ No newline at end of file diff --git a/Data.Sum.html b/Data.Sum.html index a2a9f7b7..b3ee667c 100644 --- a/Data.Sum.html +++ b/Data.Sum.html @@ -16,8 +16,8 @@ open import Data.Maybe.Base using (Maybe; just; nothing) open import Function.Base open import Level -open import Relation.Nullary.Reflects using (invert) -open import Relation.Nullary using (Dec; yes; no; _because_; ¬_) +open import Relation.Nullary.Reflects using (invert) +open import Relation.Nullary using (Dec; yes; no; _because_; ¬_) private variable @@ -60,11 +60,11 @@ -- Conversion back and forth with Dec -fromDec : Dec A → A ⊎ ¬ A -fromDec ( true because [p]) = inj₁ (invert [p]) -fromDec (false because [¬p]) = inj₂ (invert [¬p]) +fromDec : Dec A → A ⊎ ¬ A +fromDec ( true because [p]) = inj₁ (invert [p]) +fromDec (false because [¬p]) = inj₂ (invert [¬p]) -toDec : A ⊎ ¬ A → Dec A -toDec (inj₁ p) = yes p -toDec (inj₂ ¬p) = no ¬p +toDec : A ⊎ ¬ A → Dec A +toDec (inj₁ p) = yes p +toDec (inj₂ ¬p) = no ¬p \ No newline at end of file diff --git a/Data.Unit.Polymorphic.Properties.html b/Data.Unit.Polymorphic.Properties.html index f91bd614..f7e9a863 100644 --- a/Data.Unit.Polymorphic.Properties.html +++ b/Data.Unit.Polymorphic.Properties.html @@ -11,96 +11,101 @@ module Data.Unit.Polymorphic.Properties where open import Level -open import Function.Bundles using (_↔_; mk↔) -open import Data.Product using (_,_) -open import Data.Sum.Base using (inj₁) -open import Data.Unit.Base renaming (⊤ to ⊤*) -open import Data.Unit.Polymorphic.Base using (⊤; tt) -open import Relation.Nullary -open import Relation.Binary -open import Relation.Binary.PropositionalEquality - -private - variable - ℓ : Level - ------------------------------------------------------------------------- --- Equality ------------------------------------------------------------------------- - -infix 4 _≟_ - -_≟_ : Decidable {A = ⊤ {ℓ}} _≡_ -_ ≟ _ = yes refl - -≡-setoid : ∀ ℓ → Setoid ℓ ℓ -≡-setoid _ = setoid ⊤ - -≡-decSetoid : ∀ ℓ → DecSetoid ℓ ℓ -≡-decSetoid _ = decSetoid _≟_ - ------------------------------------------------------------------------- --- Ordering ------------------------------------------------------------------------- - -≡-total : Total {A = ⊤ {ℓ}} _≡_ -≡-total _ _ = inj₁ refl - -≡-antisym : Antisymmetric {A = ⊤ {ℓ}} _≡_ _≡_ -≡-antisym p _ = p - ------------------------------------------------------------------------- --- Structures - -≡-isPreorder : ∀ ℓ → IsPreorder {ℓ} {_} {⊤} _≡_ _≡_ -≡-isPreorder ℓ = record - { isEquivalence = isEquivalence - ; reflexive = λ x → x - ; 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 - -≡-preorder : ∀ ℓ → Preorder ℓ ℓ ℓ -≡-preorder ℓ = record - { isPreorder = ≡-isPreorder ℓ - } - -≡-poset : ∀ ℓ → Poset ℓ ℓ ℓ -≡-poset ℓ = record - { isPartialOrder = ≡-isPartialOrder ℓ - } - -≡-totalOrder : ∀ ℓ → TotalOrder ℓ ℓ ℓ -≡-totalOrder ℓ = record - { isTotalOrder = ≡-isTotalOrder ℓ - } - -≡-decTotalOrder : ∀ ℓ → DecTotalOrder ℓ ℓ ℓ -≡-decTotalOrder ℓ = record - { isDecTotalOrder = ≡-isDecTotalOrder ℓ - } - -⊤↔⊤* : ⊤ {ℓ} ↔ ⊤* -⊤↔⊤* = mk↔ ((λ _ → refl) , (λ _ → refl)) +open import Function.Bundles using (_↔_; mk↔) +open import Data.Product.Base using (_,_) +open import Data.Sum.Base using (inj₁) +open import Data.Unit.Base renaming (⊤ to ⊤*) +open import Data.Unit.Polymorphic.Base using (⊤; tt) +open import Relation.Nullary +open import Relation.Binary.Bundles + using (Setoid; DecSetoid; Preorder; Poset; TotalOrder; DecTotalOrder) +open import Relation.Binary.Structures + using (IsPreorder; IsPartialOrder; IsTotalOrder; IsDecTotalOrder) +open import Relation.Binary.Definitions + using (Decidable; Antisymmetric; Total) +open import Relation.Binary.PropositionalEquality + +private + variable + ℓ : Level + +------------------------------------------------------------------------ +-- Equality +------------------------------------------------------------------------ + +infix 4 _≟_ + +_≟_ : Decidable {A = ⊤ {ℓ}} _≡_ +_ ≟ _ = yes refl + +≡-setoid : ∀ ℓ → Setoid ℓ ℓ +≡-setoid _ = setoid ⊤ + +≡-decSetoid : ∀ ℓ → DecSetoid ℓ ℓ +≡-decSetoid _ = decSetoid _≟_ + +------------------------------------------------------------------------ +-- Ordering +------------------------------------------------------------------------ + +≡-total : Total {A = ⊤ {ℓ}} _≡_ +≡-total _ _ = inj₁ refl + +≡-antisym : Antisymmetric {A = ⊤ {ℓ}} _≡_ _≡_ +≡-antisym p _ = p + +------------------------------------------------------------------------ +-- Structures + +≡-isPreorder : ∀ ℓ → IsPreorder {ℓ} {_} {⊤} _≡_ _≡_ +≡-isPreorder ℓ = record + { isEquivalence = isEquivalence + ; reflexive = λ x → x + ; 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 + +≡-preorder : ∀ ℓ → Preorder ℓ ℓ ℓ +≡-preorder ℓ = record + { isPreorder = ≡-isPreorder ℓ + } + +≡-poset : ∀ ℓ → Poset ℓ ℓ ℓ +≡-poset ℓ = record + { isPartialOrder = ≡-isPartialOrder ℓ + } + +≡-totalOrder : ∀ ℓ → TotalOrder ℓ ℓ ℓ +≡-totalOrder ℓ = record + { isTotalOrder = ≡-isTotalOrder ℓ + } + +≡-decTotalOrder : ∀ ℓ → DecTotalOrder ℓ ℓ ℓ +≡-decTotalOrder ℓ = record + { isDecTotalOrder = ≡-isDecTotalOrder ℓ + } + +⊤↔⊤* : ⊤ {ℓ} ↔ ⊤* +⊤↔⊤* = mk↔ ((λ _ → refl) , (λ _ → refl)) \ No newline at end of file diff --git a/Data.Unit.Polymorphic.html b/Data.Unit.Polymorphic.html index 9cd3701d..668b7c99 100644 --- a/Data.Unit.Polymorphic.html +++ b/Data.Unit.Polymorphic.html @@ -17,5 +17,5 @@ ------------------------------------------------------------------------ -- Re-export query operations -open import Data.Unit.Polymorphic.Properties public using (_≟_) +open import Data.Unit.Polymorphic.Properties public using (_≟_) \ No newline at end of file diff --git a/Data.Unit.Properties.html b/Data.Unit.Properties.html index 1371c8bd..06a322e1 100644 --- a/Data.Unit.Properties.html +++ b/Data.Unit.Properties.html @@ -13,77 +13,81 @@ open import Data.Unit.Base open import Level using (0ℓ) open import Relation.Nullary -open import Relation.Binary hiding (Irrelevant) -open import Relation.Binary.PropositionalEquality - ------------------------------------------------------------------------- --- Irrelevancy - -⊤-irrelevant : Irrelevant ⊤ -⊤-irrelevant _ _ = refl - ------------------------------------------------------------------------- --- Equality - -infix 4 _≟_ - -_≟_ : Decidable {A = ⊤} _≡_ -_ ≟ _ = yes refl - -≡-setoid : Setoid 0ℓ 0ℓ -≡-setoid = setoid ⊤ - -≡-decSetoid : DecSetoid 0ℓ 0ℓ -≡-decSetoid = decSetoid _≟_ - ------------------------------------------------------------------------- --- Relational properties - -≡-total : Total {A = ⊤} _≡_ -≡-total _ _ = inj₁ refl - -≡-antisym : Antisymmetric {A = ⊤} _≡_ _≡_ -≡-antisym eq _ = eq - ------------------------------------------------------------------------- --- Structures - -≡-isPreorder : IsPreorder {A = ⊤} _≡_ _≡_ -≡-isPreorder = record - { isEquivalence = isEquivalence - ; reflexive = λ x → x - ; 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 - -≡-poset : Poset 0ℓ 0ℓ 0ℓ -≡-poset = record - { isPartialOrder = ≡-isPartialOrder - } - -≡-decTotalOrder : DecTotalOrder 0ℓ 0ℓ 0ℓ -≡-decTotalOrder = record - { isDecTotalOrder = ≡-isDecTotalOrder - } +open import Relation.Binary.Bundles + using (Setoid; DecSetoid; Poset; DecTotalOrder) +open import Relation.Binary.Structures + using (IsPreorder; IsPartialOrder; IsTotalOrder; IsDecTotalOrder) +open import Relation.Binary.Definitions using (Decidable; Total; Antisymmetric) +open import Relation.Binary.PropositionalEquality + +------------------------------------------------------------------------ +-- Irrelevancy + +⊤-irrelevant : Irrelevant ⊤ +⊤-irrelevant _ _ = refl + +------------------------------------------------------------------------ +-- Equality + +infix 4 _≟_ + +_≟_ : Decidable {A = ⊤} _≡_ +_ ≟ _ = yes refl + +≡-setoid : Setoid 0ℓ 0ℓ +≡-setoid = setoid ⊤ + +≡-decSetoid : DecSetoid 0ℓ 0ℓ +≡-decSetoid = decSetoid _≟_ + +------------------------------------------------------------------------ +-- Relational properties + +≡-total : Total {A = ⊤} _≡_ +≡-total _ _ = inj₁ refl + +≡-antisym : Antisymmetric {A = ⊤} _≡_ _≡_ +≡-antisym eq _ = eq + +------------------------------------------------------------------------ +-- Structures + +≡-isPreorder : IsPreorder {A = ⊤} _≡_ _≡_ +≡-isPreorder = record + { isEquivalence = isEquivalence + ; reflexive = λ x → x + ; 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 + +≡-poset : Poset 0ℓ 0ℓ 0ℓ +≡-poset = record + { isPartialOrder = ≡-isPartialOrder + } + +≡-decTotalOrder : DecTotalOrder 0ℓ 0ℓ 0ℓ +≡-decTotalOrder = record + { isDecTotalOrder = ≡-isDecTotalOrder + } \ No newline at end of file diff --git a/Data.Unit.html b/Data.Unit.html index 13f88892..ea97d983 100644 --- a/Data.Unit.html +++ b/Data.Unit.html @@ -18,5 +18,5 @@ -- Re-export query operations open import Data.Unit.Properties public - using (_≟_) + using (_≟_) \ No newline at end of file diff --git a/Data.Vec.Base.html b/Data.Vec.Base.html index 148fd556..4d207d61 100644 --- a/Data.Vec.Base.html +++ b/Data.Vec.Base.html @@ -9,354 +9,369 @@ module Data.Vec.Base where -open import Data.Bool.Base using (Bool; true; false; if_then_else_) +open import Data.Bool.Base using (Bool; true; false; if_then_else_) open import Data.Nat.Base -open import Data.Fin.Base using (Fin; zero; suc) +open import Data.Fin.Base using (Fin; zero; suc) open import Data.List.Base as List using (List) -open import Data.Product as Prod using (∃; ∃₂; _×_; _,_) -open import Data.These.Base as These using (These; this; that; these) -open import Function.Base using (const; _∘′_; id; _∘_) -open import Level using (Level) -open import Relation.Binary.PropositionalEquality.Core using (_≡_; refl; cong) -open import Relation.Nullary.Decidable using (does) -open import Relation.Unary using (Pred; Decidable) +open import Data.Product.Base as Prod using (∃; ∃₂; _×_; _,_; proj₁; proj₂) +open import Data.These.Base as These using (These; this; that; these) +open import Function.Base using (const; _∘′_; id; _∘_) +open import Level using (Level) +open import Relation.Binary.PropositionalEquality.Core using (_≡_; refl; trans; cong) +open import Relation.Nullary.Decidable.Core using (does; T?) +open import Relation.Unary using (Pred; Decidable) -private - variable - a b c p : Level - A : Set a - B : Set b - C : Set c - m n : ℕ +private + variable + a b c p : Level + A : Set a + B : Set b + C : Set c + m n : ℕ ------------------------------------------------------------------------- --- Types +------------------------------------------------------------------------ +-- Types -infixr 5 _∷_ +infixr 5 _∷_ -data Vec (A : Set a) : ℕ → Set a where - [] : Vec A zero - _∷_ : ∀ (x : A) (xs : Vec A n) → Vec A (suc n) +data Vec (A : Set a) : ℕ → Set a where + [] : Vec A zero + _∷_ : ∀ (x : A) (xs : Vec A n) → Vec A (suc n) -infix 4 _[_]=_ +infix 4 _[_]=_ -data _[_]=_ {A : Set a} : Vec A n → Fin n → A → Set a where - here : ∀ {x} {xs : Vec A n} → x ∷ xs [ zero ]= x - there : ∀ {i} {x y} {xs : Vec A n} - (xs[i]=x : xs [ i ]= x) → y ∷ xs [ suc i ]= x +data _[_]=_ {A : Set a} : Vec A n → Fin n → A → Set a where + here : ∀ {x} {xs : Vec A n} → x ∷ xs [ zero ]= x + there : ∀ {i} {x y} {xs : Vec A n} + (xs[i]=x : xs [ i ]= x) → y ∷ xs [ suc i ]= x ------------------------------------------------------------------------- --- Basic operations +------------------------------------------------------------------------ +-- Basic operations -length : Vec A n → ℕ -length {n = n} _ = n +length : Vec A n → ℕ +length {n = n} _ = n -head : Vec A (1 + n) → A -head (x ∷ xs) = x +head : Vec A (1 + n) → A +head (x ∷ xs) = x -tail : Vec A (1 + n) → Vec A n -tail (x ∷ xs) = xs +tail : Vec A (1 + n) → Vec A n +tail (x ∷ xs) = xs -lookup : Vec A n → Fin n → A -lookup (x ∷ xs) zero = x -lookup (x ∷ xs) (suc i) = lookup xs i +lookup : Vec A n → Fin n → A +lookup (x ∷ xs) zero = x +lookup (x ∷ xs) (suc i) = lookup xs i -iterate : (A → A) → A → ∀ {n} → Vec A n -iterate s z {zero} = [] -iterate s z {suc n} = z ∷ iterate s (s z) +iterate : (A → A) → A → ∀ n → Vec A n +iterate s z zero = [] +iterate s z (suc n) = z ∷ iterate s (s z) n -insert : Vec A n → Fin (suc n) → A → Vec A (suc n) -insert xs zero v = v ∷ xs -insert (x ∷ xs) (suc i) v = x ∷ insert xs i v +insertAt : Vec A n → Fin (suc n) → A → Vec A (suc n) +insertAt xs zero v = v ∷ xs +insertAt (x ∷ xs) (suc i) v = x ∷ insertAt xs i v -remove : Vec A (suc n) → Fin (suc n) → Vec A n -remove (_ ∷ xs) zero = xs -remove (x ∷ y ∷ xs) (suc i) = x ∷ remove (y ∷ xs) i +removeAt : Vec A (suc n) → Fin (suc n) → Vec A n +removeAt (x ∷ xs) zero = xs +removeAt (x ∷ xs@(_ ∷ _)) (suc i) = x ∷ removeAt xs i -updateAt : Fin n → (A → A) → Vec A n → Vec A n -updateAt zero f (x ∷ xs) = f x ∷ xs -updateAt (suc i) f (x ∷ xs) = x ∷ updateAt i f xs +updateAt : Vec A n → Fin n → (A → A) → Vec A n +updateAt (x ∷ xs) zero f = f x ∷ xs +updateAt (x ∷ xs) (suc i) f = x ∷ updateAt xs i f --- xs [ i ]%= f modifies the i-th element of xs according to f +-- xs [ i ]%= f modifies the i-th element of xs according to f -infixl 6 _[_]%=_ +infixl 6 _[_]%=_ _[_]≔_ -_[_]%=_ : Vec A n → Fin n → (A → A) → Vec A n -xs [ i ]%= f = updateAt i f xs +_[_]%=_ : Vec A n → Fin n → (A → A) → Vec A n +xs [ i ]%= f = updateAt xs i f --- xs [ i ]≔ y overwrites the i-th element of xs with y +-- xs [ i ]≔ y overwrites the i-th element of xs with y -infixl 6 _[_]≔_ +_[_]≔_ : Vec A n → Fin n → A → Vec A n +xs [ i ]≔ y = xs [ i ]%= const y -_[_]≔_ : Vec A n → Fin n → A → Vec A n -xs [ i ]≔ y = xs [ i ]%= const y +------------------------------------------------------------------------ +-- Operations for transforming vectors ------------------------------------------------------------------------- --- Operations for transforming vectors +-- See README.Data.Vec.Relation.Binary.Equality.Cast for the reasoning +-- system of `cast`-ed equality. +cast : .(eq : m ≡ n) → Vec A m → Vec A n +cast {n = zero} eq [] = [] +cast {n = suc _} eq (x ∷ xs) = x ∷ cast (cong pred eq) xs -cast : .(eq : m ≡ n) → Vec A m → Vec A n -cast {n = zero} eq [] = [] -cast {n = suc _} eq (x ∷ xs) = x ∷ cast (cong pred eq) xs +map : (A → B) → Vec A n → Vec B n +map f [] = [] +map f (x ∷ xs) = f x ∷ map f xs -map : (A → B) → Vec A n → Vec B n -map f [] = [] -map f (x ∷ xs) = f x ∷ map f xs +-- Concatenation. --- Concatenation. +infixr 5 _++_ -infixr 5 _++_ +_++_ : Vec A m → Vec A n → Vec A (m + n) +[] ++ ys = ys +(x ∷ xs) ++ ys = x ∷ (xs ++ ys) -_++_ : Vec A m → Vec A n → Vec A (m + n) -[] ++ ys = ys -(x ∷ xs) ++ ys = x ∷ (xs ++ ys) +concat : Vec (Vec A m) n → Vec A (n * m) +concat [] = [] +concat (xs ∷ xss) = xs ++ concat xss -concat : Vec (Vec A m) n → Vec A (n * m) -concat [] = [] -concat (xs ∷ xss) = xs ++ concat xss +-- Align, Restrict, and Zip. --- Align, Restrict, and Zip. +alignWith : (These A B → C) → Vec A m → Vec B n → Vec C (m ⊔ n) +alignWith f [] bs = map (f ∘′ that) bs +alignWith f as@(_ ∷ _) [] = map (f ∘′ this) as +alignWith f (a ∷ as) (b ∷ bs) = f (these a b) ∷ alignWith f as bs -alignWith : (These A B → C) → Vec A m → Vec B n → Vec C (m ⊔ n) -alignWith f [] bs = map (f ∘′ that) bs -alignWith f as@(_ ∷ _) [] = map (f ∘′ this) as -alignWith f (a ∷ as) (b ∷ bs) = f (these a b) ∷ alignWith f as bs +restrictWith : (A → B → C) → Vec A m → Vec B n → Vec C (m ⊓ n) +restrictWith f [] bs = [] +restrictWith f (_ ∷ _) [] = [] +restrictWith f (a ∷ as) (b ∷ bs) = f a b ∷ restrictWith f as bs -restrictWith : (A → B → C) → Vec A m → Vec B n → Vec C (m ⊓ n) -restrictWith f [] bs = [] -restrictWith f (_ ∷ _) [] = [] -restrictWith f (a ∷ as) (b ∷ bs) = f a b ∷ restrictWith f as bs +zipWith : (A → B → C) → Vec A n → Vec B n → Vec C n +zipWith f [] [] = [] +zipWith f (x ∷ xs) (y ∷ ys) = f x y ∷ zipWith f xs ys -zipWith : (A → B → C) → Vec A n → Vec B n → Vec C n -zipWith f [] [] = [] -zipWith f (x ∷ xs) (y ∷ ys) = f x y ∷ zipWith f xs ys +unzipWith : (A → B × C) → Vec A n → Vec B n × Vec C n +unzipWith f [] = [] , [] +unzipWith f (a ∷ as) = Prod.zip _∷_ _∷_ (f a) (unzipWith f as) -unzipWith : (A → B × C) → Vec A n → Vec B n × Vec C n -unzipWith f [] = [] , [] -unzipWith f (a ∷ as) = Prod.zip _∷_ _∷_ (f a) (unzipWith f as) +align : Vec A m → Vec B n → Vec (These A B) (m ⊔ n) +align = alignWith id -align : Vec A m → Vec B n → Vec (These A B) (m ⊔ n) -align = alignWith id +restrict : Vec A m → Vec B n → Vec (A × B) (m ⊓ n) +restrict = restrictWith _,_ -restrict : Vec A m → Vec B n → Vec (A × B) (m ⊓ n) -restrict = restrictWith _,_ +zip : Vec A n → Vec B n → Vec (A × B) n +zip = zipWith _,_ -zip : Vec A n → Vec B n → Vec (A × B) n -zip = zipWith _,_ +unzip : Vec (A × B) n → Vec A n × Vec B n +unzip = unzipWith id -unzip : Vec (A × B) n → Vec A n × Vec B n -unzip = unzipWith id +-- Interleaving. --- Interleaving. +infixr 5 _⋎_ -infixr 5 _⋎_ +_⋎_ : Vec A m → Vec A n → Vec A (m +⋎ n) +[] ⋎ ys = ys +(x ∷ xs) ⋎ ys = x ∷ (ys ⋎ xs) -_⋎_ : Vec A m → Vec A n → Vec A (m +⋎ n) -[] ⋎ ys = ys -(x ∷ xs) ⋎ ys = x ∷ (ys ⋎ xs) +-- Pointwise application --- Pointwise application +infixl 4 _⊛_ -infixl 4 _⊛_ +_⊛_ : Vec (A → B) n → Vec A n → Vec B n +[] ⊛ [] = [] +(f ∷ fs) ⊛ (x ∷ xs) = f x ∷ (fs ⊛ xs) -_⊛_ : Vec (A → B) n → Vec A n → Vec B n -[] ⊛ [] = [] -(f ∷ fs) ⊛ (x ∷ xs) = f x ∷ (fs ⊛ xs) +-- Multiplication --- Multiplication +module CartesianBind where + infixl 1 _>>=_ -module CartesianBind where - infixl 1 _>>=_ + _>>=_ : Vec A m → (A → Vec B n) → Vec B (m * n) + xs >>= f = concat (map f xs) - _>>=_ : Vec A m → (A → Vec B n) → Vec B (m * n) - xs >>= f = concat (map f xs) +infixl 4 _⊛*_ -infixl 4 _⊛*_ +_⊛*_ : Vec (A → B) m → Vec A n → Vec B (m * n) +fs ⊛* xs = fs CartesianBind.>>= λ f → map f xs -_⊛*_ : Vec (A → B) m → Vec A n → Vec B (m * n) -fs ⊛* xs = fs CartesianBind.>>= λ f → map f xs +allPairs : Vec A m → Vec B n → Vec (A × B) (m * n) +allPairs xs ys = map _,_ xs ⊛* ys -allPairs : Vec A m → Vec B n → Vec (A × B) (m * n) -allPairs xs ys = map _,_ xs ⊛* ys +-- Diagonal --- Diagonal +diagonal : Vec (Vec A n) n → Vec A n +diagonal [] = [] +diagonal (xs ∷ xss) = head xs ∷ diagonal (map tail xss) -diagonal : Vec (Vec A n) n → Vec A n -diagonal [] = [] -diagonal (xs ∷ xss) = head xs ∷ diagonal (map tail xss) +module DiagonalBind where + infixl 1 _>>=_ -module DiagonalBind where - infixl 1 _>>=_ + _>>=_ : Vec A n → (A → Vec B n) → Vec B n + xs >>= f = diagonal (map f xs) - _>>=_ : Vec A n → (A → Vec B n) → Vec B n - xs >>= f = diagonal (map f xs) - join : Vec (Vec A n) n → Vec A n - join = _>>= id +------------------------------------------------------------------------ +-- Operations for reducing vectors ------------------------------------------------------------------------- --- Operations for reducing vectors +-- Dependent folds --- Dependent folds +module _ (A : Set a) (B : ℕ → Set b) where -module _ (A : Set a) (B : ℕ → Set b) where + FoldrOp = ∀ {n} → A → B n → B (suc n) + FoldlOp = ∀ {n} → B n → A → B (suc n) - FoldrOp = ∀ {n} → A → B n → B (suc n) - FoldlOp = ∀ {n} → B n → A → B (suc n) +foldr : ∀ (B : ℕ → Set b) → FoldrOp A B → B zero → Vec A n → B n +foldr B _⊕_ e [] = e +foldr B _⊕_ e (x ∷ xs) = x ⊕ foldr B _⊕_ e xs -foldr : ∀ (B : ℕ → Set b) → FoldrOp A B → B zero → Vec A n → B n -foldr B _⊕_ e [] = e -foldr B _⊕_ e (x ∷ xs) = x ⊕ foldr B _⊕_ e xs +foldl : ∀ (B : ℕ → Set b) → FoldlOp A B → B zero → Vec A n → B n +foldl B _⊕_ e [] = e +foldl B _⊕_ e (x ∷ xs) = foldl (B ∘ suc) _⊕_ (e ⊕ x) xs -foldl : ∀ (B : ℕ → Set b) → FoldlOp A B → B zero → Vec A n → B n -foldl B _⊕_ e [] = e -foldl B _⊕_ e (x ∷ xs) = foldl (B ∘ suc) _⊕_ (e ⊕ x) xs +-- Non-dependent folds --- Non-dependent folds +foldr′ : (A → B → B) → B → Vec A n → B +foldr′ _⊕_ = foldr _ _⊕_ -foldr′ : (A → B → B) → B → Vec A n → B -foldr′ _⊕_ = foldr _ _⊕_ +foldl′ : (B → A → B) → B → Vec A n → B +foldl′ _⊕_ = foldl _ _⊕_ -foldl′ : (B → A → B) → B → Vec A n → B -foldl′ _⊕_ = foldl _ _⊕_ +-- Non-empty folds --- Non-empty folds +foldr₁ : (A → A → A) → Vec A (suc n) → A +foldr₁ _⊕_ (x ∷ []) = x +foldr₁ _⊕_ (x ∷ y ∷ ys) = x ⊕ foldr₁ _⊕_ (y ∷ ys) -foldr₁ : (A → A → A) → Vec A (suc n) → A -foldr₁ _⊕_ (x ∷ []) = x -foldr₁ _⊕_ (x ∷ y ∷ ys) = x ⊕ foldr₁ _⊕_ (y ∷ ys) +foldl₁ : (A → A → A) → Vec A (suc n) → A +foldl₁ _⊕_ (x ∷ xs) = foldl _ _⊕_ x xs -foldl₁ : (A → A → A) → Vec A (suc n) → A -foldl₁ _⊕_ (x ∷ xs) = foldl _ _⊕_ x xs +-- Special folds --- Special folds +sum : Vec ℕ n → ℕ +sum = foldr _ _+_ 0 -sum : Vec ℕ n → ℕ -sum = foldr _ _+_ 0 +count : ∀ {P : Pred A p} → Decidable P → Vec A n → ℕ +count P? [] = zero +count P? (x ∷ xs) with does (P? x) +... | true = suc (count P? xs) +... | false = count P? xs -countᵇ : (A → Bool) → Vec A n → ℕ -countᵇ p [] = zero -countᵇ p (x ∷ xs) = if p x then suc (countᵇ p xs) else countᵇ p xs +countᵇ : (A → Bool) → Vec A n → ℕ +countᵇ p = count (T? ∘ p) -count : ∀ {P : Pred A p} → Decidable P → Vec A n → ℕ -count P? = countᵇ (does ∘ P?) +------------------------------------------------------------------------ +-- Operations for building vectors ------------------------------------------------------------------------- --- Operations for building vectors +[_] : A → Vec A 1 +[ x ] = x ∷ [] -[_] : A → Vec A 1 -[ x ] = x ∷ [] +replicate : (n : ℕ) → A → Vec A n +replicate zero x = [] +replicate (suc n) x = x ∷ replicate n x -replicate : A → Vec A n -replicate {n = zero} x = [] -replicate {n = suc n} x = x ∷ replicate x +tabulate : (Fin n → A) → Vec A n +tabulate {n = zero} f = [] +tabulate {n = suc n} f = f zero ∷ tabulate (f ∘ suc) -tabulate : (Fin n → A) → Vec A n -tabulate {n = zero} f = [] -tabulate {n = suc n} f = f zero ∷ tabulate (f ∘ suc) +allFin : ∀ n → Vec (Fin n) n +allFin _ = tabulate id -allFin : ∀ n → Vec (Fin n) n -allFin _ = tabulate id +------------------------------------------------------------------------ +-- Operations for dividing vectors ------------------------------------------------------------------------- --- Operations for dividing vectors +splitAt : ∀ m {n} (xs : Vec A (m + n)) → + ∃₂ λ (ys : Vec A m) (zs : Vec A n) → xs ≡ ys ++ zs +splitAt zero xs = [] , xs , refl +splitAt (suc m) (x ∷ xs) = + let ys , zs , eq = splitAt m xs in x ∷ ys , zs , cong (x ∷_) eq -splitAt : ∀ m {n} (xs : Vec A (m + n)) → - ∃₂ λ (ys : Vec A m) (zs : Vec A n) → xs ≡ ys ++ zs -splitAt zero xs = ([] , xs , refl) -splitAt (suc m) (x ∷ xs) with splitAt m xs -splitAt (suc m) (x ∷ .(ys ++ zs)) | (ys , zs , refl) = - ((x ∷ ys) , zs , refl) +take : ∀ m {n} → Vec A (m + n) → Vec A m +take m xs = proj₁ (splitAt m xs) -take : ∀ m {n} → Vec A (m + n) → Vec A m -take m xs with splitAt m xs -take m .(ys ++ zs) | (ys , zs , refl) = ys +drop : ∀ m {n} → Vec A (m + n) → Vec A n +drop m xs = proj₁ (proj₂ (splitAt m xs)) -drop : ∀ m {n} → Vec A (m + n) → Vec A n -drop m xs with splitAt m xs -drop m .(ys ++ zs) | (ys , zs , refl) = zs +group : ∀ n k (xs : Vec A (n * k)) → + ∃ λ (xss : Vec (Vec A k) n) → xs ≡ concat xss +group zero k [] = ([] , refl) +group (suc n) k xs = + let ys , zs , eq-split = splitAt k xs in + let zss , eq-group = group n k zs in + (ys ∷ zss) , trans eq-split (cong (ys ++_) eq-group) -group : ∀ n k (xs : Vec A (n * k)) → - ∃ λ (xss : Vec (Vec A k) n) → xs ≡ concat xss -group zero k [] = ([] , refl) -group (suc n) k xs with splitAt k xs -group (suc n) k .(ys ++ zs) | (ys , zs , refl) with group n k zs -group (suc n) k .(ys ++ concat zss) | (ys , ._ , refl) | (zss , refl) = - ((ys ∷ zss) , refl) +split : Vec A n → Vec A ⌈ n /2⌉ × Vec A ⌊ n /2⌋ +split [] = ([] , []) +split (x ∷ []) = (x ∷ [] , []) +split (x ∷ y ∷ xs) = Prod.map (x ∷_) (y ∷_) (split xs) -split : Vec A n → Vec A ⌈ n /2⌉ × Vec A ⌊ n /2⌋ -split [] = ([] , []) -split (x ∷ []) = (x ∷ [] , []) -split (x ∷ y ∷ xs) = Prod.map (x ∷_) (y ∷_) (split xs) +uncons : Vec A (suc n) → A × Vec A n +uncons (x ∷ xs) = x , xs -uncons : Vec A (suc n) → A × Vec A n -uncons (x ∷ xs) = x , xs +------------------------------------------------------------------------ +-- Operations involving ≤ ------------------------------------------------------------------------- --- Operations involving ≤ +-- Take the first 'm' elements of a vector. +truncate : ∀ {m n} → m ≤ n → Vec A n → Vec A m +truncate {m = zero} _ _ = [] +truncate (s≤s le) (x ∷ xs) = x ∷ (truncate le xs) --- Take the first 'm' elements of a vector. -truncate : ∀ {m n} → m ≤ n → Vec A n → Vec A m -truncate z≤n _ = [] -truncate (s≤s le) (x ∷ xs) = x ∷ (truncate le xs) +-- Pad out a vector with extra elements. +padRight : ∀ {m n} → m ≤ n → A → Vec A m → Vec A n +padRight z≤n a xs = replicate _ a +padRight (s≤s le) a (x ∷ xs) = x ∷ padRight le a xs --- Pad out a vector with extra elements. -padRight : ∀ {m n} → m ≤ n → A → Vec A m → Vec A n -padRight z≤n a xs = replicate a -padRight (s≤s le) a (x ∷ xs) = x ∷ padRight le a xs +------------------------------------------------------------------------ +-- Operations for converting between lists ------------------------------------------------------------------------- --- Operations for converting between lists +toList : Vec A n → List A +toList [] = List.[] +toList (x ∷ xs) = List._∷_ x (toList xs) -toList : Vec A n → List A -toList [] = List.[] -toList (x ∷ xs) = List._∷_ x (toList xs) +fromList : (xs : List A) → Vec A (List.length xs) +fromList List.[] = [] +fromList (List._∷_ x xs) = x ∷ fromList xs -fromList : (xs : List A) → Vec A (List.length xs) -fromList List.[] = [] -fromList (List._∷_ x xs) = x ∷ fromList xs +------------------------------------------------------------------------ +-- Operations for reversing vectors ------------------------------------------------------------------------- --- Operations for reversing vectors +-- snoc --- snoc +infixl 5 _∷ʳ_ -infixl 5 _∷ʳ_ +_∷ʳ_ : Vec A n → A → Vec A (suc n) +[] ∷ʳ y = [ y ] +(x ∷ xs) ∷ʳ y = x ∷ (xs ∷ʳ y) -_∷ʳ_ : Vec A n → A → Vec A (suc n) -[] ∷ʳ y = [ y ] -(x ∷ xs) ∷ʳ y = x ∷ (xs ∷ʳ y) +-- vanilla reverse --- vanilla reverse +reverse : Vec A n → Vec A n +reverse = foldl (Vec _) (λ rev x → x ∷ rev) [] -reverse : Vec A n → Vec A n -reverse = foldl (Vec _) (λ rev x → x ∷ rev) [] +-- reverse-append --- reverse-append +infix 5 _ʳ++_ -infix 5 _ʳ++_ +_ʳ++_ : Vec A m → Vec A n → Vec A (m + n) +xs ʳ++ ys = foldl (Vec _ ∘ (_+ _)) (λ rev x → x ∷ rev) ys xs -_ʳ++_ : Vec A m → Vec A n → Vec A (m + n) -xs ʳ++ ys = foldl (Vec _ ∘ (_+ _)) (λ rev x → x ∷ rev) ys xs +-- init and last --- init and last +initLast : ∀ (xs : Vec A (1 + n)) → ∃₂ λ ys y → xs ≡ ys ∷ʳ y +initLast {n = zero} (x ∷ []) = [] , x , refl +initLast {n = suc n} (x ∷ xs) = + let ys , y , eq = initLast xs in + x ∷ ys , y , cong (x ∷_) eq -initLast : ∀ (xs : Vec A (1 + n)) → ∃₂ λ ys y → xs ≡ ys ∷ʳ y -initLast {n = zero} (x ∷ []) = ([] , x , refl) -initLast {n = suc n} (x ∷ xs) with initLast xs -... | (ys , y , refl) = (x ∷ ys , y , refl) +init : Vec A (1 + n) → Vec A n +init xs = proj₁ (initLast xs) -init : Vec A (1 + n) → Vec A n -init xs with initLast xs -... | (ys , y , refl) = ys +last : Vec A (1 + n) → A +last xs = proj₁ (proj₂ (initLast xs)) -last : Vec A (1 + n) → A -last xs with initLast xs -... | (ys , y , refl) = y +------------------------------------------------------------------------ +-- Other operations ------------------------------------------------------------------------- --- Other operations +transpose : Vec (Vec A n) m → Vec (Vec A m) n +transpose {n = n} [] = replicate n [] +transpose {n = n} (as ∷ ass) = ((replicate n _∷_) ⊛ as) ⊛ transpose ass -transpose : Vec (Vec A n) m → Vec (Vec A m) n -transpose [] = replicate [] -transpose (as ∷ ass) = replicate _∷_ ⊛ as ⊛ transpose ass +------------------------------------------------------------------------ +-- DEPRECATED +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 2.0 + +remove = removeAt +{-# WARNING_ON_USAGE remove +"Warning: remove was deprecated in v2.0. +Please use removeAt instead." +#-} +insert = insertAt +{-# WARNING_ON_USAGE insert +"Warning: insert was deprecated in v2.0. +Please use insertAt instead." +#-} \ No newline at end of file diff --git a/Data.Vec.Functional.html b/Data.Vec.Functional.html index 65d16866..326ce994 100644 --- a/Data.Vec.Functional.html +++ b/Data.Vec.Functional.html @@ -18,141 +18,161 @@ open import Data.Fin.Base open import Data.List.Base as L using (List) -open import Data.Nat.Base as ℕ using (ℕ; zero; suc; NonZero; pred) -open import Data.Product using (Σ; ∃; _×_; _,_; proj₁; proj₂; uncurry) -open import Data.Sum.Base using (_⊎_; inj₁; inj₂; [_,_]) -open import Data.Vec.Base as V using (Vec) -open import Function.Base -open import Level using (Level) +open import Data.Nat.Base as ℕ using (ℕ; zero; suc; NonZero; pred) +open import Data.Product.Base using (Σ; ∃; _×_; _,_; proj₁; proj₂; uncurry) +open import Data.Sum.Base using (_⊎_; inj₁; inj₂; [_,_]) +open import Data.Vec.Base as V using (Vec) +open import Function.Base using (_∘_; const; flip; _ˢ_; id) +open import Level using (Level) -infixr 5 _∷_ _++_ -infixl 4 _⊛_ -infixl 1 _>>=_ +infixr 5 _∷_ _++_ +infixl 4 _⊛_ +infixl 1 _>>=_ -private - variable - a b c : Level - A : Set a - B : Set b - C : Set c +private + variable + a b c : Level + A B C : Set a + m n : ℕ ------------------------------------------------------------------------- --- Definition +------------------------------------------------------------------------ +-- Definition -Vector : Set a → ℕ → Set a -Vector A n = Fin n → A +Vector : Set a → ℕ → Set a +Vector A n = Fin n → A ------------------------------------------------------------------------- --- Conversion +------------------------------------------------------------------------ +-- Conversion -toVec : ∀ {n} → Vector A n → Vec A n -toVec = V.tabulate +toVec : Vector A n → Vec A n +toVec = V.tabulate -fromVec : ∀ {n} → Vec A n → Vector A n -fromVec = V.lookup +fromVec : Vec A n → Vector A n +fromVec = V.lookup -toList : ∀ {n} → Vector A n → List A -toList = L.tabulate +toList : Vector A n → List A +toList = L.tabulate -fromList : ∀ (xs : List A) → Vector A (L.length xs) -fromList = L.lookup +fromList : ∀ (xs : List A) → Vector A (L.length xs) +fromList = L.lookup ------------------------------------------------------------------------- --- Basic operations +------------------------------------------------------------------------ +-- Basic operations -[] : Vector A zero -[] () +[] : Vector A zero +[] () -_∷_ : ∀ {n} → A → Vector A n → Vector A (suc n) -(x ∷ xs) zero = x -(x ∷ xs) (suc i) = xs i +_∷_ : A → Vector A n → Vector A (suc n) +(x ∷ xs) zero = x +(x ∷ xs) (suc i) = xs i -length : ∀ {n} → Vector A n → ℕ -length {n = n} _ = n +length : Vector A n → ℕ +length {n = n} _ = n -head : ∀ {n} → Vector A (suc n) → A -head xs = xs zero +head : Vector A (suc n) → A +head xs = xs zero -tail : ∀ {n} → Vector A (suc n) → Vector A n -tail xs = xs ∘ suc +tail : Vector A (suc n) → Vector A n +tail xs = xs ∘ suc -uncons : ∀ {n} → Vector A (suc n) → A × Vector A n -uncons xs = head xs , tail xs +uncons : Vector A (suc n) → A × Vector A n +uncons xs = head xs , tail xs -replicate : ∀ {n} → A → Vector A n -replicate = const +replicate : (n : ℕ) → A → Vector A n +replicate n = const -insert : ∀ {n} → Vector A n → Fin (suc n) → A → Vector A (suc n) -insert {n = n} xs zero v zero = v -insert {n = n} xs zero v (suc j) = xs j -insert {n = suc n} xs (suc i) v zero = head xs -insert {n = suc n} xs (suc i) v (suc j) = insert (tail xs) i v j +insertAt : Vector A n → Fin (suc n) → A → Vector A (suc n) +insertAt {n = n} xs zero v zero = v +insertAt {n = n} xs zero v (suc j) = xs j +insertAt {n = suc n} xs (suc i) v zero = head xs +insertAt {n = suc n} xs (suc i) v (suc j) = insertAt (tail xs) i v j -remove : ∀ {n} → Fin (suc n) → Vector A (suc n) → Vector A n -remove i t = t ∘ punchIn i +removeAt : Vector A (suc n) → Fin (suc n) → Vector A n +removeAt t i = t ∘ punchIn i -updateAt : ∀ {n} → Fin n → (A → A) → Vector A n → Vector A n -updateAt {n = suc n} zero f xs zero = f (head xs) -updateAt {n = suc n} zero f xs (suc j) = xs (suc j) -updateAt {n = suc n} (suc i) f xs zero = head xs -updateAt {n = suc n} (suc i) f xs (suc j) = updateAt i f (tail xs) j +updateAt : Vector A n → Fin n → (A → A) → Vector A n +updateAt {n = suc n} xs zero f zero = f (head xs) +updateAt {n = suc n} xs zero f (suc j) = xs (suc j) +updateAt {n = suc n} xs (suc i) f zero = head xs +updateAt {n = suc n} xs (suc i) f (suc j) = updateAt (tail xs) i f j ------------------------------------------------------------------------- --- Transformations +------------------------------------------------------------------------ +-- Transformations -map : (A → B) → ∀ {n} → Vector A n → Vector B n -map f xs = f ∘ xs +map : (A → B) → ∀ {n} → Vector A n → Vector B n +map f xs = f ∘ xs -_++_ : ∀ {m n} → Vector A m → Vector A n → Vector A (m ℕ.+ n) -_++_ {m = m} xs ys i = [ xs , ys ] (splitAt m i) +_++_ : Vector A m → Vector A n → Vector A (m ℕ.+ n) +_++_ {m = m} xs ys i = [ xs , ys ] (splitAt m i) -concat : ∀ {m n} → Vector (Vector A m) n → Vector A (n ℕ.* m) -concat {m = m} xss i = uncurry (flip xss) (quotRem m i) +concat : Vector (Vector A m) n → Vector A (n ℕ.* m) +concat {m = m} xss i = uncurry (flip xss) (quotRem m i) -foldr : (A → B → B) → B → ∀ {n} → Vector A n → B -foldr f z {n = zero} xs = z -foldr f z {n = suc n} xs = f (head xs) (foldr f z (tail xs)) +foldr : (A → B → B) → B → ∀ {n} → Vector A n → B +foldr f z {n = zero} xs = z +foldr f z {n = suc n} xs = f (head xs) (foldr f z (tail xs)) -foldl : (B → A → B) → B → ∀ {n} → Vector A n → B -foldl f z {n = zero} xs = z -foldl f z {n = suc n} xs = foldl f (f z (head xs)) (tail xs) +foldl : (B → A → B) → B → ∀ {n} → Vector A n → B +foldl f z {n = zero} xs = z +foldl f z {n = suc n} xs = foldl f (f z (head xs)) (tail xs) -rearrange : ∀ {m n} → (Fin m → Fin n) → Vector A n → Vector A m -rearrange r xs = xs ∘ r +rearrange : (Fin m → Fin n) → Vector A n → Vector A m +rearrange r xs = xs ∘ r -_⊛_ : ∀ {n} → Vector (A → B) n → Vector A n → Vector B n -_⊛_ = _ˢ_ +_⊛_ : Vector (A → B) n → Vector A n → Vector B n +_⊛_ = _ˢ_ -_>>=_ : ∀ {m n} → Vector A m → (A → Vector B n) → Vector B (m ℕ.* n) -xs >>= f = concat (map f xs) +_>>=_ : Vector A m → (A → Vector B n) → Vector B (m ℕ.* n) +xs >>= f = concat (map f xs) -zipWith : (A → B → C) → ∀ {n} → Vector A n → Vector B n → Vector C n -zipWith f xs ys i = f (xs i) (ys i) +zipWith : (A → B → C) → ∀ {n} → Vector A n → Vector B n → Vector C n +zipWith f xs ys i = f (xs i) (ys i) -unzipWith : ∀ {n} → (A → B × C) → Vector A n → Vector B n × Vector C n -unzipWith f xs = proj₁ ∘ f ∘ xs , proj₂ ∘ f ∘ xs +unzipWith : (A → B × C) → Vector A n → Vector B n × Vector C n +unzipWith f xs = proj₁ ∘ f ∘ xs , proj₂ ∘ f ∘ xs -zip : ∀ {n} → Vector A n → Vector B n → Vector (A × B) n -zip = zipWith _,_ +zip : Vector A n → Vector B n → Vector (A × B) n +zip = zipWith _,_ -unzip : ∀ {n} → Vector (A × B) n → Vector A n × Vector B n -unzip = unzipWith id +unzip : Vector (A × B) n → Vector A n × Vector B n +unzip = unzipWith id -take : ∀ m {n} → Vector A (m ℕ.+ n) → Vector A m -take _ {n = n} xs = xs ∘ (_↑ˡ n) +take : ∀ m {n} → Vector A (m ℕ.+ n) → Vector A m +take _ {n = n} xs = xs ∘ (_↑ˡ n) -drop : ∀ m {n} → Vector A (m ℕ.+ n) → Vector A n -drop m xs = xs ∘ (m ↑ʳ_) +drop : ∀ m {n} → Vector A (m ℕ.+ n) → Vector A n +drop m xs = xs ∘ (m ↑ʳ_) -reverse : ∀ {n} → Vector A n → Vector A n -reverse xs = xs ∘ opposite +reverse : Vector A n → Vector A n +reverse xs = xs ∘ opposite -init : ∀ {n} → Vector A (suc n) → Vector A n -init xs = xs ∘ inject₁ +init : Vector A (suc n) → Vector A n +init xs = xs ∘ inject₁ -last : ∀ {n} → Vector A (suc n) → A -last {n = n} xs = xs (fromℕ n) +last : Vector A (suc n) → A +last {n = n} xs = xs (fromℕ n) -transpose : ∀ {m n} → Vector (Vector A n) m → Vector (Vector A m) n -transpose = flip +transpose : Vector (Vector A n) m → Vector (Vector A m) n +transpose = flip + +------------------------------------------------------------------------ +-- DEPRECATED +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 2.0 + +remove : Fin (suc n) → Vector A (suc n) → Vector A n +remove = flip removeAt +{-# WARNING_ON_USAGE remove +"Warning: remove was deprecated in v2.0. +Please use removeAt instead. +NOTE: argument order has been flipped." +#-} +insert = insertAt +{-# WARNING_ON_USAGE insert +"Warning: insert was deprecated in v2.0. +Please use insertAt instead." +#-} \ No newline at end of file diff --git a/Data.Vec.N-ary.html b/Data.Vec.N-ary.html index 51dfc1e7..52d3d31e 100644 --- a/Data.Vec.N-ary.html +++ b/Data.Vec.N-ary.html @@ -10,180 +10,181 @@ module Data.Vec.N-ary where open import Axiom.Extensionality.Propositional using (Extensionality) -open import Function.Bundles using (_↔_; Inverse; mk↔′) -open import Data.Nat.Base hiding (_⊔_) -open import Data.Product as Prod -open import Data.Vec.Base -open import Function.Base -open import Function.Bundles using (_⇔_; mk⇔) -open import Level using (Level; _⊔_) -open import Relation.Binary hiding (_⇔_) -open import Relation.Binary.PropositionalEquality -open import Relation.Nullary.Decidable +open import Function.Bundles using (_↔_; Inverse; mk↔ₛ′) +open import Data.Nat.Base hiding (_⊔_) +open import Data.Product.Base as Prod using (∃; _,_) +open import Data.Vec.Base using (Vec; []; _∷_; head; tail) +open import Function.Base using (_∘_; id; flip; constᵣ) +open import Function.Bundles using (_⇔_; mk⇔) +open import Level using (Level; _⊔_) +open import Relation.Binary.Core using (REL) +open import Relation.Binary.PropositionalEquality.Core using (_≡_; refl; cong) -private - variable - a b c ℓ ℓ₁ ℓ₂ : Level - A : Set a - B : Set b - C : Set c +private + variable + a b c ℓ ℓ₁ ℓ₂ : Level + A : Set a + B : Set b + C : Set c ------------------------------------------------------------------------- --- N-ary functions - -N-ary-level : Level → Level → ℕ → Level -N-ary-level ℓ₁ ℓ₂ zero = ℓ₂ -N-ary-level ℓ₁ ℓ₂ (suc n) = ℓ₁ ⊔ N-ary-level ℓ₁ ℓ₂ n +------------------------------------------------------------------------ +-- N-ary functions -N-ary : ∀ (n : ℕ) → Set ℓ₁ → Set ℓ₂ → Set (N-ary-level ℓ₁ ℓ₂ n) -N-ary zero A B = B -N-ary (suc n) A B = A → N-ary n A B +N-ary-level : Level → Level → ℕ → Level +N-ary-level ℓ₁ ℓ₂ zero = ℓ₂ +N-ary-level ℓ₁ ℓ₂ (suc n) = ℓ₁ ⊔ N-ary-level ℓ₁ ℓ₂ n ------------------------------------------------------------------------- --- Conversion - -curryⁿ : ∀ {n} → (Vec A n → B) → N-ary n A B -curryⁿ {n = zero} f = f [] -curryⁿ {n = suc n} f = λ x → curryⁿ (f ∘ _∷_ x) - -_$ⁿ_ : ∀ {n} → N-ary n A B → (Vec A n → B) -f $ⁿ [] = f -f $ⁿ (x ∷ xs) = f x $ⁿ xs - ------------------------------------------------------------------------- --- Quantifiers - -module _ {A : Set a} where - - -- Universal quantifier. - - ∀ⁿ : ∀ n → N-ary n A (Set ℓ) → Set (N-ary-level a ℓ n) - ∀ⁿ zero P = P - ∀ⁿ (suc n) P = ∀ x → ∀ⁿ n (P x) - - -- Universal quantifier with implicit (hidden) arguments. - - ∀ⁿʰ : ∀ n → N-ary n A (Set ℓ) → Set (N-ary-level a ℓ n) - ∀ⁿʰ zero P = P - ∀ⁿʰ (suc n) P = ∀ {x} → ∀ⁿʰ n (P x) - - -- Existential quantifier. - - ∃ⁿ : ∀ n → N-ary n A (Set ℓ) → Set (N-ary-level a ℓ n) - ∃ⁿ zero P = P - ∃ⁿ (suc n) P = ∃ λ x → ∃ⁿ n (P x) - ------------------------------------------------------------------------- --- N-ary function equality - -Eq : ∀ {A : Set a} {B : Set b} {C : Set c} n → - REL B C ℓ → REL (N-ary n A B) (N-ary n A C) (N-ary-level a ℓ n) -Eq n _∼_ f g = ∀ⁿ n (curryⁿ {n = n} λ xs → (f $ⁿ xs) ∼ (g $ⁿ xs)) - --- A variant where all the arguments are implicit (hidden). - -Eqʰ : ∀ {A : Set a} {B : Set b} {C : Set c} n → - REL B C ℓ → REL (N-ary n A B) (N-ary n A C) (N-ary-level a ℓ n) -Eqʰ n _∼_ f g = ∀ⁿʰ n (curryⁿ {n = n} λ xs → (f $ⁿ xs) ∼ (g $ⁿ xs)) - ------------------------------------------------------------------------- --- Some lemmas - --- The functions curryⁿ and _$ⁿ_ are inverses. - -left-inverse : ∀ {n} (f : Vec A n → B) → - ∀ xs → (curryⁿ f $ⁿ xs) ≡ f xs -left-inverse f [] = refl -left-inverse f (x ∷ xs) = left-inverse (f ∘ _∷_ x) xs - -right-inverse : ∀ n (f : N-ary n A B) → - Eq n _≡_ (curryⁿ (_$ⁿ_ {n = n} f)) f -right-inverse zero f = refl -right-inverse (suc n) f = λ x → right-inverse n (f x) - --- ∀ⁿ can be expressed in an "uncurried" way. - -uncurry-∀ⁿ : ∀ n {P : N-ary n A (Set ℓ)} → - ∀ⁿ n P ⇔ (∀ (xs : Vec A n) → P $ⁿ xs) -uncurry-∀ⁿ {a} {A} {ℓ} n = mk⇔ (⇒ n) (⇐ n) - where - ⇒ : ∀ n {P : N-ary n A (Set ℓ)} → - ∀ⁿ n P → (∀ (xs : Vec A n) → P $ⁿ xs) - ⇒ zero p [] = p - ⇒ (suc n) p (x ∷ xs) = ⇒ n (p x) xs - - ⇐ : ∀ n {P : N-ary n A (Set ℓ)} → - (∀ (xs : Vec A n) → P $ⁿ xs) → ∀ⁿ n P - ⇐ zero p = p [] - ⇐ (suc n) p = λ x → ⇐ n (p ∘ _∷_ x) - --- ∃ⁿ can be expressed in an "uncurried" way. - -uncurry-∃ⁿ : ∀ n {P : N-ary n A (Set ℓ)} → - ∃ⁿ n P ⇔ (∃ λ (xs : Vec A n) → P $ⁿ xs) -uncurry-∃ⁿ {a} {A} {ℓ} n = mk⇔ (⇒ n) (⇐ n) - where - ⇒ : ∀ n {P : N-ary n A (Set ℓ)} → - ∃ⁿ n P → (∃ λ (xs : Vec A n) → P $ⁿ xs) - ⇒ zero p = ([] , p) - ⇒ (suc n) (x , p) = Prod.map (_∷_ x) id (⇒ n p) +N-ary : ∀ (n : ℕ) → Set ℓ₁ → Set ℓ₂ → Set (N-ary-level ℓ₁ ℓ₂ n) +N-ary zero A B = B +N-ary (suc n) A B = A → N-ary n A B - ⇐ : ∀ n {P : N-ary n A (Set ℓ)} → - (∃ λ (xs : Vec A n) → P $ⁿ xs) → ∃ⁿ n P - ⇐ zero ([] , p) = p - ⇐ (suc n) (x ∷ xs , p) = (x , ⇐ n (xs , p)) - --- Conversion preserves equality. - -module _ (_∼_ : REL B C ℓ) where - - curryⁿ-cong : ∀ {n} (f : Vec A n → B) (g : Vec A n → C) → - (∀ xs → f xs ∼ g xs) → - Eq n _∼_ (curryⁿ f) (curryⁿ g) - curryⁿ-cong {n = zero} f g hyp = hyp [] - curryⁿ-cong {n = suc n} f g hyp = λ x → - curryⁿ-cong (f ∘ _∷_ x) (g ∘ _∷_ x) (λ xs → hyp (x ∷ xs)) - - curryⁿ-cong⁻¹ : ∀ {n} (f : Vec A n → B) (g : Vec A n → C) → - Eq n _∼_ (curryⁿ f) (curryⁿ g) → - ∀ xs → f xs ∼ g xs - curryⁿ-cong⁻¹ f g hyp [] = hyp - curryⁿ-cong⁻¹ f g hyp (x ∷ xs) = - curryⁿ-cong⁻¹ (f ∘ _∷_ x) (g ∘ _∷_ x) (hyp x) xs - - appⁿ-cong : ∀ {n} (f : N-ary n A B) (g : N-ary n A C) → - Eq n _∼_ f g → - (xs : Vec A n) → (f $ⁿ xs) ∼ (g $ⁿ xs) - appⁿ-cong f g hyp [] = hyp - appⁿ-cong f g hyp (x ∷ xs) = appⁿ-cong (f x) (g x) (hyp x) xs - - appⁿ-cong⁻¹ : ∀ {n} (f : N-ary n A B) (g : N-ary n A C) → - ((xs : Vec A n) → (f $ⁿ xs) ∼ (g $ⁿ xs)) → - Eq n _∼_ f g - appⁿ-cong⁻¹ {n = zero} f g hyp = hyp [] - appⁿ-cong⁻¹ {n = suc n} f g hyp = λ x → - appⁿ-cong⁻¹ (f x) (g x) (λ xs → hyp (x ∷ xs)) - --- Eq and Eqʰ are equivalent. - -Eq-to-Eqʰ : ∀ n (_∼_ : REL B C ℓ) {f : N-ary n A B} {g : N-ary n A C} → - Eq n _∼_ f g → Eqʰ n _∼_ f g -Eq-to-Eqʰ zero _∼_ eq = eq -Eq-to-Eqʰ (suc n) _∼_ eq = Eq-to-Eqʰ n _∼_ (eq _) - -Eqʰ-to-Eq : ∀ n (_∼_ : REL B C ℓ) {f : N-ary n A B} {g : N-ary n A C} → - Eqʰ n _∼_ f g → Eq n _∼_ f g -Eqʰ-to-Eq zero _∼_ eq = eq -Eqʰ-to-Eq (suc n) _∼_ eq = λ _ → Eqʰ-to-Eq n _∼_ eq - -module _ (ext : ∀ {a b} → Extensionality a b) where - - Vec↔N-ary : ∀ n → (Vec A n → B) ↔ N-ary n A B - Vec↔N-ary zero = mk↔′ (λ vxs → vxs []) (flip constᵣ) (λ _ → refl) - (λ vxs → ext λ where [] → refl) - Vec↔N-ary (suc n) = let open Inverse (Vec↔N-ary n) in - mk↔′ (λ vxs x → to λ xs → vxs (x ∷ xs)) - (λ any xs → from (any (head xs)) (tail xs)) - (λ any → ext λ x → inverseˡ _) - (λ vxs → ext λ where (x ∷ xs) → cong (λ f → f xs) (inverseʳ (λ ys → vxs (x ∷ ys)))) +------------------------------------------------------------------------ +-- Conversion + +curryⁿ : ∀ {n} → (Vec A n → B) → N-ary n A B +curryⁿ {n = zero} f = f [] +curryⁿ {n = suc n} f = λ x → curryⁿ (f ∘ _∷_ x) + +infix -1 _$ⁿ_ + +_$ⁿ_ : ∀ {n} → N-ary n A B → (Vec A n → B) +f $ⁿ [] = f +f $ⁿ (x ∷ xs) = f x $ⁿ xs + +------------------------------------------------------------------------ +-- Quantifiers + +module _ {A : Set a} where + + -- Universal quantifier. + + ∀ⁿ : ∀ n → N-ary n A (Set ℓ) → Set (N-ary-level a ℓ n) + ∀ⁿ zero P = P + ∀ⁿ (suc n) P = ∀ x → ∀ⁿ n (P x) + + -- Universal quantifier with implicit (hidden) arguments. + + ∀ⁿʰ : ∀ n → N-ary n A (Set ℓ) → Set (N-ary-level a ℓ n) + ∀ⁿʰ zero P = P + ∀ⁿʰ (suc n) P = ∀ {x} → ∀ⁿʰ n (P x) + + -- Existential quantifier. + + ∃ⁿ : ∀ n → N-ary n A (Set ℓ) → Set (N-ary-level a ℓ n) + ∃ⁿ zero P = P + ∃ⁿ (suc n) P = ∃ λ x → ∃ⁿ n (P x) + +------------------------------------------------------------------------ +-- N-ary function equality + +Eq : ∀ {A : Set a} {B : Set b} {C : Set c} n → + REL B C ℓ → REL (N-ary n A B) (N-ary n A C) (N-ary-level a ℓ n) +Eq n _∼_ f g = ∀ⁿ n (curryⁿ {n = n} λ xs → (f $ⁿ xs) ∼ (g $ⁿ xs)) + +-- A variant where all the arguments are implicit (hidden). + +Eqʰ : ∀ {A : Set a} {B : Set b} {C : Set c} n → + REL B C ℓ → REL (N-ary n A B) (N-ary n A C) (N-ary-level a ℓ n) +Eqʰ n _∼_ f g = ∀ⁿʰ n (curryⁿ {n = n} λ xs → (f $ⁿ xs) ∼ (g $ⁿ xs)) + +------------------------------------------------------------------------ +-- Some lemmas + +-- The functions curryⁿ and _$ⁿ_ are inverses. + +left-inverse : ∀ {n} (f : Vec A n → B) → + ∀ xs → (curryⁿ f $ⁿ xs) ≡ f xs +left-inverse f [] = refl +left-inverse f (x ∷ xs) = left-inverse (f ∘ _∷_ x) xs + +right-inverse : ∀ n (f : N-ary n A B) → + Eq n _≡_ (curryⁿ (_$ⁿ_ {n = n} f)) f +right-inverse zero f = refl +right-inverse (suc n) f = λ x → right-inverse n (f x) + +-- ∀ⁿ can be expressed in an "uncurried" way. + +uncurry-∀ⁿ : ∀ n {P : N-ary n A (Set ℓ)} → + ∀ⁿ n P ⇔ (∀ (xs : Vec A n) → P $ⁿ xs) +uncurry-∀ⁿ {a} {A} {ℓ} n = mk⇔ (⇒ n) (⇐ n) + where + ⇒ : ∀ n {P : N-ary n A (Set ℓ)} → + ∀ⁿ n P → (∀ (xs : Vec A n) → P $ⁿ xs) + ⇒ zero p [] = p + ⇒ (suc n) p (x ∷ xs) = ⇒ n (p x) xs + + ⇐ : ∀ n {P : N-ary n A (Set ℓ)} → + (∀ (xs : Vec A n) → P $ⁿ xs) → ∀ⁿ n P + ⇐ zero p = p [] + ⇐ (suc n) p = λ x → ⇐ n (p ∘ _∷_ x) + +-- ∃ⁿ can be expressed in an "uncurried" way. + +uncurry-∃ⁿ : ∀ n {P : N-ary n A (Set ℓ)} → + ∃ⁿ n P ⇔ (∃ λ (xs : Vec A n) → P $ⁿ xs) +uncurry-∃ⁿ {a} {A} {ℓ} n = mk⇔ (⇒ n) (⇐ n) + where + ⇒ : ∀ n {P : N-ary n A (Set ℓ)} → + ∃ⁿ n P → (∃ λ (xs : Vec A n) → P $ⁿ xs) + ⇒ zero p = ([] , p) + ⇒ (suc n) (x , p) = Prod.map (_∷_ x) id (⇒ n p) + + ⇐ : ∀ n {P : N-ary n A (Set ℓ)} → + (∃ λ (xs : Vec A n) → P $ⁿ xs) → ∃ⁿ n P + ⇐ zero ([] , p) = p + ⇐ (suc n) (x ∷ xs , p) = (x , ⇐ n (xs , p)) + +-- Conversion preserves equality. + +module _ (_∼_ : REL B C ℓ) where + + curryⁿ-cong : ∀ {n} (f : Vec A n → B) (g : Vec A n → C) → + (∀ xs → f xs ∼ g xs) → + Eq n _∼_ (curryⁿ f) (curryⁿ g) + curryⁿ-cong {n = zero} f g hyp = hyp [] + curryⁿ-cong {n = suc n} f g hyp = λ x → + curryⁿ-cong (f ∘ _∷_ x) (g ∘ _∷_ x) (λ xs → hyp (x ∷ xs)) + + curryⁿ-cong⁻¹ : ∀ {n} (f : Vec A n → B) (g : Vec A n → C) → + Eq n _∼_ (curryⁿ f) (curryⁿ g) → + ∀ xs → f xs ∼ g xs + curryⁿ-cong⁻¹ f g hyp [] = hyp + curryⁿ-cong⁻¹ f g hyp (x ∷ xs) = + curryⁿ-cong⁻¹ (f ∘ _∷_ x) (g ∘ _∷_ x) (hyp x) xs + + appⁿ-cong : ∀ {n} (f : N-ary n A B) (g : N-ary n A C) → + Eq n _∼_ f g → + (xs : Vec A n) → (f $ⁿ xs) ∼ (g $ⁿ xs) + appⁿ-cong f g hyp [] = hyp + appⁿ-cong f g hyp (x ∷ xs) = appⁿ-cong (f x) (g x) (hyp x) xs + + appⁿ-cong⁻¹ : ∀ {n} (f : N-ary n A B) (g : N-ary n A C) → + ((xs : Vec A n) → (f $ⁿ xs) ∼ (g $ⁿ xs)) → + Eq n _∼_ f g + appⁿ-cong⁻¹ {n = zero} f g hyp = hyp [] + appⁿ-cong⁻¹ {n = suc n} f g hyp = λ x → + appⁿ-cong⁻¹ (f x) (g x) (λ xs → hyp (x ∷ xs)) + +-- Eq and Eqʰ are equivalent. + +Eq-to-Eqʰ : ∀ n (_∼_ : REL B C ℓ) {f : N-ary n A B} {g : N-ary n A C} → + Eq n _∼_ f g → Eqʰ n _∼_ f g +Eq-to-Eqʰ zero _∼_ eq = eq +Eq-to-Eqʰ (suc n) _∼_ eq = Eq-to-Eqʰ n _∼_ (eq _) + +Eqʰ-to-Eq : ∀ n (_∼_ : REL B C ℓ) {f : N-ary n A B} {g : N-ary n A C} → + Eqʰ n _∼_ f g → Eq n _∼_ f g +Eqʰ-to-Eq zero _∼_ eq = eq +Eqʰ-to-Eq (suc n) _∼_ eq = λ _ → Eqʰ-to-Eq n _∼_ eq + +module _ (ext : ∀ {a b} → Extensionality a b) where + + Vec↔N-ary : ∀ n → (Vec A n → B) ↔ N-ary n A B + Vec↔N-ary zero = mk↔ₛ′ (λ vxs → vxs []) (flip constᵣ) (λ _ → refl) + (λ vxs → ext λ where [] → refl) + Vec↔N-ary (suc n) = let open Inverse (Vec↔N-ary n) in + mk↔ₛ′ (λ vxs x → to λ xs → vxs (x ∷ xs)) + (λ any xs → from (any (head xs)) (tail xs)) + (λ any → ext λ x → strictlyInverseˡ _) + (λ vxs → ext λ where (x ∷ xs) → cong (λ f → f xs) (strictlyInverseʳ (λ ys → vxs (x ∷ ys)))) \ No newline at end of file diff --git a/Effect.Applicative.html b/Effect.Applicative.html index 30cc6cee..923a7618 100644 --- a/Effect.Applicative.html +++ b/Effect.Applicative.html @@ -13,119 +13,123 @@ module Effect.Applicative where open import Data.Bool.Base using (Bool; true; false) -open import Data.Product using (_×_; _,_) -open import Data.Unit.Polymorphic.Base using (⊤) +open import Data.Product.Base using (_×_; _,_) +open import Data.Unit.Polymorphic.Base using (⊤) -open import Effect.Choice using (RawChoice) -open import Effect.Empty using (RawEmpty) -open import Effect.Functor as Fun using (RawFunctor) +open import Effect.Choice using (RawChoice) +open import Effect.Empty using (RawEmpty) +open import Effect.Functor as Fun using (RawFunctor) -open import Function.Base using (const; flip; _∘′_) -open import Level using (Level; suc; _⊔_) -open import Relation.Binary.PropositionalEquality.Core as P using (_≡_) +open import Function.Base using (const; flip; _∘′_) +open import Level using (Level; suc; _⊔_) +open import Relation.Binary.PropositionalEquality.Core as P using (_≡_) -private - variable - f g : Level - A B C : Set f ------------------------------------------------------------------------- --- The type of raw applicatives +private + variable + f g : Level + A B C : Set f +------------------------------------------------------------------------ +-- The type of raw applicatives -record RawApplicative (F : Set f → Set g) : Set (suc f ⊔ g) where - infixl 4 _<*>_ _<*_ _*>_ - infixl 4 _⊛_ _<⊛_ _⊛>_ - infix 4 _⊗_ - field - rawFunctor : RawFunctor F - pure : A → F A - _<*>_ : F (A → B) → F A → F B +record RawApplicative (F : Set f → Set g) : Set (suc f ⊔ g) where + infixl 4 _<*>_ _<*_ _*>_ + infixl 4 _⊛_ _<⊛_ _⊛>_ + infix 4 _⊗_ + field + rawFunctor : RawFunctor F + pure : A → F A + _<*>_ : F (A → B) → F A → F B - open RawFunctor rawFunctor public + open RawFunctor rawFunctor public - _<*_ : F A → F B → F A - a <* b = const <$> a <*> b + _<*_ : F A → F B → F A + a <* b = const <$> a <*> b - _*>_ : F A → F B → F B - a *> b = flip const <$> a <*> b + _*>_ : F A → F B → F B + a *> b = flip const <$> a <*> b - zipWith : (A → B → C) → F A → F B → F C - zipWith f x y = f <$> x <*> y + zipWith : (A → B → C) → F A → F B → F C + zipWith f x y = f <$> x <*> y - zip : F A → F B → F (A × B) - zip = zipWith _,_ + zip : F A → F B → F (A × B) + zip = zipWith _,_ - -- backwards compatibility: unicode variants - _⊛_ : F (A → B) → F A → F B - _⊛_ = _<*>_ + -- Haskell-style alternative name for pure + return : A → F A + return = pure - _<⊛_ : F A → F B → F A - _<⊛_ = _<*_ + -- backwards compatibility: unicode variants + _⊛_ : F (A → B) → F A → F B + _⊛_ = _<*>_ - _⊛>_ : F A → F B → F B - _⊛>_ = _*>_ + _<⊛_ : F A → F B → F A + _<⊛_ = _<*_ - _⊗_ : F A → F B → F (A × B) - _⊗_ = zip + _⊛>_ : F A → F B → F B + _⊛>_ = _*>_ -module _ where + _⊗_ : F A → F B → F (A × B) + _⊗_ = zip - open RawApplicative - open RawFunctor +module _ where - -- Smart constructor - mkRawApplicative : - (F : Set f → Set f) → - (pure : ∀ {A} → A → F A) → - (app : ∀ {A B} → F (A → B) → F A → F B) → - RawApplicative F - mkRawApplicative F pure app .rawFunctor ._<$>_ = app ∘′ pure - mkRawApplicative F pure app .pure = pure - mkRawApplicative F pure app ._<*>_ = app + open RawApplicative + open RawFunctor ------------------------------------------------------------------------- --- The type of raw applicatives with a zero + -- Smart constructor + mkRawApplicative : + (F : Set f → Set f) → + (pure : ∀ {A} → A → F A) → + (app : ∀ {A B} → F (A → B) → F A → F B) → + RawApplicative F + mkRawApplicative F pure app .rawFunctor ._<$>_ = app ∘′ pure + mkRawApplicative F pure app .pure = pure + mkRawApplicative F pure app ._<*>_ = app -record RawApplicativeZero (F : Set f → Set g) : Set (suc f ⊔ g) where - field - rawApplicative : RawApplicative F - rawEmpty : RawEmpty F +------------------------------------------------------------------------ +-- The type of raw applicatives with a zero - open RawApplicative rawApplicative public - open RawEmpty rawEmpty public +record RawApplicativeZero (F : Set f → Set g) : Set (suc f ⊔ g) where + field + rawApplicative : RawApplicative F + rawEmpty : RawEmpty F - guard : Bool → F ⊤ - guard true = pure _ - guard false = empty + open RawApplicative rawApplicative public + open RawEmpty rawEmpty public ------------------------------------------------------------------------- --- The type of raw alternative applicatives + guard : Bool → F ⊤ + guard true = pure _ + guard false = empty -record RawAlternative (F : Set f → Set g) : Set (suc f ⊔ g) where - field - rawApplicativeZero : RawApplicativeZero F - rawChoice : RawChoice F +------------------------------------------------------------------------ +-- The type of raw alternative applicatives - open RawApplicativeZero rawApplicativeZero public - open RawChoice rawChoice public +record RawAlternative (F : Set f → Set g) : Set (suc f ⊔ g) where + field + rawApplicativeZero : RawApplicativeZero F + rawChoice : RawChoice F ------------------------------------------------------------------------- --- The type of applicative morphisms + open RawApplicativeZero rawApplicativeZero public + open RawChoice rawChoice public -record Morphism {F₁ F₂ : Set f → Set g} - (A₁ : RawApplicative F₁) - (A₂ : RawApplicative F₂) : Set (suc f ⊔ g) where - module A₁ = RawApplicative A₁ - module A₂ = RawApplicative A₂ - field - functorMorphism : Fun.Morphism A₁.rawFunctor A₂.rawFunctor +------------------------------------------------------------------------ +-- The type of applicative morphisms - open Fun.Morphism functorMorphism public - - field - op-pure : (x : A) → op (A₁.pure x) ≡ A₂.pure x - op-<*> : (f : F₁ (A → B)) (x : F₁ A) → - op (f A₁.⊛ x) ≡ (op f A₂.⊛ op x) +record Morphism {F₁ F₂ : Set f → Set g} + (A₁ : RawApplicative F₁) + (A₂ : RawApplicative F₂) : Set (suc f ⊔ g) where + module A₁ = RawApplicative A₁ + module A₂ = RawApplicative A₂ + field + functorMorphism : Fun.Morphism A₁.rawFunctor A₂.rawFunctor - -- backwards compatibility: unicode variants - op-⊛ = op-<*> + open Fun.Morphism functorMorphism public + + field + op-pure : (x : A) → op (A₁.pure x) ≡ A₂.pure x + op-<*> : (f : F₁ (A → B)) (x : F₁ A) → + op (f A₁.⊛ x) ≡ (op f A₂.⊛ op x) + + -- backwards compatibility: unicode variants + op-⊛ = op-<*> \ No newline at end of file diff --git a/Effect.Monad.html b/Effect.Monad.html index 8144490f..5eaf7c1f 100644 --- a/Effect.Monad.html +++ b/Effect.Monad.html @@ -17,111 +17,120 @@ open import Effect.Choice open import Effect.Empty open import Effect.Applicative -open import Function.Base using (flip; _$′_; _∘′_) -open import Level using (Level; suc; _⊔_) +open import Function.Base using (id; flip; _$′_; _∘′_) +open import Level using (Level; suc; _⊔_) -private - variable - f g g₁ g₂ : Level - A B C : Set f +private + variable + f g g₁ g₂ : Level + A B C : Set f ------------------------------------------------------------------------- --- The type of raw monads +------------------------------------------------------------------------ +-- The type of raw monads -record RawMonad (F : Set f → Set g) : Set (suc f ⊔ g) where - infixl 1 _>>=_ _>>_ _>=>_ - infixr 1 _=<<_ _<=<_ - field - rawApplicative : RawApplicative F - _>>=_ : F A → (A → F B) → F B +record RawMonad (F : Set f → Set g) : Set (suc f ⊔ g) where + infixl 1 _>>=_ _>>_ _>=>_ + infixr 1 _=<<_ _<=<_ + field + rawApplicative : RawApplicative F + _>>=_ : F A → (A → F B) → F B - open RawApplicative rawApplicative public + open RawApplicative rawApplicative public - _>>_ : F A → F B → F B - _>>_ = _*>_ + _>>_ : F A → F B → F B + _>>_ = _*>_ - _=<<_ : (A → F B) → F A → F B - _=<<_ = flip _>>=_ + _=<<_ : (A → F B) → F A → F B + _=<<_ = flip _>>=_ - Kleisli : Set f → Set f → Set (f ⊔ g) - Kleisli A B = A → F B + Kleisli : Set f → Set f → Set (f ⊔ g) + Kleisli A B = A → F B - _>=>_ : Kleisli A B → Kleisli B C → Kleisli A C - (f >=> g) a = f a >>= g + _>=>_ : Kleisli A B → Kleisli B C → Kleisli A C + (f >=> g) a = f a >>= g - _<=<_ : Kleisli B C → Kleisli A B → Kleisli A C - _<=<_ = flip _>=>_ + _<=<_ : Kleisli B C → Kleisli A B → Kleisli A C + _<=<_ = flip _>=>_ - when : Bool → F ⊤ → F ⊤ - when true m = m - when false m = pure _ + when : Bool → F ⊤ → F ⊤ + when true m = m + when false m = pure _ - unless : Bool → F ⊤ → F ⊤ - unless = when ∘′ not + unless : Bool → F ⊤ → F ⊤ + unless = when ∘′ not --- Smart constructor -module _ where +-- When level g=f, a join/μ operator is definable - open RawMonad - open RawApplicative +module Join {F : Set f → Set f} (M : RawMonad F) where + open RawMonad M - mkRawMonad : - (F : Set f → Set f) → - (pure : ∀ {A} → A → F A) → - (bind : ∀ {A B} → F A → (A → F B) → F B) → - RawMonad F - mkRawMonad F pure _>>=_ .rawApplicative = - mkRawApplicative _ pure $′ λ mf mx → do - f ← mf - x ← mx - pure (f x) - mkRawMonad F pure _>>=_ ._>>=_ = _>>=_ + join : F (F A) → F A + join = _>>= id ------------------------------------------------------------------------- --- The type of raw monads with a zero +-- Smart constructor -record RawMonadZero (F : Set f → Set g) : Set (suc f ⊔ g) where - field - rawMonad : RawMonad F - rawEmpty : RawEmpty F +module _ where - open RawMonad rawMonad public - open RawEmpty rawEmpty public + open RawMonad + open RawApplicative - rawApplicativeZero : RawApplicativeZero F - rawApplicativeZero = record - { rawApplicative = rawApplicative - ; rawEmpty = rawEmpty - } + mkRawMonad : + (F : Set f → Set f) → + (pure : ∀ {A} → A → F A) → + (bind : ∀ {A B} → F A → (A → F B) → F B) → + RawMonad F + mkRawMonad F pure _>>=_ .rawApplicative = + mkRawApplicative _ pure $′ λ mf mx → do + f ← mf + x ← mx + pure (f x) + mkRawMonad F pure _>>=_ ._>>=_ = _>>=_ ------------------------------------------------------------------------- --- The type of raw monadplus +------------------------------------------------------------------------ +-- The type of raw monads with a zero -record RawMonadPlus (F : Set f → Set g) : Set (suc f ⊔ g) where - field - rawMonadZero : RawMonadZero F - rawChoice : RawChoice F +record RawMonadZero (F : Set f → Set g) : Set (suc f ⊔ g) where + field + rawMonad : RawMonad F + rawEmpty : RawEmpty F - open RawMonadZero rawMonadZero public - open RawChoice rawChoice public + open RawMonad rawMonad public + open RawEmpty rawEmpty public - rawAlternative : RawAlternative F - rawAlternative = record - { rawApplicativeZero = rawApplicativeZero - ; rawChoice = rawChoice - } + rawApplicativeZero : RawApplicativeZero F + rawApplicativeZero = record + { rawApplicative = rawApplicative + ; rawEmpty = rawEmpty + } ------------------------------------------------------------------------- --- The type of raw monad transformer +------------------------------------------------------------------------ +-- The type of raw monadplus --- F has been RawMonadT'd as TF -record RawMonadTd (F : Set f → Set g₁) (TF : Set f → Set g₂) : Set (suc f ⊔ g₁ ⊔ g₂) where - field - lift : F A → TF A - rawMonad : RawMonad TF +record RawMonadPlus (F : Set f → Set g) : Set (suc f ⊔ g) where + field + rawMonadZero : RawMonadZero F + rawChoice : RawChoice F - open RawMonad rawMonad public + open RawMonadZero rawMonadZero public + open RawChoice rawChoice public -RawMonadT : (T : (Set f → Set g₁) → (Set f → Set g₂)) → Set (suc f ⊔ suc g₁ ⊔ g₂) -RawMonadT T = ∀ {M} → RawMonad M → RawMonadTd M (T M) + rawAlternative : RawAlternative F + rawAlternative = record + { rawApplicativeZero = rawApplicativeZero + ; rawChoice = rawChoice + } + +------------------------------------------------------------------------ +-- The type of raw monad transformer + +-- F has been RawMonadT'd as TF +record RawMonadTd (F : Set f → Set g₁) (TF : Set f → Set g₂) : Set (suc f ⊔ g₁ ⊔ g₂) where + field + lift : F A → TF A + rawMonad : RawMonad TF + + open RawMonad rawMonad public + +RawMonadT : (T : (Set f → Set g₁) → (Set f → Set g₂)) → Set (suc f ⊔ suc g₁ ⊔ g₂) +RawMonadT T = ∀ {M} → RawMonad M → RawMonadTd M (T M) \ No newline at end of file diff --git a/Examples.Amortized.Core.html b/Examples.Amortized.Core.html index cb0911de..fe2857ef 100644 --- a/Examples.Amortized.Core.html +++ b/Examples.Amortized.Core.html @@ -6,7 +6,7 @@ open import Algebra.Cost costMonoid = ℕ-CostMonoid -open CostMonoid costMonoid using (ℂ) +open CostMonoid costMonoid using (ℂ) open import Calf costMonoid open import Calf.Data.Product diff --git a/Examples.Amortized.DynamicArray.html b/Examples.Amortized.DynamicArray.html index dafab1d1..daba2452 100644 --- a/Examples.Amortized.DynamicArray.html +++ b/Examples.Amortized.DynamicArray.html @@ -6,19 +6,19 @@ open import Algebra.Cost costMonoid = ℕ-CostMonoid -open CostMonoid costMonoid using (ℂ) +open CostMonoid costMonoid using (ℂ) open import Calf costMonoid open import Calf.Data.Product open import Calf.Data.Bool open import Calf.Data.Maybe -open import Calf.Data.Nat as Nat using (ℕ; zero; suc; nat; _+_; _∸_; pred; _*_; _^_; _>_) +open import Calf.Data.Nat as Nat using (ℕ; zero; suc; nat; _+_; _∸_; pred; _*_; _^_; _>_) import Data.Nat.Properties as Nat open import Calf.Data.List open import Data.Nat.PredExp2 import Data.List.Properties as List -open import Calf.Data.Equality as Eq using (_≡_; refl; _≡⁺_; ≡⁺-syntax; _≡⁻_; ≡⁻-syntax; module ≡-Reasoning) -open import Function hiding (_⇔_) +open import Calf.Data.Equality as Eq using (_≡_; refl; _≡⁺_; ≡⁺-syntax; _≡⁻_; ≡⁻-syntax; module ≡-Reasoning) +open import Function hiding (_⇔_) open import Relation.Nullary @@ -39,8 +39,8 @@ get/step : ∀ {c e} → DynamicArray.get (step (dynamic-array A) c e) ≡ step (Π nat λ _ → maybe A ⋉ dynamic-array A) c (DynamicArray.get e) {-# REWRITE quit/step append/step get/step #-} -Φ : val nat → val nat → ℂ -Φ n m = 2 ^ n ∸ 2 * m +Φ : val nat → val nat → ℂ +Φ n m = 2 ^ n ∸ 2 * m {-# TERMINATING #-} -- array n m @@ -48,140 +48,140 @@ -- remaining free spaces: m (≤ 2 ^ (pred n)) array : cmp (Π nat λ _ → Π nat λ _ → dynamic-array unit) DynamicArray.quit (array n m) = step (F unit) (Φ n m) (ret triv) -DynamicArray.append (array n zero) triv = step (dynamic-array unit) (2 ^ n) (array (suc n) pred[2^ n ]) +DynamicArray.append (array n zero) triv = step (dynamic-array unit) (2 ^ n) (array (suc n) pred[2^ n ]) DynamicArray.append (array n (suc m)) triv = array n m -DynamicArray.get (array n m) i with i Nat.<? 2 ^ n ∸ m -... | no ¬p = nothing , array n m -... | yes p = just triv , array n m +DynamicArray.get (array n m) i with i Nat.<? 2 ^ n ∸ m +... | no ¬p = nothing , array n m +... | yes p = just triv , array n m {-# TERMINATING #-} SPEC/array : cmp (Π nat λ _ → dynamic-array unit) DynamicArray.quit (SPEC/array n) = ret triv DynamicArray.append (SPEC/array n) triv = step (dynamic-array unit) 2 (SPEC/array (suc n)) -DynamicArray.get (SPEC/array n) i with i Nat.<? n -... | no ¬p = nothing , SPEC/array n -... | yes p = just triv , SPEC/array n +DynamicArray.get (SPEC/array n) i with i Nat.<? n +... | no ¬p = nothing , SPEC/array n +... | yes p = just triv , SPEC/array n postulate _≈⁻_ : (d₁ d₂ : cmp (dynamic-array A)) → tp⁻ record _≈_ {A : tp⁺} (d₁ d₂ : cmp (dynamic-array A)) : Set where coinductive field - quit : cmp $ + quit : cmp $ DynamicArray.quit d₁ ≡⁻[ F unit ] DynamicArray.quit d₂ - append : cmp $ + append : cmp $ Π A λ a → DynamicArray.append d₁ a ≈⁻ DynamicArray.append d₂ a - get : cmp $ + get : cmp $ Π nat λ i → - (proj₁ (DynamicArray.get d₁ i) ≡⁺[ maybe A ] proj₁ (DynamicArray.get d₂ i)) ⋉ - (proj₂ (DynamicArray.get d₁ i) ≈⁻ proj₂ (DynamicArray.get d₂ i)) + (proj₁ (DynamicArray.get d₁ i) ≡⁺[ maybe A ] proj₁ (DynamicArray.get d₂ i)) ⋉ + (proj₂ (DynamicArray.get d₁ i) ≈⁻ proj₂ (DynamicArray.get d₂ i)) postulate ≈⁻/decode : {d₁ d₂ : cmp (dynamic-array A)} → val (U (d₁ ≈⁻ d₂)) ≡ d₁ ≈ d₂ {-# REWRITE ≈⁻/decode #-} {-# TERMINATING #-} -≈-cong : (c : ℂ) {x y : DynamicArray A} → x ≈ y → step (dynamic-array A) c x ≈ step (dynamic-array A) c y -_≈_.quit (≈-cong c h) = Eq.cong (step (F unit) c) (_≈_.quit h) +≈-cong : (c : ℂ) {x y : DynamicArray A} → x ≈ y → step (dynamic-array A) c x ≈ step (dynamic-array A) c y +_≈_.quit (≈-cong c h) = Eq.cong (step (F unit) c) (_≈_.quit h) _≈_.append (≈-cong c h) a = ≈-cong c (_≈_.append h a) -_≈_.get (≈-cong c h) i = proj₁ (_≈_.get h i) , ≈-cong c (proj₂ (_≈_.get h i)) +_≈_.get (≈-cong c h) i = proj₁ (_≈_.get h i) , ≈-cong c (proj₂ (_≈_.get h i)) -- from unreleased agda-stdlib -2^n>0 : ∀ (n : ℕ) → 2 ^ n > 0 -2^n>0 zero = Nat.s≤s Nat.z≤n -2^n>0 (suc n) = Nat.≤-trans (2^n>0 n) (Nat.m≤m+n (2 ^ n) ((2 ^ n) + zero)) +2^n>0 : ∀ (n : ℕ) → 2 ^ n > 0 +2^n>0 zero = Nat.s≤s Nat.z≤n +2^n>0 (suc n) = Nat.≤-trans (2^n>0 n) (Nat.m≤m+n (2 ^ n) ((2 ^ n) + zero)) -2^-mono : {m n : ℕ} → m Nat.≤ n → 2 ^ m Nat.≤ 2 ^ n -2^-mono {n = n} Nat.z≤n = 2^n>0 n -2^-mono (Nat.s≤s h) = Nat.*-monoʳ-≤ 2 (2^-mono h) +2^-mono : {m n : ℕ} → m Nat.≤ n → 2 ^ m Nat.≤ 2 ^ n +2^-mono {n = n} Nat.z≤n = 2^n>0 n +2^-mono (Nat.s≤s h) = Nat.*-monoʳ-≤ 2 (2^-mono h) -2^suc[pred[n]] : (n : ℕ) → 2 ^ suc (pred n) ∸ 2 Nat.≤ 2 ^ n -2^suc[pred[n]] zero = Nat.z≤n -2^suc[pred[n]] (suc n) = Nat.m∸n≤m (2 ^ suc n) 2 +2^suc[pred[n]] : (n : ℕ) → 2 ^ suc (pred n) ∸ 2 Nat.≤ 2 ^ n +2^suc[pred[n]] zero = Nat.z≤n +2^suc[pred[n]] (suc n) = Nat.m∸n≤m (2 ^ suc n) 2 {-# TERMINATING #-} -array≈SPEC/array : (n m : val nat) → m Nat.≤ pred[2^ pred n ] → - array n m ≈ step (dynamic-array unit) (2 ^ n ∸ 2 * m) (SPEC/array (2 ^ n ∸ m)) +array≈SPEC/array : (n m : val nat) → m Nat.≤ pred[2^ pred n ] → + array n m ≈ step (dynamic-array unit) (2 ^ n ∸ 2 * m) (SPEC/array (2 ^ n ∸ m)) _≈_.quit (array≈SPEC/array n m h) = refl _≈_.append (array≈SPEC/array n zero h) triv = - Eq.subst₂ + Eq.subst₂ (λ c x → - step (dynamic-array unit) (2 ^ n) (array (suc n) (2 ^ n ∸ 1)) ≈ - step (dynamic-array unit) (2 ^ n + c) (SPEC/array x)) - (let open ≡-Reasoning in - begin - 2 ^ suc n ∸ 2 * pred[2^ n ] - ≡⟨ Eq.cong (2 ^ suc n ∸_) (Nat.*-distribˡ-∸ 2 (2 ^ n) 1) ⟩ - 2 ^ suc n ∸ (2 * 2 ^ n ∸ 2) - ≡⟨⟩ - 2 ^ suc n ∸ (2 ^ suc n ∸ 2) - ≡⟨ Nat.m∸[m∸n]≡n (Nat.*-monoʳ-≤ 2 (2^n>0 n)) ⟩ + step (dynamic-array unit) (2 ^ n) (array (suc n) (2 ^ n ∸ 1)) ≈ + step (dynamic-array unit) (2 ^ n + c) (SPEC/array x)) + (let open ≡-Reasoning in + begin + 2 ^ suc n ∸ 2 * pred[2^ n ] + ≡⟨ Eq.cong (2 ^ suc n ∸_) (Nat.*-distribˡ-∸ 2 (2 ^ n) 1) ⟩ + 2 ^ suc n ∸ (2 * 2 ^ n ∸ 2) + ≡⟨⟩ + 2 ^ suc n ∸ (2 ^ suc n ∸ 2) + ≡⟨ Nat.m∸[m∸n]≡n (Nat.*-monoʳ-≤ 2 (2^n>0 n)) ⟩ 2 - ∎) - (let open ≡-Reasoning in - begin - 2 ^ suc n ∸ pred[2^ n ] - ≡⟨⟩ - 2 * 2 ^ n ∸ (2 ^ n ∸ 1) - ≡⟨⟩ - (2 ^ n + (2 ^ n + 0)) ∸ (2 ^ n ∸ 1) - ≡⟨ Eq.cong (λ x → (2 ^ n) + x ∸ (2 ^ n ∸ 1)) (Nat.+-identityʳ (2 ^ n)) ⟩ - (2 ^ n + 2 ^ n) ∸ (2 ^ n ∸ 1) - ≡⟨ Nat.+-∸-assoc (2 ^ n) {n = 2 ^ n} {o = 2 ^ n ∸ 1} (Nat.m∸n≤m (2 ^ n) 1) ⟩ - 2 ^ n + (2 ^ n ∸ (2 ^ n ∸ 1)) - ≡⟨ Eq.cong (2 ^ n +_) (Nat.m∸[m∸n]≡n (2^n>0 n)) ⟩ - 2 ^ n + 1 - ≡⟨ Nat.+-comm (2 ^ n) 1 ⟩ - suc (2 ^ n) - ∎) - (≈-cong (2 ^ n) + ∎) + (let open ≡-Reasoning in + begin + 2 ^ suc n ∸ pred[2^ n ] + ≡⟨⟩ + 2 * 2 ^ n ∸ (2 ^ n ∸ 1) + ≡⟨⟩ + (2 ^ n + (2 ^ n + 0)) ∸ (2 ^ n ∸ 1) + ≡⟨ Eq.cong (λ x → (2 ^ n) + x ∸ (2 ^ n ∸ 1)) (Nat.+-identityʳ (2 ^ n)) ⟩ + (2 ^ n + 2 ^ n) ∸ (2 ^ n ∸ 1) + ≡⟨ Nat.+-∸-assoc (2 ^ n) {n = 2 ^ n} {o = 2 ^ n ∸ 1} (Nat.m∸n≤m (2 ^ n) 1) ⟩ + 2 ^ n + (2 ^ n ∸ (2 ^ n ∸ 1)) + ≡⟨ Eq.cong (2 ^ n +_) (Nat.m∸[m∸n]≡n (2^n>0 n)) ⟩ + 2 ^ n + 1 + ≡⟨ Nat.+-comm (2 ^ n) 1 ⟩ + suc (2 ^ n) + ∎) + (≈-cong (2 ^ n) {x = array (suc n) pred[2^ n ]} - {y = step (dynamic-array unit) (2 ^ suc n ∸ 2 * pred[2^ n ]) (SPEC/array (2 ^ suc n ∸ pred[2^ n ]))} - (array≈SPEC/array (suc n) pred[2^ n ] Nat.≤-refl)) + {y = step (dynamic-array unit) (2 ^ suc n ∸ 2 * pred[2^ n ]) (SPEC/array (2 ^ suc n ∸ pred[2^ n ]))} + (array≈SPEC/array (suc n) pred[2^ n ] Nat.≤-refl)) _≈_.append (array≈SPEC/array n (suc m) h) triv = - Eq.subst₂ + Eq.subst₂ (λ c x → array n m ≈ step (dynamic-array unit) c (SPEC/array x)) (let - lemma : suc (suc (m + (m + zero))) Nat.≤ (2 ^ n) + lemma : suc (suc (m + (m + zero))) Nat.≤ (2 ^ n) lemma = - let open Nat.≤-Reasoning in - begin + let open Nat.≤-Reasoning in + begin suc (suc (m + (m + zero))) - ≡˘⟨ Eq.cong suc (Nat.+-suc m (m + zero)) ⟩ + ≡˘⟨ Eq.cong suc (Nat.+-suc m (m + zero)) ⟩ suc m + (suc m + zero) - ≤⟨ Nat.+-mono-≤ h (Nat.+-monoˡ-≤ zero h) ⟩ - pred[2^ pred n ] + (pred[2^ pred n ] + zero) - ≡⟨ Nat.*-distribˡ-∸ 2 (2 ^ pred n) 1 ⟩ - 2 ^ suc (pred n) ∸ 2 - ≤⟨ 2^suc[pred[n]] n ⟩ - 2 ^ n - ∎ + ≤⟨ Nat.+-mono-≤ h (Nat.+-monoˡ-≤ zero h) ⟩ + pred[2^ pred n ] + (pred[2^ pred n ] + zero) + ≡⟨ Nat.*-distribˡ-∸ 2 (2 ^ pred n) 1 ⟩ + 2 ^ suc (pred n) ∸ 2 + ≤⟨ 2^suc[pred[n]] n ⟩ + 2 ^ n + ∎ in - let open ≡-Reasoning in - begin - 2 ^ n ∸ 2 * m - ≡˘⟨ Nat.[m+n]∸[m+o]≡n∸o 2 (2 ^ n) (2 * m) ⟩ - (2 + 2 ^ n) ∸ (2 + 2 * m) - ≡⟨ Nat.+-∸-assoc 2 lemma ⟩ - 2 + (2 ^ n ∸ (2 + 2 * m)) - ≡⟨ Nat.+-comm 2 (2 ^ n ∸ (2 + 2 * m)) ⟩ - 2 ^ n ∸ (2 + 2 * m) + 2 - ≡˘⟨ Eq.cong (λ x → 2 ^ n ∸ x + 2) (Nat.*-distribˡ-+ 2 1 m) ⟩ - 2 ^ n ∸ 2 * suc m + 2 - ∎) - (let open ≡-Reasoning in - begin - 2 ^ n ∸ m - ≡˘⟨ Nat.[m+n]∸[m+o]≡n∸o 1 (2 ^ n) m ⟩ - suc (2 ^ n) ∸ suc m - ≡⟨ - Nat.+-∸-assoc + let open ≡-Reasoning in + begin + 2 ^ n ∸ 2 * m + ≡˘⟨ Nat.[m+n]∸[m+o]≡n∸o 2 (2 ^ n) (2 * m) ⟩ + (2 + 2 ^ n) ∸ (2 + 2 * m) + ≡⟨ Nat.+-∸-assoc 2 lemma ⟩ + 2 + (2 ^ n ∸ (2 + 2 * m)) + ≡⟨ Nat.+-comm 2 (2 ^ n ∸ (2 + 2 * m)) ⟩ + 2 ^ n ∸ (2 + 2 * m) + 2 + ≡˘⟨ Eq.cong (λ x → 2 ^ n ∸ x + 2) (Nat.*-distribˡ-+ 2 1 m) ⟩ + 2 ^ n ∸ 2 * suc m + 2 + ∎) + (let open ≡-Reasoning in + begin + 2 ^ n ∸ m + ≡˘⟨ Nat.[m+n]∸[m+o]≡n∸o 1 (2 ^ n) m ⟩ + suc (2 ^ n) ∸ suc m + ≡⟨ + Nat.+-∸-assoc 1 - (Nat.≤-trans h (Nat.∸-mono (2^-mono {n = n} Nat.pred[n]≤n) (Nat.z≤n {1}))) - ⟩ - suc (2 ^ n ∸ suc m) - ∎) - (array≈SPEC/array n m (Nat.<⇒≤ h)) -_≈_.get (array≈SPEC/array n m h) i with i Nat.<? 2 ^ n ∸ m -... | no ¬p = refl , array≈SPEC/array n m h -... | yes p = refl , array≈SPEC/array n m h + (Nat.≤-trans h (Nat.∸-mono (2^-mono {n = n} Nat.pred[n]≤n) (Nat.z≤n {1}))) + ⟩ + suc (2 ^ n ∸ suc m) + ∎) + (array≈SPEC/array n m (Nat.<⇒≤ h)) +_≈_.get (array≈SPEC/array n m h) i with i Nat.<? 2 ^ n ∸ m +... | no ¬p = refl , array≈SPEC/array n m h +... | yes p = refl , array≈SPEC/array n m h \ No newline at end of file diff --git a/Examples.Amortized.Queue.html b/Examples.Amortized.Queue.html index d2748fb6..84eeedb7 100644 --- a/Examples.Amortized.Queue.html +++ b/Examples.Amortized.Queue.html @@ -6,17 +6,17 @@ open import Algebra.Cost costMonoid = ℕ-CostMonoid -open CostMonoid costMonoid using (ℂ) +open CostMonoid costMonoid using (ℂ) open import Calf costMonoid open import Calf.Data.Product open import Calf.Data.Maybe -open import Calf.Data.Nat as Nat using (ℕ; zero; suc; nat; _+_; _∸_; pred; _*_; _^_; _>_) +open import Calf.Data.Nat as Nat using (ℕ; zero; suc; nat; _+_; _∸_; pred; _*_; _^_; _>_) import Data.Nat.Properties as Nat open import Calf.Data.List import Data.List.Properties as List -open import Calf.Data.Equality as Eq using (_≡_; refl; _≡⁺_; ≡⁺-syntax; _≡⁻_; ≡⁻-syntax; module ≡-Reasoning) -open import Function hiding (_⇔_) +open import Calf.Data.Equality as Eq using (_≡_; refl; _≡⁺_; ≡⁺-syntax; _≡⁻_; ≡⁻-syntax; module ≡-Reasoning) +open import Function hiding (_⇔_) open import Examples.Amortized.Core @@ -45,34 +45,34 @@ {-# TERMINATING #-} list-queue : cmp (Π (list E) λ _ → queue (F unit)) Queue.quit (list-queue l) = ret triv -Queue.enqueue (list-queue l) e = step (queue (F unit)) (length l) (list-queue (l ++ [ e ])) +Queue.enqueue (list-queue l) e = step (queue (F unit)) (length l) (list-queue (l ++ [ e ])) Queue.dequeue (list-queue [] ) = nothing , list-queue [] Queue.dequeue (list-queue (e ∷ l)) = just e , list-queue l {-# TERMINATING #-} SPEC/list-queue : cmp (Π (list E) λ _ → queue (F unit)) Queue.quit (SPEC/list-queue l) = ret triv -Queue.enqueue (SPEC/list-queue l) e = step (queue (F unit)) 1 (SPEC/list-queue (l ++ [ e ])) +Queue.enqueue (SPEC/list-queue l) e = step (queue (F unit)) 1 (SPEC/list-queue (l ++ [ e ])) Queue.dequeue (SPEC/list-queue [] ) = nothing , SPEC/list-queue [] Queue.dequeue (SPEC/list-queue (e ∷ l)) = just e , SPEC/list-queue l -Φ : val (list E) → val (list E) → ℂ -Φ bl fl = length bl +Φ : val (list E) → val (list E) → ℂ +Φ bl fl = length bl {-# TERMINATING #-} batched-queue : cmp (Π (list E) λ _ → Π (list E) λ _ → queue (F unit)) Queue.quit (batched-queue bl fl) = step (F unit) (Φ bl fl) (ret triv) Queue.enqueue (batched-queue bl fl) e = batched-queue (e ∷ bl) fl -Queue.dequeue (batched-queue bl []) with reverse bl +Queue.dequeue (batched-queue bl []) with reverse bl ... | [] = nothing , batched-queue [] [] -... | e ∷ fl = step (maybe E ⋉ queue (F unit)) (length bl) (just e , batched-queue [] fl) +... | e ∷ fl = step (maybe E ⋉ queue (F unit)) (length bl) (just e , batched-queue [] fl) Queue.dequeue (batched-queue bl (e ∷ fl)) = just e , batched-queue bl fl {-# TERMINATING #-} SPEC/batched-queue : cmp (Π (list E) λ _ → Π (list E) λ _ → queue (F unit)) Queue.quit (SPEC/batched-queue bl fl) = ret triv Queue.enqueue (SPEC/batched-queue bl fl) e = step (queue (F unit)) 1 (SPEC/batched-queue (e ∷ bl) fl) -Queue.dequeue (SPEC/batched-queue bl []) with reverse bl +Queue.dequeue (SPEC/batched-queue bl []) with reverse bl ... | [] = nothing , SPEC/batched-queue [] [] ... | e ∷ fl = just e , SPEC/batched-queue [] fl Queue.dequeue (SPEC/batched-queue bl (e ∷ fl)) = just e , SPEC/batched-queue bl fl @@ -82,34 +82,34 @@ record _≈_ (q₁ q₂ : cmp (queue X)) : Set where coinductive field - quit : cmp $ + quit : cmp $ Queue.quit q₁ ≡⁻[ X ] Queue.quit q₂ - enqueue : cmp $ + enqueue : cmp $ Π E λ e → Queue.enqueue q₁ e ≈⁻ Queue.enqueue q₂ e - dequeue : cmp $ - (proj₁ (Queue.dequeue q₁) ≡⁺[ maybe E ] proj₁ (Queue.dequeue q₂)) ⋉ - (proj₂ (Queue.dequeue q₁) ≈⁻ proj₂ (Queue.dequeue q₂)) + dequeue : cmp $ + (proj₁ (Queue.dequeue q₁) ≡⁺[ maybe E ] proj₁ (Queue.dequeue q₂)) ⋉ + (proj₂ (Queue.dequeue q₁) ≈⁻ proj₂ (Queue.dequeue q₂)) postulate ≈⁻/decode : {q₁ q₂ : cmp (queue X)} → val (U (q₁ ≈⁻ q₂)) ≡ q₁ ≈ q₂ {-# REWRITE ≈⁻/decode #-} {-# TERMINATING #-} -≈-cong : (c : ℂ) {x y : Queue X} → x ≈ y → step (queue X) c x ≈ step (queue X) c y -_≈_.quit (≈-cong {X = X} c h) = Eq.cong (step X c) (_≈_.quit h) +≈-cong : (c : ℂ) {x y : Queue X} → x ≈ y → step (queue X) c x ≈ step (queue X) c y +_≈_.quit (≈-cong {X = X} c h) = Eq.cong (step X c) (_≈_.quit h) _≈_.enqueue (≈-cong c h) e = ≈-cong c (_≈_.enqueue h e) -_≈_.dequeue (≈-cong c h) = proj₁ (_≈_.dequeue h) , ≈-cong c (proj₂ (_≈_.dequeue h)) +_≈_.dequeue (≈-cong c h) = proj₁ (_≈_.dequeue h) , ≈-cong c (proj₂ (_≈_.dequeue h)) {-# TERMINATING #-} batched-queue≈SPEC/batched-queue : (bl fl : val (list E)) → batched-queue bl fl ≈ step (queue (F unit)) (Φ bl fl) (SPEC/batched-queue bl fl) _≈_.quit (batched-queue≈SPEC/batched-queue bl fl) = refl _≈_.enqueue (batched-queue≈SPEC/batched-queue bl fl) e = - Eq.subst + Eq.subst (λ c → batched-queue (e ∷ bl) fl ≈ step (queue (F unit)) c (SPEC/batched-queue (e ∷ bl) fl)) - (Nat.+-comm 1 (length bl)) + (Nat.+-comm 1 (length bl)) (batched-queue≈SPEC/batched-queue (e ∷ bl) fl) -_≈_.dequeue (batched-queue≈SPEC/batched-queue bl []) with reverse bl | List.reverse-injective {xs = bl} {ys = []} +_≈_.dequeue (batched-queue≈SPEC/batched-queue bl []) with reverse bl | List.reverse-injective {xs = bl} {ys = []} _≈_.dequeue (batched-queue≈SPEC/batched-queue bl []) | [] | h with h refl ... | refl = refl , batched-queue≈SPEC/batched-queue [] [] _≈_.dequeue (batched-queue≈SPEC/batched-queue bl []) | e ∷ fl | _ = @@ -119,30 +119,30 @@ {-# TERMINATING #-} batched-queue≈SPEC/list-queue : (bl fl : val (list E)) → - batched-queue bl fl ≈ step (queue (F unit)) (Φ bl fl) (SPEC/list-queue (fl ++ reverse bl)) + batched-queue bl fl ≈ step (queue (F unit)) (Φ bl fl) (SPEC/list-queue (fl ++ reverse bl)) _≈_.quit (batched-queue≈SPEC/list-queue bl fl) = refl _≈_.enqueue (batched-queue≈SPEC/list-queue bl fl) e = - Eq.subst₂ + Eq.subst₂ (λ c l → batched-queue (e ∷ bl) fl ≈ step (queue (F unit)) c (SPEC/list-queue l)) - (Nat.+-comm 1 (length bl)) - (let open ≡-Reasoning in - begin - fl ++ reverse (e ∷ bl) - ≡⟨ Eq.cong (fl ++_) (List.unfold-reverse e bl) ⟩ - fl ++ reverse bl ∷ʳ e - ≡˘⟨ List.++-assoc fl (reverse bl) [ e ] ⟩ - (fl ++ reverse bl) ∷ʳ e - ∎) + (Nat.+-comm 1 (length bl)) + (let open ≡-Reasoning in + begin + fl ++ reverse (e ∷ bl) + ≡⟨ Eq.cong (fl ++_) (List.unfold-reverse e bl) ⟩ + fl ++ reverse bl ∷ʳ e + ≡˘⟨ List.++-assoc fl (reverse bl) [ e ] ⟩ + (fl ++ reverse bl) ∷ʳ e + ∎) (batched-queue≈SPEC/list-queue (e ∷ bl) fl) -_≈_.dequeue (batched-queue≈SPEC/list-queue bl []) with reverse bl | List.reverse-injective {xs = bl} {ys = []} +_≈_.dequeue (batched-queue≈SPEC/list-queue bl []) with reverse bl | List.reverse-injective {xs = bl} {ys = []} _≈_.dequeue (batched-queue≈SPEC/list-queue bl []) | [] | h with h refl ... | refl = refl , batched-queue≈SPEC/list-queue [] [] _≈_.dequeue (batched-queue≈SPEC/list-queue bl []) | e ∷ fl | _ = refl , - ≈-cong (length bl) - ( Eq.subst + ≈-cong (length bl) + ( Eq.subst (λ l → batched-queue [] fl ≈ SPEC/list-queue l) - (List.++-identityʳ fl) + (List.++-identityʳ fl) (batched-queue≈SPEC/list-queue [] fl) ) _≈_.dequeue (batched-queue≈SPEC/list-queue bl (e ∷ fl)) = @@ -161,34 +161,34 @@ {-# TERMINATING #-} -◯[list-queue≈batched-queue] : (bl fl : val (list E)) → ◯ (list-queue (fl ++ reverse bl) ≈ batched-queue bl fl) +◯[list-queue≈batched-queue] : (bl fl : val (list E)) → ◯ (list-queue (fl ++ reverse bl) ≈ batched-queue bl fl) _≈_.quit (◯[list-queue≈batched-queue] bl fl u) = - Eq.sym (step/ext (F unit) (ret triv) (length bl) u) + Eq.sym (step/ext (F unit) (ret triv) (length bl) u) _≈_.enqueue (◯[list-queue≈batched-queue] bl fl u) e = - Eq.subst + Eq.subst (_≈ Queue.enqueue (batched-queue bl fl) e) - (Eq.sym (step/ext (queue (F unit)) (list-queue _) (length (fl ++ reverse bl)) u)) - (Eq.subst + (Eq.sym (step/ext (queue (F unit)) (list-queue _) (length (fl ++ reverse bl)) u)) + (Eq.subst (λ l → list-queue l ≈ batched-queue (e ∷ bl) fl) - {x = fl ++ reverse (e ∷ bl)} - (let open ≡-Reasoning in - begin - fl ++ reverse (e ∷ bl) - ≡⟨ Eq.cong (fl ++_) (List.unfold-reverse e bl) ⟩ - fl ++ reverse bl ∷ʳ e - ≡˘⟨ List.++-assoc fl (reverse bl) [ e ] ⟩ - (fl ++ reverse bl) ∷ʳ e - ∎) + {x = fl ++ reverse (e ∷ bl)} + (let open ≡-Reasoning in + begin + fl ++ reverse (e ∷ bl) + ≡⟨ Eq.cong (fl ++_) (List.unfold-reverse e bl) ⟩ + fl ++ reverse bl ∷ʳ e + ≡˘⟨ List.++-assoc fl (reverse bl) [ e ] ⟩ + (fl ++ reverse bl) ∷ʳ e + ∎) (◯[list-queue≈batched-queue] (e ∷ bl) fl u)) -_≈_.dequeue (◯[list-queue≈batched-queue] bl [] u) with reverse bl | List.reverse-injective {xs = bl} {ys = []} +_≈_.dequeue (◯[list-queue≈batched-queue] bl [] u) with reverse bl | List.reverse-injective {xs = bl} {ys = []} _≈_.dequeue (◯[list-queue≈batched-queue] bl [] u) | [] | h with h refl ... | refl = refl , ◯[list-queue≈batched-queue] [] [] u _≈_.dequeue (◯[list-queue≈batched-queue] bl [] u) | e ∷ fl | _ = refl , - Eq.subst₂ + Eq.subst₂ _≈_ - (Eq.cong list-queue (List.++-identityʳ fl)) - (Eq.sym (step/ext (queue (F unit)) (batched-queue [] fl) (Φ bl fl) u)) + (Eq.cong list-queue (List.++-identityʳ fl)) + (Eq.sym (step/ext (queue (F unit)) (batched-queue [] fl) (Φ bl fl) u)) (◯[list-queue≈batched-queue] [] fl u) _≈_.dequeue (◯[list-queue≈batched-queue] bl (e ∷ fl) u) = refl , ◯[list-queue≈batched-queue] bl fl u @@ -207,8 +207,8 @@ ψ {A} {X} (return a ) q = a , Queue.quit q ψ {A} {X} (enqueue e p) q = ψ p (Queue.enqueue q e) ψ {A} {X} (dequeue k ) q = - bind (A ⋉ X) (k (proj₁ (Queue.dequeue q))) λ p → - ψ p (proj₂ (Queue.dequeue q)) + bind (A ⋉ X) (k (proj₁ (Queue.dequeue q))) λ p → + ψ p (proj₂ (Queue.dequeue q)) postulate _≈'_ : (q₁ q₂ : cmp (queue X)) → tp⁻ @@ -221,18 +221,18 @@ classic-amortization {X} = forward , backward where forward : {q₁ q₂ : cmp (queue X)} → q₁ ≈ q₂ → cmp (q₁ ≈' q₂) - forward h A (return a ) = Eq.cong (a ,_) (_≈_.quit h) + forward h A (return a ) = Eq.cong (a ,_) (_≈_.quit h) forward h A (enqueue e p) = forward (_≈_.enqueue h e) A p forward h A (dequeue k ) = - Eq.cong₂ + Eq.cong₂ (λ e₁ e₂ → bind (A ⋉ X) (k e₁) e₂) - (proj₁ (_≈_.dequeue h)) - (funext (forward (proj₂ (_≈_.dequeue h)) A)) + (proj₁ (_≈_.dequeue h)) + (funext (forward (proj₂ (_≈_.dequeue h)) A)) backward : {q₁ q₂ : cmp (queue X)} → cmp (q₁ ≈' q₂) → q₁ ≈ q₂ - _≈_.quit (backward classic) = Eq.cong proj₂ (classic unit (return triv)) + _≈_.quit (backward classic) = Eq.cong proj₂ (classic unit (return triv)) _≈_.enqueue (backward classic) e = backward λ A p → classic A (enqueue e p) _≈_.dequeue (backward classic) = - Eq.cong proj₁ (classic (maybe E) (dequeue λ e → ret (return e))) , + Eq.cong proj₁ (classic (maybe E) (dequeue λ e → ret (return e))) , backward λ A p → classic A (dequeue λ _ → ret p) \ No newline at end of file diff --git a/Examples.Amortized.Simple.html b/Examples.Amortized.Simple.html index a34378e1..2d608a77 100644 --- a/Examples.Amortized.Simple.html +++ b/Examples.Amortized.Simple.html @@ -6,15 +6,15 @@ open import Algebra.Cost costMonoid = ℕ-CostMonoid -open CostMonoid costMonoid using (ℂ) +open CostMonoid costMonoid using (ℂ) open import Level using (0ℓ) open import Calf costMonoid open import Calf.Data.Product open import Calf.Data.Bool -open import Calf.Data.Nat as Nat using (ℕ; zero; suc; nat; _+_; _∸_; pred; _*_; _^_; _>_) -open import Calf.Data.Equality as Eq using (_≡_; refl; _≡⁺_; ≡⁺-syntax; _≡⁻_; ≡⁻-syntax; module ≡-Reasoning) +open import Calf.Data.Nat as Nat using (ℕ; zero; suc; nat; _+_; _∸_; pred; _*_; _^_; _>_) +open import Calf.Data.Equality as Eq using (_≡_; refl; _≡⁺_; ≡⁺-syntax; _≡⁻_; ≡⁻-syntax; module ≡-Reasoning) open import Examples.Amortized.Core @@ -39,7 +39,7 @@ Simple.quit every = ret triv Simple.next every = step simple 1 every -Φ : val bool → ℂ +Φ : val bool → ℂ Φ false = 1 Φ true = 0 @@ -59,8 +59,8 @@ ≈⁻/decode : {s₁ s₂ : cmp simple} → val (U (s₁ ≈⁻ s₂)) ≡ s₁ ≈ s₂ {-# REWRITE ≈⁻/decode #-} -≈-cong : (c : ℂ) {x y : Simple} → x ≈ y → step simple c x ≈ step simple c y -_≈_.quit (≈-cong c h) = Eq.cong (step (F unit) c) (_≈_.quit h) +≈-cong : (c : ℂ) {x y : Simple} → x ≈ y → step simple c x ≈ step simple c y +_≈_.quit (≈-cong c h) = Eq.cong (step (F unit) c) (_≈_.quit h) _≈_.next (≈-cong c h) = ≈-cong c (_≈_.next h) {-# TERMINATING #-} diff --git a/Examples.Decalf.Basic.html b/Examples.Decalf.Basic.html index 55f5a249..c99cb5e3 100644 --- a/Examples.Decalf.Basic.html +++ b/Examples.Decalf.Basic.html @@ -6,53 +6,53 @@ open import Algebra.Cost costMonoid = ℕ-CostMonoid -open CostMonoid costMonoid using (ℂ) +open CostMonoid costMonoid using (ℂ) open import Calf costMonoid open import Calf.Data.Nat import Data.Nat.Properties as Nat -open import Calf.Data.Equality as Eq using (_≡_; refl; module ≡-Reasoning) +open import Calf.Data.Equality as Eq using (_≡_; refl; module ≡-Reasoning) open import Function -double : cmp $ Π nat λ _ → F nat +double : cmp $ Π nat λ _ → F nat double zero = ret zero double (suc n) = - step (F nat) 1 $ + step (F nat) 1 $ bind (F nat) (double n) λ n' → ret (suc (suc n')) -double/bound : cmp $ Π nat λ _ → F nat +double/bound : cmp $ Π nat λ _ → F nat double/bound n = step (F nat) n (ret (2 * n)) double/has-cost : (n : val nat) → double n ≡ double/bound n double/has-cost zero = refl double/has-cost (suc n) = - let open ≡-Reasoning in - begin - (step (F nat) 1 $ + let open ≡-Reasoning in + begin + (step (F nat) 1 $ bind (F nat) (double n) λ n' → ret (suc (suc n'))) - ≡⟨ - Eq.cong + ≡⟨ + Eq.cong (step (F nat) 1) - (begin + (begin (bind (F nat) (double n) λ n' → ret (suc (suc n'))) - ≡⟨ Eq.cong (λ e → bind (F nat) e λ n' → ret (suc (suc n'))) (double/has-cost n) ⟩ + ≡⟨ Eq.cong (λ e → bind (F nat) e λ n' → ret (suc (suc n'))) (double/has-cost n) ⟩ (bind (F nat) (step (F nat) n (ret (2 * n))) λ n' → ret (suc (suc n'))) - ≡⟨⟩ + ≡⟨⟩ step (F nat) n (ret (suc (suc (2 * n)))) - ≡˘⟨ Eq.cong (step (F nat) n ∘ ret ∘ suc) (Nat.+-suc n (n + 0)) ⟩ + ≡˘⟨ Eq.cong (step (F nat) n ∘ ret ∘ suc) (Nat.+-suc n (n + 0)) ⟩ step (F nat) n (ret (2 * suc n)) - ∎) - ⟩ + ∎) + ⟩ step (F nat) 1 (step (F nat) n (ret (2 * suc n))) - ≡⟨⟩ + ≡⟨⟩ step (F nat) (suc n) (ret (2 * suc n)) - ∎ + ∎ double/correct : ◯ ((n : val nat) → double n ≡ ret (2 * n)) -double/correct u n = Eq.trans (double/has-cost n) (step/ext (F nat) (ret (2 * n)) n u) +double/correct u n = Eq.trans (double/has-cost n) (step/ext (F nat) (ret (2 * n)) n u) \ No newline at end of file diff --git a/Examples.Decalf.GlobalState.html b/Examples.Decalf.GlobalState.html index 53f3ff71..f72e5c3f 100644 --- a/Examples.Decalf.GlobalState.html +++ b/Examples.Decalf.GlobalState.html @@ -6,11 +6,11 @@ open import Algebra.Cost costMonoid = ℕ-CostMonoid -open CostMonoid costMonoid using (ℂ) +open CostMonoid costMonoid using (ℂ) open import Calf costMonoid open import Calf.Data.Nat as Nat using (nat; _*_) -open import Calf.Data.Equality as Eq using (_≡_; module ≡-Reasoning) +open import Calf.Data.Equality as Eq using (_≡_; module ≡-Reasoning) open import Function @@ -33,9 +33,9 @@ set/set : {e : cmp X} → set X s₁ (set X s₂ e) ≡ set X s₂ e - get/step : (c : ℂ) {e : val S → cmp X} → + get/step : (c : ℂ) {e : val S → cmp X} → step X c (get X e) ≡ get X λ s → step X c (e s) - set/step : (c : ℂ) {e : cmp X} → + set/step : (c : ℂ) {e : cmp X} → step X c (set X s e) ≡ set X s (step X c e) @@ -46,39 +46,39 @@ e = get (F nat) λ n → bind (F nat) (double n) λ n' → - set (F nat) n' $ + set (F nat) n' $ ret n e/bound : cmp (F nat) e/bound = get (F nat) λ n → - set (F nat) (2 * n) $ - step (F nat) n $ + set (F nat) (2 * n) $ + step (F nat) n $ ret n e/has-cost : e ≡ e/bound e/has-cost = - Eq.cong (get (F nat)) $ funext λ n → - let open ≡-Reasoning in - begin + Eq.cong (get (F nat)) $ funext λ n → + let open ≡-Reasoning in + begin ( bind (F nat) (double n) λ n' → - set (F nat) n' $ + set (F nat) n' $ ret n ) - ≡⟨ Eq.cong (λ e₁ → bind (F nat) e₁ λ n' → set (F nat) n' (ret n)) (double/has-cost n) ⟩ + ≡⟨ Eq.cong (λ e₁ → bind (F nat) e₁ λ n' → set (F nat) n' (ret n)) (double/has-cost n) ⟩ ( bind (F nat) (step (F nat) n (ret (2 * n))) λ n' → - set (F nat) n' $ + set (F nat) n' $ ret n ) - ≡⟨⟩ - ( step (F nat) n $ - set (F nat) (2 * n) $ + ≡⟨⟩ + ( step (F nat) n $ + set (F nat) (2 * n) $ ret n ) - ≡⟨ set/step n ⟩ - ( set (F nat) (2 * n) $ - step (F nat) n $ + ≡⟨ set/step n ⟩ + ( set (F nat) (2 * n) $ + step (F nat) n $ ret n ) - ∎ + ∎ \ No newline at end of file diff --git a/Examples.Decalf.HigherOrderFunction.html b/Examples.Decalf.HigherOrderFunction.html index 9cf448c9..f4fd8619 100644 --- a/Examples.Decalf.HigherOrderFunction.html +++ b/Examples.Decalf.HigherOrderFunction.html @@ -6,23 +6,23 @@ open import Algebra.Cost costMonoid = ℕ-CostMonoid -open CostMonoid costMonoid using (ℂ) +open CostMonoid costMonoid using (ℂ) open import Calf costMonoid open import Calf.Data.Nat as Nat using (nat; zero; suc; _+_; _*_) import Data.Nat.Properties as Nat open import Data.Nat.Square -open import Calf.Data.List using (list; []; _∷_; [_]; _++_; length) -open import Calf.Data.Bool using (bool; if_then_else_) +open import Calf.Data.List using (list; []; _∷_; [_]; _++_; length) +open import Calf.Data.Bool using (bool; if_then_else_) open import Calf.Data.Product using (unit) -open import Calf.Data.Equality as Eq using (_≡_; refl; module ≡-Reasoning) +open import Calf.Data.Equality as Eq using (_≡_; refl; module ≡-Reasoning) open import Calf.Data.IsBoundedG costMonoid open import Calf.Data.IsBounded costMonoid open import Function module Twice where - twice : cmp $ Π (U (F nat)) λ _ → F nat + twice : cmp $ Π (U (F nat)) λ _ → F nat twice e = bind (F nat) e λ x₁ → bind (F nat) e λ x₂ → @@ -30,30 +30,30 @@ twice/is-bounded : (e : cmp (F nat)) → IsBounded nat e 1 → IsBounded nat (twice e) 2 twice/is-bounded e e≤step⋆1 = - let open ≤⁻-Reasoning cost in - begin + let open ≤⁻-Reasoning cost in + begin bind cost ( bind (F nat) e λ x₁ → bind (F nat) e λ x₂ → ret (x₁ + x₂) ) (λ _ → ret triv) - ≡⟨⟩ + ≡⟨⟩ ( bind cost e λ _ → bind cost e λ _ → ret triv ) - ≤⟨ ≤⁻-mono₂ (λ e₁ e₂ → bind (F _) e₁ λ _ → bind (F _) e₂ λ _ → ret triv) e≤step⋆1 e≤step⋆1 ⟩ + ≲⟨ ≤⁻-mono₂ (λ e₁ e₂ → bind (F _) e₁ λ _ → bind (F _) e₂ λ _ → ret triv) e≤step⋆1 e≤step⋆1 ⟩ ( bind cost (step⋆ 1) λ _ → bind cost (step⋆ 1) λ _ → ret triv ) - ≡⟨⟩ + ≡⟨⟩ step⋆ 2 - ∎ + ∎ module Map where - map : cmp $ Π (U (Π nat λ _ → F nat)) λ _ → Π (list nat) λ _ → F (list nat) + map : cmp $ Π (U (Π nat λ _ → F nat)) λ _ → Π (list nat) λ _ → F (list nat) map f [] = ret [] map f (x ∷ xs) = bind (F (list nat)) (f x) λ y → @@ -64,34 +64,34 @@ (f : cmp (Π nat λ _ → F nat)) → ((x : val nat) → IsBounded nat (f x) c) → (l : val (list nat)) → - IsBounded (list nat) (map f l) (length l * c) + IsBounded (list nat) (map f l) (length l * c) map/is-bounded f f-bound [] = ≤⁻-refl map/is-bounded {c} f f-bound (x ∷ xs) = - let open ≤⁻-Reasoning cost in - begin + let open ≤⁻-Reasoning cost in + begin bind cost ( bind (F (list nat)) (f x) λ y → bind (F (list nat)) (map f xs) λ ys → ret (y ∷ ys) ) (λ _ → ret triv) - ≡⟨⟩ + ≡⟨⟩ ( bind cost (f x) λ _ → bind cost (map f xs) λ _ → ret triv ) - ≤⟨ + ≲⟨ ≤⁻-mono₂ (λ e₁ e₂ → bind cost e₁ λ _ → bind cost e₂ λ _ → ret triv) (f-bound x) (map/is-bounded f f-bound xs) - ⟩ + ⟩ ( bind cost (step⋆ c) λ _ → - bind cost (step⋆ (length xs * c)) λ _ → + bind cost (step⋆ (length xs * c)) λ _ → ret triv ) - ≡⟨⟩ - step⋆ (length (x ∷ xs) * c) - ∎ + ≡⟨⟩ + step⋆ (length (x ∷ xs) * c) + ∎ open import Examples.Decalf.ProbabilisticChoice map/is-bounded' : @@ -99,33 +99,33 @@ {n : val nat} → ((x : val nat) → IsBoundedG nat (f x) (binomial n)) → (l : val (list nat)) → - IsBoundedG (list nat) (map f l) (binomial (length l * n)) + IsBoundedG (list nat) (map f l) (binomial (length l * n)) map/is-bounded' f {n} f-bound [] = ≤⁻-refl map/is-bounded' f {n} f-bound (x ∷ xs) = - let open ≤⁻-Reasoning cost in - begin + let open ≤⁻-Reasoning cost in + begin bind cost ( bind (F (list nat)) (f x) λ y → bind (F (list nat)) (map f xs) λ ys → ret (y ∷ ys) ) (λ _ → ret triv) - ≡⟨⟩ + ≡⟨⟩ ( bind cost (f x) λ _ → bind cost (map f xs) λ _ → ret triv ) - ≤⟨ ≤⁻-mono (λ e → bind cost (f x) λ _ → e) (map/is-bounded' f f-bound xs) ⟩ + ≲⟨ ≤⁻-mono (λ e → bind cost (f x) λ _ → e) (map/is-bounded' f f-bound xs) ⟩ ( bind cost (f x) λ _ → - binomial (length xs * n) + binomial (length xs * n) ) - ≤⟨ ≤⁻-mono (λ e → bind cost e λ _ → binomial (length xs * n)) (f-bound x) ⟩ + ≲⟨ ≤⁻-mono (λ e → bind cost e λ _ → binomial (length xs * n)) (f-bound x) ⟩ ( bind cost (binomial n) λ _ → - binomial (length xs * n) + binomial (length xs * n) ) - ≡⟨ binomial/+ n (length xs * n) ⟩ - binomial (n + length xs * n) - ≡⟨⟩ - binomial (length (x ∷ xs) * n) - ∎ + ≡⟨ binomial/+ n (length xs * n) ⟩ + binomial (n + length xs * n) + ≡⟨⟩ + binomial (length (x ∷ xs) * n) + ∎ \ No newline at end of file diff --git a/Examples.Decalf.Nondeterminism.html b/Examples.Decalf.Nondeterminism.html index 7dcd85b6..c92304f9 100644 --- a/Examples.Decalf.Nondeterminism.html +++ b/Examples.Decalf.Nondeterminism.html @@ -6,17 +6,17 @@ open import Algebra.Cost costMonoid = ℕ-CostMonoid -open CostMonoid costMonoid using (ℂ; _+_) +open CostMonoid costMonoid using (ℂ; _+_) open import Calf costMonoid hiding (A) open import Calf.Data.Nat as Nat using (nat; zero; suc; _*_) import Data.Nat.Properties as Nat open import Data.Nat.Square -open import Calf.Data.List as List using (list; []; _∷_; [_]; _++_; length) +open import Calf.Data.List as List using (list; []; _∷_; [_]; _++_; length) import Data.Fin as Fin -open import Calf.Data.Bool using (bool; false; true; if_then_else_) +open import Calf.Data.Bool using (bool; false; true; if_then_else_) open import Calf.Data.Product using (unit; _×⁺_) -open import Calf.Data.Equality as Eq using (_≡_; refl; module ≡-Reasoning) +open import Calf.Data.Equality as Eq using (_≡_; refl; module ≡-Reasoning) open import Calf.Data.IsBoundedG costMonoid open import Calf.Data.IsBounded costMonoid open import Relation.Nullary @@ -38,9 +38,9 @@ branch/idem : {e : cmp X} → branch X e e ≡ e - branch/step : (c : ℂ) {e₀ e₁ : cmp X} → + branch/step : (c : ℂ) {e₀ e₁ : cmp X} → step X c (branch X e₀ e₁) ≡ branch X (step X c e₀) (step X c e₁) - fail/step : (c : ℂ) → + fail/step : (c : ℂ) → step X c (fail X) ≡ fail X bind/fail : {A : tp⁺} {f : val A → cmp X} → @@ -55,146 +55,146 @@ open Comparable M open import Examples.Sorting.Sequential.Core M - choose : cmp $ Π (list A) λ l → F (Σ⁺ A λ pivot → Σ⁺ (list A) λ l' → meta⁺ (l ↭ pivot ∷ l')) + choose : cmp $ Π (list A) λ l → F (Σ⁺ A λ pivot → Σ⁺ (list A) λ l' → meta⁺ (l ↭ pivot ∷ l')) choose [] = fail (F _) choose (x ∷ xs) = branch (F _) - (bind (F _) (choose xs) λ (pivot , l , xs↭pivot∷l) → ret (pivot , x ∷ l , trans (prep x xs↭pivot∷l) (swap x pivot refl))) - (ret (x , xs , refl)) + (bind (F _) (choose xs) λ (pivot , l , xs↭pivot∷l) → ret (pivot , x ∷ l , trans (prep x xs↭pivot∷l) (swap x pivot refl))) + (ret (x , xs , refl)) - choose/cost : cmp $ Π (list A) λ _ → cost + choose/cost : cmp $ Π (list A) λ _ → cost choose/cost l = ret triv choose/is-bounded : ∀ x xs → IsBoundedG _ (choose (x ∷ xs)) (choose/cost (x ∷ xs)) choose/is-bounded x [] = ≤⁻-reflexive branch/idˡ choose/is-bounded x (x' ∷ xs) = - let open ≤⁻-Reasoning cost in - begin + let open ≤⁻-Reasoning cost in + begin branch (F unit) (bind (F unit) (choose (x' ∷ xs)) λ _ → ret triv) (ret triv) - ≤⟨ ≤⁻-mono (λ e → branch (F unit) (bind (F unit) e λ _ → ret triv) (ret triv)) (choose/is-bounded x' xs) ⟩ + ≲⟨ ≤⁻-mono (λ e → branch (F unit) (bind (F unit) e λ _ → ret triv) (ret triv)) (choose/is-bounded x' xs) ⟩ branch (F unit) (ret triv) (ret triv) - ≡⟨ branch/idem ⟩ + ≡⟨ branch/idem ⟩ ret triv - ∎ + ∎ - partition : cmp $ Π A λ pivot → Π (list A) λ l → F (Σ⁺ (list A) λ l₁ → Σ⁺ (list A) λ l₂ → meta⁺ (All (_≤ pivot) l₁) ×⁺ meta⁺ (All (pivot ≤_) l₂) ×⁺ meta⁺ (l₁ ++ l₂ ↭ l)) - partition pivot [] = ret ([] , [] , [] , [] , refl) + partition : cmp $ Π A λ pivot → Π (list A) λ l → F (Σ⁺ (list A) λ l₁ → Σ⁺ (list A) λ l₂ → meta⁺ (All (_≤ pivot) l₁) ×⁺ meta⁺ (All (pivot ≤_) l₂) ×⁺ meta⁺ (l₁ ++ l₂ ↭ l)) + partition pivot [] = ret ([] , [] , [] , [] , refl) partition pivot (x ∷ xs) = bind (F _) (partition pivot xs) λ (xs₁ , xs₂ , h₁ , h₂ , xs₁++xs₂↭xs) → - bind (F _) (x ≤? pivot) $ case-≤ - (λ x≤pivot → ret (x ∷ xs₁ , xs₂ , x≤pivot ∷ h₁ , h₂ , prep x xs₁++xs₂↭xs)) - (λ x≰pivot → ret (xs₁ , x ∷ xs₂ , h₁ , ≰⇒≥ x≰pivot ∷ h₂ , trans (shift-↭ x xs₁ xs₂) (prep x xs₁++xs₂↭xs))) + bind (F _) (x ≤? pivot) $ case-≤ + (λ x≤pivot → ret (x ∷ xs₁ , xs₂ , x≤pivot ∷ h₁ , h₂ , prep x xs₁++xs₂↭xs)) + (λ x≰pivot → ret (xs₁ , x ∷ xs₂ , h₁ , ≰⇒≥ x≰pivot ∷ h₂ , trans (shift-↭ x xs₁ xs₂) (prep x xs₁++xs₂↭xs))) - partition/cost : cmp $ Π A λ a → Π (list A) λ l → cost - partition/cost _ l = step⋆ (length l) + partition/cost : cmp $ Π A λ a → Π (list A) λ l → cost + partition/cost _ l = step⋆ (length l) partition/is-bounded : ∀ pivot l → IsBoundedG _ (partition pivot l) (partition/cost pivot l) partition/is-bounded pivot [] = ≤⁻-refl partition/is-bounded pivot (x ∷ xs) = - let open ≤⁻-Reasoning cost in - begin + let open ≤⁻-Reasoning cost in + begin ( bind (F unit) (partition pivot xs) λ (xs₁ , xs₂ , h₁ , h₂ , xs₁++xs₂↭xs) → bind (F unit) (x ≤? pivot) λ x≤?pivot → - bind {Σ⁺ (list A) λ l₁ → Σ⁺ (list A) λ l₂ → meta⁺ (All (_≤ pivot) l₁) ×⁺ meta⁺ (All (pivot ≤_) l₂) ×⁺ meta⁺ (l₁ ++ l₂ ↭ x ∷ xs)} (F unit) + bind {Σ⁺ (list A) λ l₁ → Σ⁺ (list A) λ l₂ → meta⁺ (All (_≤ pivot) l₁) ×⁺ meta⁺ (All (pivot ≤_) l₂) ×⁺ meta⁺ (l₁ ++ l₂ ↭ x ∷ xs)} (F unit) ( case-≤ - (λ x≤pivot → ret (x ∷ xs₁ , xs₂ , x≤pivot ∷ h₁ , h₂ , prep x xs₁++xs₂↭xs)) - (λ x≰pivot → ret (xs₁ , x ∷ xs₂ , h₁ , ≰⇒≥ x≰pivot ∷ h₂ , trans (shift-↭ x xs₁ xs₂) (prep x xs₁++xs₂↭xs))) + (λ x≤pivot → ret (x ∷ xs₁ , xs₂ , x≤pivot ∷ h₁ , h₂ , prep x xs₁++xs₂↭xs)) + (λ x≰pivot → ret (xs₁ , x ∷ xs₂ , h₁ , ≰⇒≥ x≰pivot ∷ h₂ , trans (shift-↭ x xs₁ xs₂) (prep x xs₁++xs₂↭xs))) x≤?pivot ) (λ _ → ret triv) ) - ≡⟨ - ( Eq.cong (bind (F unit) (partition pivot xs)) $ funext λ (xs₁ , xs₂ , h₁ , h₂ , xs₁++xs₂↭xs) → - Eq.cong (bind (F unit) (x ≤? pivot)) $ funext $ + ≡⟨ + ( Eq.cong (bind (F unit) (partition pivot xs)) $ funext λ (xs₁ , xs₂ , h₁ , h₂ , xs₁++xs₂↭xs) → + Eq.cong (bind (F unit) (x ≤? pivot)) $ funext $ bind/case-≤ - {B = Σ⁺ (list A) λ l₁ → Σ⁺ (list A) λ l₂ → meta⁺ (All (_≤ pivot) l₁) ×⁺ meta⁺ (All (pivot ≤_) l₂) ×⁺ meta⁺ (l₁ ++ l₂ ↭ x ∷ xs)} + {B = Σ⁺ (list A) λ l₁ → Σ⁺ (list A) λ l₂ → meta⁺ (All (_≤ pivot) l₁) ×⁺ meta⁺ (All (pivot ≤_) l₂) ×⁺ meta⁺ (l₁ ++ l₂ ↭ x ∷ xs)} {X = F unit} {f = λ _ → ret triv} - (λ x≤pivot → ret (x ∷ xs₁ , xs₂ , x≤pivot ∷ h₁ , h₂ , prep x xs₁++xs₂↭xs)) - (λ x≰pivot → ret (xs₁ , x ∷ xs₂ , h₁ , ≰⇒≥ x≰pivot ∷ h₂ , trans (shift-↭ x xs₁ xs₂) (prep x xs₁++xs₂↭xs))) + (λ x≤pivot → ret (x ∷ xs₁ , xs₂ , x≤pivot ∷ h₁ , h₂ , prep x xs₁++xs₂↭xs)) + (λ x≰pivot → ret (xs₁ , x ∷ xs₂ , h₁ , ≰⇒≥ x≰pivot ∷ h₂ , trans (shift-↭ x xs₁ xs₂) (prep x xs₁++xs₂↭xs))) ) - ⟩ + ⟩ ( bind (F unit) (partition pivot xs) λ _ → - bind (F unit) (x ≤? pivot) $ case-≤ + bind (F unit) (x ≤? pivot) $ case-≤ (λ _ → ret triv) (λ _ → ret triv) ) - ≡⟨ - ( Eq.cong (bind (F unit) (partition pivot xs)) $ funext λ (xs₁ , xs₂ , h₁ , h₂ , xs₁++xs₂↭xs) → - Eq.cong (bind (F unit) (x ≤? pivot)) $ funext $ + ≡⟨ + ( Eq.cong (bind (F unit) (partition pivot xs)) $ funext λ (xs₁ , xs₂ , h₁ , h₂ , xs₁++xs₂↭xs) → + Eq.cong (bind (F unit) (x ≤? pivot)) $ funext $ case-≤/idem (ret triv) ) - ⟩ + ⟩ ( bind (F unit) (partition pivot xs) λ _ → bind (F unit) (x ≤? pivot) λ _ → ret triv ) - ≤⟨ + ≲⟨ ( ≤⁻-mono - {Π (Σ⁺ (list A) λ l₁ → Σ⁺ (list A) λ l₂ → meta⁺ (All (_≤ pivot) l₁) ×⁺ meta⁺ (All (pivot ≤_) l₂) ×⁺ meta⁺ (l₁ ++ l₂ ↭ xs)) λ _ → F unit} - (bind (F unit) (partition pivot xs)) $ + {Π (Σ⁺ (list A) λ l₁ → Σ⁺ (list A) λ l₂ → meta⁺ (All (_≤ pivot) l₁) ×⁺ meta⁺ (All (pivot ≤_) l₂) ×⁺ meta⁺ (l₁ ++ l₂ ↭ xs)) λ _ → F unit} + (bind (F unit) (partition pivot xs)) $ λ-mono-≤⁻ λ _ → h-cost x pivot ) - ⟩ + ⟩ ( bind (F unit) (partition pivot xs) λ _ → step⋆ 1 ) - ≡⟨⟩ + ≡⟨⟩ ( bind (F unit) (bind (F unit) (partition pivot xs) λ _ → ret triv) λ _ → step⋆ 1 ) - ≤⟨ ≤⁻-mono (λ e → bind (F unit) (bind (F unit) e λ _ → ret triv) λ _ → step (F unit) 1 (ret triv)) (partition/is-bounded pivot xs) ⟩ - ( bind (F unit) (step (F unit) (length xs) (ret triv)) λ _ → + ≲⟨ ≤⁻-mono (λ e → bind (F unit) (bind (F unit) e λ _ → ret triv) λ _ → step (F unit) 1 (ret triv)) (partition/is-bounded pivot xs) ⟩ + ( bind (F unit) (step (F unit) (length xs) (ret triv)) λ _ → step⋆ 1 ) - ≡⟨⟩ - step⋆ (length xs + 1) - ≡⟨ Eq.cong step⋆ (Nat.+-comm (length xs) 1) ⟩ - step⋆ (length (x ∷ xs)) - ∎ + ≡⟨⟩ + step⋆ (length xs + 1) + ≡⟨ Eq.cong step⋆ (Nat.+-comm (length xs) 1) ⟩ + step⋆ (length (x ∷ xs)) + ∎ {-# TERMINATING #-} - sort : cmp $ Π (list A) λ _ → F (list A) + sort : cmp $ Π (list A) λ _ → F (list A) sort [] = ret [] sort (x ∷ xs) = bind (F _) (choose (x ∷ xs)) λ (pivot , l , x∷xs↭pivot∷l) → bind (F _) (partition pivot l) λ (l₁ , l₂ , h₁ , h₂ , l₁++l₂↭l) → bind (F _) (sort l₁) λ l₁' → bind (F _) (sort l₂) λ l₂' → - ret (l₁' ++ [ x ] ++ l₂') + ret (l₁' ++ [ x ] ++ l₂') - sort/cost : cmp $ Π (list A) λ _ → cost - sort/cost l = step⋆ (length l ²) + sort/cost : cmp $ Π (list A) λ _ → cost + sort/cost l = step⋆ (length l ²) - sort/arithmetic : (m n : val nat) → m ² + n ² Nat.≤ (m + n) ² + sort/arithmetic : (m n : val nat) → m ² + n ² Nat.≤ (m + n) ² sort/arithmetic m n = - let open Nat.≤-Reasoning in - begin - m ² + n ² - ≤⟨ Nat.+-mono-≤ (Nat.m≤m+n (m * m) (n * m)) (Nat.m≤n+m (n * n) (m * n)) ⟩ - (m * m + n * m) + (m * n + n * n) - ≡˘⟨ Eq.cong₂ _+_ (Nat.*-distribʳ-+ m m n) (Nat.*-distribʳ-+ n m n) ⟩ - (m + n) * m + (m + n) * n - ≡˘⟨ Nat.*-distribˡ-+ (m + n) m n ⟩ - (m + n) * (m + n) - ∎ + let open Nat.≤-Reasoning in + begin + m ² + n ² + ≤⟨ Nat.+-mono-≤ (Nat.m≤m+n (m * m) (n * m)) (Nat.m≤n+m (n * n) (m * n)) ⟩ + (m * m + n * m) + (m * n + n * n) + ≡˘⟨ Eq.cong₂ _+_ (Nat.*-distribʳ-+ m m n) (Nat.*-distribʳ-+ n m n) ⟩ + (m + n) * m + (m + n) * n + ≡˘⟨ Nat.*-distribˡ-+ (m + n) m n ⟩ + (m + n) * (m + n) + ∎ {-# TERMINATING #-} sort/is-bounded : ∀ l → IsBoundedG _ (sort l) (sort/cost l) sort/is-bounded [] = ≤⁻-refl sort/is-bounded (x ∷ xs) = - let open ≤⁻-Reasoning cost in - begin + let open ≤⁻-Reasoning cost in + begin ( bind (F _) (choose (x ∷ xs)) λ (pivot , l , x∷xs↭pivot∷l) → bind (F _) (partition pivot l) λ (l₁ , l₂ , h₁ , h₂ , l₁++l₂↭l) → bind (F _) (sort l₁) λ _ → bind (F _) (sort l₂) λ _ → ret triv ) - ≤⟨ + ≲⟨ ( ≤⁻-mono - {Π (Σ⁺ A λ pivot → Σ⁺ (list A) λ l' → meta⁺ (x ∷ xs ↭ pivot ∷ l')) λ _ → F unit} + {Π (Σ⁺ A λ pivot → Σ⁺ (list A) λ l' → meta⁺ (x ∷ xs ↭ pivot ∷ l')) λ _ → F unit} {F unit} (bind (F unit) (choose (x ∷ xs))) {λ (pivot , l , x∷xs↭pivot∷l) → @@ -205,141 +205,141 @@ {λ (pivot , l , x∷xs↭pivot∷l) → bind (F _) (partition pivot l) λ (l₁ , l₂ , h₁ , h₂ , l₁++l₂↭l) → bind (F _) (sort l₁) λ _ → - step⋆ (length l₂ ²)} $ + step⋆ (length l₂ ²)} $ λ-mono-≤⁻ λ (pivot , l , x∷xs↭pivot∷l) → ≤⁻-mono - {Π (Σ⁺ (list A) λ l₁ → Σ⁺ (list A) λ l₂ → meta⁺ (All (_≤ pivot) l₁) ×⁺ meta⁺ (All (pivot ≤_) l₂) ×⁺ meta⁺ (l₁ ++ l₂ ↭ l)) λ _ → F unit} + {Π (Σ⁺ (list A) λ l₁ → Σ⁺ (list A) λ l₂ → meta⁺ (All (_≤ pivot) l₁) ×⁺ meta⁺ (All (pivot ≤_) l₂) ×⁺ meta⁺ (l₁ ++ l₂ ↭ l)) λ _ → F unit} {F unit} - (bind (F unit) (partition pivot l)) $ + (bind (F unit) (partition pivot l)) $ λ-mono-≤⁻ λ (l₁ , l₂ , h₁ , h₂ , l₁++l₂↭l) → - ≤⁻-mono (λ e → bind (F unit) (sort l₁) λ _ → e) $ + ≤⁻-mono (λ e → bind (F unit) (sort l₁) λ _ → e) $ sort/is-bounded l₂ ) - ⟩ + ⟩ ( bind (F _) (choose (x ∷ xs)) λ (pivot , l , x∷xs↭pivot∷l) → bind (F _) (partition pivot l) λ (l₁ , l₂ , h₁ , h₂ , l₁++l₂↭l) → bind (F _) (sort l₁) λ _ → - step⋆ (length l₂ ²) + step⋆ (length l₂ ²) ) - ≤⟨ + ≲⟨ ( ≤⁻-mono - {Π (Σ⁺ A λ pivot → Σ⁺ (list A) λ l' → meta⁺ (x ∷ xs ↭ pivot ∷ l')) λ _ → F unit} + {Π (Σ⁺ A λ pivot → Σ⁺ (list A) λ l' → meta⁺ (x ∷ xs ↭ pivot ∷ l')) λ _ → F unit} {F unit} (bind (F _) (choose (x ∷ xs))) {λ (pivot , l , x∷xs↭pivot∷l) → bind (F _) (partition pivot l) λ (l₁ , l₂ , h₁ , h₂ , l₁++l₂↭l) → bind (F _) (sort l₁) λ _ → - step⋆ (length l₂ ²)} + step⋆ (length l₂ ²)} {λ (pivot , l , x∷xs↭pivot∷l) → bind (F _) (partition pivot l) λ (l₁ , l₂ , h₁ , h₂ , l₁++l₂↭l) → - step⋆ (length l₁ ² + length l₂ ²)} $ + step⋆ (length l₁ ² + length l₂ ²)} $ λ-mono-≤⁻ λ (pivot , l , x∷xs↭pivot∷l) → ≤⁻-mono - {Π (Σ⁺ (list A) λ l₁ → Σ⁺ (list A) λ l₂ → meta⁺ (All (_≤ pivot) l₁) ×⁺ meta⁺ (All (pivot ≤_) l₂) ×⁺ meta⁺ (l₁ ++ l₂ ↭ l)) λ _ → F unit} + {Π (Σ⁺ (list A) λ l₁ → Σ⁺ (list A) λ l₂ → meta⁺ (All (_≤ pivot) l₁) ×⁺ meta⁺ (All (pivot ≤_) l₂) ×⁺ meta⁺ (l₁ ++ l₂ ↭ l)) λ _ → F unit} {F unit} - (bind (F _) (partition pivot l)) $ + (bind (F _) (partition pivot l)) $ λ-mono-≤⁻ λ (l₁ , l₂ , h₁ , h₂ , l₁++l₂↭l) → bind-irr-monoˡ-≤⁻ (sort/is-bounded l₁) ) - ⟩ + ⟩ ( bind (F _) (choose (x ∷ xs)) λ (pivot , l , x∷xs↭pivot∷l) → bind (F _) (partition pivot l) λ (l₁ , l₂ , h₁ , h₂ , l₁++l₂↭l) → - step⋆ (length l₁ ² + length l₂ ²) + step⋆ (length l₁ ² + length l₂ ²) ) - ≤⟨ + ≲⟨ ( ≤⁻-mono - {Π (Σ⁺ A λ pivot → Σ⁺ (list A) λ l' → meta⁺ (x ∷ xs ↭ pivot ∷ l')) λ _ → F unit} + {Π (Σ⁺ A λ pivot → Σ⁺ (list A) λ l' → meta⁺ (x ∷ xs ↭ pivot ∷ l')) λ _ → F unit} {F unit} (bind (F _) (choose (x ∷ xs))) {λ (pivot , l , x∷xs↭pivot∷l) → bind (F _) (partition pivot l) λ (l₁ , l₂ , h₁ , h₂ , l₁++l₂↭l) → - step⋆ (length l₁ ² + length l₂ ²)} + step⋆ (length l₁ ² + length l₂ ²)} {λ (pivot , l , x∷xs↭pivot∷l) → bind (F _) (partition pivot l) λ _ → - step⋆ (length l ²)} $ + step⋆ (length l ²)} $ λ-mono-≤⁻ λ (pivot , l , x∷xs↭pivot∷l) → ≤⁻-mono - {Π (Σ⁺ (list A) λ l₁ → Σ⁺ (list A) λ l₂ → meta⁺ (All (_≤ pivot) l₁) ×⁺ meta⁺ (All (pivot ≤_) l₂) ×⁺ meta⁺ (l₁ ++ l₂ ↭ l)) λ _ → F unit} + {Π (Σ⁺ (list A) λ l₁ → Σ⁺ (list A) λ l₂ → meta⁺ (All (_≤ pivot) l₁) ×⁺ meta⁺ (All (pivot ≤_) l₂) ×⁺ meta⁺ (l₁ ++ l₂ ↭ l)) λ _ → F unit} {F unit} - (bind (F _) (partition pivot l)) $ + (bind (F _) (partition pivot l)) $ λ-mono-≤⁻ λ (l₁ , l₂ , h₁ , h₂ , l₁++l₂↭l) → - ≤⁺-mono step⋆ $ - ≤⇒≤⁺ (Nat.≤-trans (sort/arithmetic (length l₁) (length l₂)) (Nat.≤-reflexive (Eq.cong _² (Eq.trans (Eq.sym (length-++ l₁)) (↭-length l₁++l₂↭l))))) + ≤⁺-mono step⋆ $ + ≤⇒≤⁺ (Nat.≤-trans (sort/arithmetic (length l₁) (length l₂)) (Nat.≤-reflexive (Eq.cong _² (Eq.trans (Eq.sym (length-++ l₁)) (↭-length l₁++l₂↭l))))) ) - ⟩ + ⟩ ( bind (F _) (choose (x ∷ xs)) λ (pivot , l , x∷xs↭pivot∷l) → bind (F _) (partition pivot l) λ _ → - step⋆ (length l ²) + step⋆ (length l ²) ) - ≤⟨ + ≲⟨ ( ≤⁻-mono - {Π (Σ⁺ A λ pivot → Σ⁺ (list A) λ l' → meta⁺ (x ∷ xs ↭ pivot ∷ l')) λ _ → F unit} + {Π (Σ⁺ A λ pivot → Σ⁺ (list A) λ l' → meta⁺ (x ∷ xs ↭ pivot ∷ l')) λ _ → F unit} {F unit} (bind (F _) (choose (x ∷ xs))) {λ (pivot , l , x∷xs↭pivot∷l) → bind (F _) (partition pivot l) λ _ → - step⋆ (length l ²)} + step⋆ (length l ²)} {λ (pivot , l , x∷xs↭pivot∷l) → - step⋆ (length l + length l ²)} $ + step⋆ (length l + length l ²)} $ λ-mono-≤⁻ λ (pivot , l , x∷xs↭pivot∷l) → bind-irr-monoˡ-≤⁻ (partition/is-bounded pivot l) ) - ⟩ + ⟩ ( bind (F _) (choose (x ∷ xs)) λ (pivot , l , x∷xs↭pivot∷l) → - step⋆ (length l + length l ²) + step⋆ (length l + length l ²) ) - ≡˘⟨ - ( Eq.cong (bind (F _) (choose (x ∷ xs))) $ funext λ (pivot , l , x∷xs↭pivot∷l) → - Eq.cong (λ c → step⋆ (c + c ²)) {length xs} {length l} (Eq.cong Nat.pred (↭-length x∷xs↭pivot∷l)) + ≡˘⟨ + ( Eq.cong (bind (F _) (choose (x ∷ xs))) $ funext λ (pivot , l , x∷xs↭pivot∷l) → + Eq.cong (λ c → step⋆ (c + c ²)) {length xs} {length l} (Eq.cong Nat.pred (↭-length x∷xs↭pivot∷l)) ) - ⟩ + ⟩ ( bind (F _) (choose (x ∷ xs)) λ _ → - step⋆ (length xs + length xs ²) + step⋆ (length xs + length xs ²) ) - ≤⟨ bind-irr-monoˡ-≤⁻ (choose/is-bounded x xs) ⟩ - step⋆ (length xs + length xs ²) - ≤⟨ step⋆-mono-≤⁻ (Nat.+-mono-≤ (Nat.n≤1+n (length xs)) (Nat.*-monoʳ-≤ (length xs) (Nat.n≤1+n (length xs)))) ⟩ - step⋆ (length (x ∷ xs) + length xs * length (x ∷ xs)) - ≡⟨⟩ - step⋆ (length (x ∷ xs) ²) - ∎ + ≲⟨ bind-irr-monoˡ-≤⁻ (choose/is-bounded x xs) ⟩ + step⋆ (length xs + length xs ²) + ≲⟨ step⋆-mono-≤⁻ (Nat.+-mono-≤ (Nat.n≤1+n (length xs)) (Nat.*-monoʳ-≤ (length xs) (Nat.n≤1+n (length xs)))) ⟩ + step⋆ (length (x ∷ xs) + length xs * length (x ∷ xs)) + ≡⟨⟩ + step⋆ (length (x ∷ xs) ²) + ∎ module Lookup {A : tp⁺} where - lookup : cmp $ Π (list A) λ _ → Π nat λ _ → F A + lookup : cmp $ Π (list A) λ _ → Π nat λ _ → F A lookup [] i = fail (F _) lookup (x ∷ xs) zero = ret x lookup (x ∷ xs) (suc i) = step (F _) 1 (lookup xs i) - lookup/bound : cmp $ Π (list A) λ _ → Π nat λ _ → F A - lookup/bound l i with i Nat.<? length l - ... | yes p = step (F _) i (ret (List.lookup l (Fin.fromℕ< p))) - ... | no _ = fail (F _) + lookup/bound : cmp $ Π (list A) λ _ → Π nat λ _ → F A + lookup/bound l i with i Nat.<? length l + ... | yes p = step (F _) i (ret (List.lookup l (Fin.fromℕ< p))) + ... | no _ = fail (F _) lookup/is-bounded : (l : val (list A)) (i : val nat) → lookup l i ≤⁻[ F A ] lookup/bound l i - lookup/is-bounded l i with i Nat.<? length l - ... | yes p = lemma l i p + lookup/is-bounded l i with i Nat.<? length l + ... | yes p = lemma l i p where - lemma : (l : val (list A)) (i : val nat) (p : i Nat.< length l) → lookup l i ≤⁻[ F A ] step (F _) i (ret (List.lookup l (Fin.fromℕ< p))) - lemma (x ∷ xs) zero (Nat.s≤s Nat.z≤n) = ≤⁻-refl - lemma (x ∷ xs) (suc i) (Nat.s≤s p) = ≤⁻-mono (step (F _) 1) (lemma xs i p) - ... | no ¬p = lemma l i (Nat.≮⇒≥ ¬p) + lemma : (l : val (list A)) (i : val nat) (p : i Nat.< length l) → lookup l i ≤⁻[ F A ] step (F _) i (ret (List.lookup l (Fin.fromℕ< p))) + lemma (x ∷ xs) zero (Nat.s≤s Nat.z≤n) = ≤⁻-refl + lemma (x ∷ xs) (suc i) (Nat.s≤s p) = ≤⁻-mono (step (F _) 1) (lemma xs i p) + ... | no ¬p = lemma l i (Nat.≮⇒≥ ¬p) where - lemma : (l : val (list A)) (i : val nat) → i Nat.≥ length l → lookup l i ≤⁻[ F A ] fail (F A) - lemma [] i Nat.z≤n = ≤⁻-refl - lemma (x ∷ xs) (suc i) (Nat.s≤s p) = - let open ≤⁻-Reasoning (F _) in - begin + lemma : (l : val (list A)) (i : val nat) → i Nat.≥ length l → lookup l i ≤⁻[ F A ] fail (F A) + lemma [] i Nat.z≤n = ≤⁻-refl + lemma (x ∷ xs) (suc i) (Nat.s≤s p) = + let open ≤⁻-Reasoning (F _) in + begin step (F _) 1 (lookup xs i) - ≤⟨ ≤⁻-mono (step (F _) 1) (lemma xs i p) ⟩ + ≲⟨ ≤⁻-mono (step (F _) 1) (lemma xs i p) ⟩ step (F _) 1 (fail (F _)) - ≡⟨ fail/step 1 ⟩ + ≡⟨ fail/step 1 ⟩ fail (F _) - ∎ + ∎ module Pervasive where - e : cmp $ F bool + e : cmp $ F bool e = branch (F bool) (step (F bool) 3 (ret true)) @@ -347,35 +347,35 @@ e/is-bounded : e ≤⁻[ F bool ] step (F bool) 12 (branch (F bool) (ret true) (ret false)) e/is-bounded = - let open ≤⁻-Reasoning (F bool) in - begin + let open ≤⁻-Reasoning (F bool) in + begin e - ≡⟨⟩ + ≡⟨⟩ branch (F bool) (step (F bool) 3 (ret true)) (step (F bool) 12 (ret false)) - ≤⟨ + ≲⟨ ≤⁻-mono (λ e → branch (F bool) e (step (F bool) 12 (ret false))) - (step-monoˡ-≤⁻ {F bool} (ret true) (Nat.s≤s (Nat.s≤s (Nat.s≤s Nat.z≤n)))) - ⟩ + (step-monoˡ-≤⁻ {F bool} (ret true) (Nat.s≤s (Nat.s≤s (Nat.s≤s Nat.z≤n)))) + ⟩ branch (F bool) (step (F bool) 12 (ret true)) (step (F bool) 12 (ret false)) - ≡˘⟨ branch/step 12 ⟩ + ≡˘⟨ branch/step 12 ⟩ step (F bool) 12 (branch (F bool) (ret true) (ret false)) - ∎ + ∎ e/is-bounded' : IsBounded bool e 12 e/is-bounded' = - let open ≤⁻-Reasoning (F unit) in - begin + let open ≤⁻-Reasoning (F unit) in + begin bind (F unit) e (λ _ → ret triv) - ≤⟨ ≤⁻-mono (λ e → bind (F _) e (λ _ → ret triv)) e/is-bounded ⟩ + ≲⟨ ≤⁻-mono (λ e → bind (F _) e (λ _ → ret triv)) e/is-bounded ⟩ bind (F unit) (step (F bool) 12 (branch (F bool) (ret true) (ret false))) (λ _ → ret triv) - ≡⟨⟩ + ≡⟨⟩ step (F unit) 12 (branch (F unit) (ret triv) (ret triv)) - ≡⟨ Eq.cong (step (F unit) 12) branch/idem ⟩ + ≡⟨ Eq.cong (step (F unit) 12) branch/idem ⟩ step⋆ 12 - ∎ + ∎ \ No newline at end of file diff --git a/Examples.Decalf.ProbabilisticChoice.html b/Examples.Decalf.ProbabilisticChoice.html index c3213cba..b21c8a60 100644 --- a/Examples.Decalf.ProbabilisticChoice.html +++ b/Examples.Decalf.ProbabilisticChoice.html @@ -6,13 +6,13 @@ open import Algebra.Cost costMonoid = ℕ-CostMonoid -open CostMonoid costMonoid using (ℂ) +open CostMonoid costMonoid using (ℂ) open import Calf costMonoid open import Calf.Data.Nat import Data.Nat.Properties as Nat open import Calf.Data.List -open import Calf.Data.Equality as Eq using (_≡_; refl; module ≡-Reasoning) +open import Calf.Data.Equality as Eq using (_≡_; refl; module ≡-Reasoning) open import Calf.Data.IsBoundedG costMonoid open import Calf.Data.IsBounded costMonoid open import Function hiding (flip) @@ -38,14 +38,14 @@ flip/assocˡ : (X : tp⁻) (e₀ e₁ e₂ : cmp X) {p q r : 𝕀} → p ≡ (p ∧ q) ∨ r → flip X p e₀ (flip X q e₁ e₂) ≡ flip X (p ∧ q) (flip X r e₀ e₁) e₂ flip/assocˡ X e₀ e₁ e₂ {p} {q} {r} h = - let open ≡-Reasoning in - begin + let open ≡-Reasoning in + begin flip X p e₀ (flip X q e₁ e₂) - ≡⟨ Eq.cong (λ p → flip X p e₀ (flip X q e₁ e₂)) h ⟩ + ≡⟨ Eq.cong (λ p → flip X p e₀ (flip X q e₁ e₂)) h ⟩ flip X (p ∧ q ∨ r) e₀ (flip X q e₁ e₂) - ≡˘⟨ flip/assocʳ X e₀ e₁ e₂ (Eq.cong (_∧ q) h) ⟩ + ≡˘⟨ flip/assocʳ X e₀ e₁ e₂ (Eq.cong (_∧ q) h) ⟩ flip X (p ∧ q) (flip X r e₀ e₁) e₂ - ∎ + ∎ postulate bind/flip : {f : val A → cmp X} {p : 𝕀} {e₀ e₁ : cmp (F A)} → @@ -62,16 +62,16 @@ bernoulli/upper : bernoulli ≤⁻[ cost ] step⋆ 1 bernoulli/upper = - let open ≤⁻-Reasoning cost in - begin + let open ≤⁻-Reasoning cost in + begin flip cost ½ (step⋆ 0) (step⋆ 1) - ≤⟨ ≤⁻-mono {cost} (λ e → flip cost ½ e (step⋆ 1)) (≤⁺-mono step⋆ (≤⇒≤⁺ (z≤n {1}))) ⟩ + ≲⟨ ≤⁻-mono {cost} (λ e → flip cost ½ e (step⋆ 1)) (≤⁺-mono step⋆ (≤⇒≤⁺ (z≤n {1}))) ⟩ flip cost ½ (step⋆ 1) (step⋆ 1) - ≡⟨ flip/same cost (step⋆ 1) {½} ⟩ + ≡⟨ flip/same cost (step⋆ 1) {½} ⟩ step⋆ 1 - ∎ + ∎ - binomial : cmp $ Π nat λ _ → cost + binomial : cmp $ Π nat λ _ → cost binomial zero = ret triv binomial (suc n) = bind cost bernoulli λ _ → @@ -81,95 +81,95 @@ (bind cost (binomial m) λ _ → binomial n) ≡ binomial (m + n) binomial/+ zero n = refl binomial/+ (suc m) n = - let open ≡-Reasoning in - begin + let open ≡-Reasoning in + begin ( bind cost bernoulli λ _ → bind cost (binomial m) λ _ → binomial n ) - ≡⟨ - ( Eq.cong (bind cost bernoulli) $ funext λ _ → + ≡⟨ + ( Eq.cong (bind cost bernoulli) $ funext λ _ → binomial/+ m n ) - ⟩ + ⟩ binomial (suc m + n) - ∎ + ∎ binomial/comm : (n : val nat) → (bind cost bernoulli λ _ → binomial n) ≡ (bind cost (binomial n) λ _ → bernoulli) binomial/comm zero = refl binomial/comm (suc n) = - let open ≡-Reasoning in - begin + let open ≡-Reasoning in + begin ( bind cost bernoulli λ _ → bind cost bernoulli λ _ → binomial n ) - ≡⟨ - ( Eq.cong (bind cost bernoulli) $ funext λ _ → + ≡⟨ + ( Eq.cong (bind cost bernoulli) $ funext λ _ → binomial/comm n ) - ⟩ + ⟩ ( bind cost bernoulli λ _ → bind cost (binomial n) λ _ → bernoulli ) - ∎ + ∎ binomial/upper : (n : val nat) → binomial n ≤⁻[ cost ] step⋆ n binomial/upper zero = ≤⁻-refl binomial/upper (suc n) = - let open ≤⁻-Reasoning cost in - begin + let open ≤⁻-Reasoning cost in + begin ( bind cost bernoulli λ _ → binomial n ) - ≤⟨ ≤⁻-mono (λ e → bind cost e λ _ → binomial n) bernoulli/upper ⟩ + ≲⟨ ≤⁻-mono (λ e → bind cost e λ _ → binomial n) bernoulli/upper ⟩ ( bind cost (step⋆ 1) λ _ → binomial n ) - ≡⟨⟩ + ≡⟨⟩ step cost 1 (binomial n) - ≤⟨ ≤⁻-mono (step cost 1) (binomial/upper n) ⟩ + ≲⟨ ≤⁻-mono (step cost 1) (binomial/upper n) ⟩ step⋆ (suc n) - ∎ + ∎ -sublist : cmp $ Π (list A) λ _ → F (list A) +sublist : cmp $ Π (list A) λ _ → F (list A) sublist {A} [] = ret [] sublist {A} (x ∷ xs) = bind (F (list A)) (sublist {A} xs) λ xs' → flip (F (list A)) ½ (ret xs') (step (F (list A)) 1 (ret (x ∷ xs'))) -sublist/cost : cmp $ Π (list A) λ _ → cost -sublist/cost l = binomial (length l) +sublist/cost : cmp $ Π (list A) λ _ → cost +sublist/cost l = binomial (length l) sublist/is-bounded : (l : val (list A)) → IsBoundedG (list A) (sublist {A} l) (sublist/cost {A} l) sublist/is-bounded {A} [] = ≤⁻-refl sublist/is-bounded {A} (x ∷ xs) = - let open ≤⁻-Reasoning cost in - begin + let open ≤⁻-Reasoning cost in + begin bind cost ( bind (F (list A)) (sublist {A} xs) λ xs' → flip (F (list A)) ½ (ret xs') (step (F (list A)) 1 (ret (x ∷ xs'))) ) (λ _ → ret triv) - ≡⟨⟩ + ≡⟨⟩ ( bind cost (sublist {A} xs) λ _ → flip cost ½ (ret triv) (step cost 1 (ret triv)) ) - ≡⟨⟩ + ≡⟨⟩ ( bind cost (sublist {A} xs) λ _ → bernoulli ) - ≤⟨ ≤⁻-mono (λ e → bind cost e λ _ → bernoulli) (sublist/is-bounded {A} xs) ⟩ - ( bind cost (binomial (length xs)) λ _ → + ≲⟨ ≤⁻-mono (λ e → bind cost e λ _ → bernoulli) (sublist/is-bounded {A} xs) ⟩ + ( bind cost (binomial (length xs)) λ _ → bernoulli ) - ≡˘⟨ binomial/comm (length xs) ⟩ - binomial (length (x ∷ xs)) - ∎ + ≡˘⟨ binomial/comm (length xs) ⟩ + binomial (length (x ∷ xs)) + ∎ -sublist/is-bounded' : (l : val (list A)) → IsBounded (list A) (sublist {A} l) (length l) -sublist/is-bounded' {A} l = ≤⁻-trans (sublist/is-bounded {A} l) (binomial/upper (length l)) +sublist/is-bounded' : (l : val (list A)) → IsBounded (list A) (sublist {A} l) (length l) +sublist/is-bounded' {A} l = ≤⁻-trans (sublist/is-bounded {A} l) (binomial/upper (length l)) \ No newline at end of file diff --git a/Examples.Exp2.html b/Examples.Exp2.html index 8409ec57..3b9ba148 100644 --- a/Examples.Exp2.html +++ b/Examples.Exp2.html @@ -6,17 +6,17 @@ open import Algebra.Cost parCostMonoid = ℕ²-ParCostMonoid -open ParCostMonoid parCostMonoid +open ParCostMonoid parCostMonoid -open import Calf costMonoid +open import Calf costMonoid open import Calf.Parallel parCostMonoid open import Calf.Data.Bool open import Calf.Data.Nat -open import Calf.Data.IsBounded costMonoid -open import Calf.Data.BigO costMonoid +open import Calf.Data.IsBounded costMonoid +open import Calf.Data.BigO costMonoid -open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; _≢_; module ≡-Reasoning) -open import Data.Nat as Nat using (_+_; pred; _*_; _^_; _⊔_) +open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; _≢_; module ≡-Reasoning) +open import Data.Nat as Nat using (_+_; pred; _*_; _^_; _⊔_) import Data.Nat.Properties as N open import Data.Nat.PredExp2 open import Data.Empty @@ -25,7 +25,7 @@ Correct : cmp (Π nat λ _ → F nat) → Set -Correct exp₂ = (n : ℕ) → ◯ (exp₂ n ≡ ret (2 ^ n)) +Correct exp₂ = (n : ℕ) → ◯ (exp₂ n ≡ ret (2 ^ n)) module Slow where exp₂ : cmp (Π nat λ _ → F nat) @@ -35,42 +35,42 @@ step (F nat) (1 , 1) (ret (r₁ + r₂)) exp₂/bound : cmp (Π nat λ _ → F nat) - exp₂/bound n = step (F nat) (pred[2^ n ] , n) (ret (2 ^ n)) + exp₂/bound n = step (F nat) (pred[2^ n ] , n) (ret (2 ^ n)) exp₂/is-bounded : ∀ n → exp₂ n ≤⁻[ F nat ] exp₂/bound n exp₂/is-bounded zero = ≤⁻-refl exp₂/is-bounded (suc n) = - let open ≤⁻-Reasoning (F nat) in - begin + let open ≤⁻-Reasoning (F nat) in + begin (bind (F nat) (exp₂ n ∥ exp₂ n) λ (r₁ , r₂) → step (F nat) (1 , 1) (ret (r₁ + r₂))) - ≤⟨ + ≲⟨ ≤⁻-mono₂ (λ e₁ e₂ → bind (F nat) (e₁ ∥ e₂) λ (r₁ , r₂) → step (F nat) (1 , 1) (ret (r₁ + r₂))) (exp₂/is-bounded n) (exp₂/is-bounded n) - ⟩ - (bind (F nat) ((step (F nat) (pred[2^ n ] , n) (ret (2 ^ n))) ∥ (step (F nat) (pred[2^ n ] , n) (ret (2 ^ n)))) λ (r₁ , r₂) → + ⟩ + (bind (F nat) ((step (F nat) (pred[2^ n ] , n) (ret (2 ^ n))) ∥ (step (F nat) (pred[2^ n ] , n) (ret (2 ^ n)))) λ (r₁ , r₂) → step (F nat) (1 , 1) (ret (r₁ + r₂))) - ≡⟨⟩ - step (F nat) (pred[2^ n ] + pred[2^ n ] + 1 , n ⊔ n + 1) (ret (2 ^ n + 2 ^ n)) - ≡⟨ - Eq.cong₂ (step (F nat)) - (Eq.cong₂ _,_ - (Eq.trans (N.+-comm _ 1) (pred[2^suc[n]] n)) - (Eq.trans (N.+-comm _ 1) (Eq.cong (1 +_) (N.⊔-idem n)))) - (Eq.cong ret (lemma/2^suc n)) - ⟩ - step (F nat) (pred[2^ suc n ] , suc n) (ret (2 ^ suc n)) - ∎ + ≡⟨⟩ + step (F nat) (pred[2^ n ] + pred[2^ n ] + 1 , n ⊔ n + 1) (ret (2 ^ n + 2 ^ n)) + ≡⟨ + Eq.cong₂ (step (F nat)) + (Eq.cong₂ _,_ + (Eq.trans (N.+-comm _ 1) (pred[2^suc[n]] n)) + (Eq.trans (N.+-comm _ 1) (Eq.cong (1 +_) (N.⊔-idem n)))) + (Eq.cong ret (lemma/2^suc n)) + ⟩ + step (F nat) (pred[2^ suc n ] , suc n) (ret (2 ^ suc n)) + ∎ exp₂/correct : Correct exp₂ - exp₂/correct n u = Eq.trans (≤⁻-ext-≡ u (exp₂/is-bounded n)) (step/ext (F nat) (ret (2 ^ n)) (pred[2^ n ] , n) u) + exp₂/correct n u = Eq.trans (≤⁻-ext-≡ u (exp₂/is-bounded n)) (step/ext (F nat) (ret (2 ^ n)) (pred[2^ n ] , n) u) - exp₂/asymptotic : given nat measured-via (λ n → n) , exp₂ ∈𝓞(λ n → 2 ^ n , n) + exp₂/asymptotic : given nat measured-via (λ n → n) , exp₂ ∈𝓞(λ n → 2 ^ n , n) exp₂/asymptotic = f[n]≤g[n]via λ n → ≤⁻-mono (λ e → bind (F _) e (λ _ → ret triv)) - (≤⁻-trans (exp₂/is-bounded n) (step-monoˡ-≤⁻ (ret (2 ^ n)) (N.pred[n]≤n {2 ^ n} , N.≤-refl {n}))) + (≤⁻-trans (exp₂/is-bounded n) (step-monoˡ-≤⁻ (ret (2 ^ n)) (N.pred[n]≤n {2 ^ n} , N.≤-refl {n}))) module Fast where @@ -82,30 +82,30 @@ step (F nat) (1 , 1) (ret (r + r)) exp₂/bound : cmp (Π nat λ _ → F nat) - exp₂/bound n = step (F nat) (n , n) (ret (2 ^ n)) + exp₂/bound n = step (F nat) (n , n) (ret (2 ^ n)) exp₂/is-bounded : ∀ n → exp₂ n ≤⁻[ F nat ] exp₂/bound n exp₂/is-bounded zero = ≤⁻-refl exp₂/is-bounded (suc n) = - let open ≤⁻-Reasoning (F nat) in - begin + let open ≤⁻-Reasoning (F nat) in + begin (bind (F nat) (exp₂ n) λ r → step (F nat) (1 , 1) (ret (r + r))) - ≤⟨ ≤⁻-mono (λ e → bind (F nat) e λ r → step (F nat) (1 , 1) (ret (r + r))) (exp₂/is-bounded n) ⟩ - (bind (F nat) (step (F nat) (n , n) (ret (2 ^ n))) λ r → + ≲⟨ ≤⁻-mono (λ e → bind (F nat) e λ r → step (F nat) (1 , 1) (ret (r + r))) (exp₂/is-bounded n) ⟩ + (bind (F nat) (step (F nat) (n , n) (ret (2 ^ n))) λ r → step (F nat) (1 , 1) (ret (r + r))) - ≡⟨⟩ - step (F nat) (n + 1 , n + 1) (ret (2 ^ n + 2 ^ n)) - ≡⟨ - Eq.cong₂ (step (F nat)) - (Eq.cong₂ _,_ (N.+-comm _ 1) (N.+-comm _ 1)) - (Eq.cong ret (lemma/2^suc n)) - ⟩ - step (F nat) (suc n , suc n) (ret (2 ^ suc n)) - ∎ + ≡⟨⟩ + step (F nat) (n + 1 , n + 1) (ret (2 ^ n + 2 ^ n)) + ≡⟨ + Eq.cong₂ (step (F nat)) + (Eq.cong₂ _,_ (N.+-comm _ 1) (N.+-comm _ 1)) + (Eq.cong ret (lemma/2^suc n)) + ⟩ + step (F nat) (suc n , suc n) (ret (2 ^ suc n)) + ∎ exp₂/correct : Correct exp₂ - exp₂/correct n u = Eq.trans (≤⁻-ext-≡ u (exp₂/is-bounded n)) (step/ext (F nat) (ret (2 ^ n)) (n , n) u) + exp₂/correct n u = Eq.trans (≤⁻-ext-≡ u (exp₂/is-bounded n)) (step/ext (F nat) (ret (2 ^ n)) (n , n) u) exp₂/asymptotic : given nat measured-via (λ n → n) , exp₂ ∈𝓞(λ n → n , n) exp₂/asymptotic = f[n]≤g[n]via (≤⁻-mono (λ e → bind (F _) e _) ∘ exp₂/is-bounded) @@ -113,12 +113,12 @@ slow≡fast : ◯ (Slow.exp₂ ≡ Fast.exp₂) slow≡fast u = funext λ n → - begin + begin Slow.exp₂ n - ≡⟨ Slow.exp₂/correct n u ⟩ - ret (2 ^ n) - ≡˘⟨ Fast.exp₂/correct n u ⟩ + ≡⟨ Slow.exp₂/correct n u ⟩ + ret (2 ^ n) + ≡˘⟨ Fast.exp₂/correct n u ⟩ Fast.exp₂ n - ∎ - where open ≡-Reasoning + ∎ + where open ≡-Reasoning \ No newline at end of file diff --git a/Examples.Id.html b/Examples.Id.html index b7a26c60..3580894e 100644 --- a/Examples.Id.html +++ b/Examples.Id.html @@ -6,15 +6,15 @@ open import Algebra.Cost costMonoid = ℕ-CostMonoid -open CostMonoid costMonoid +open CostMonoid costMonoid open import Calf costMonoid open import Calf.Data.Nat open import Calf.Data.IsBounded costMonoid open import Calf.Data.BigO costMonoid -open import Function using (_∘_; _$_) -open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; module ≡-Reasoning) +open import Function using (_∘_; _$_) +open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; module ≡-Reasoning) module Easy where @@ -49,18 +49,18 @@ id/is-bounded : ∀ n → id n ≤⁻[ F nat ] id/bound n id/is-bounded zero = ≤⁻-refl id/is-bounded (suc n) = - let open ≤⁻-Reasoning (F nat) in - ≤⁻-mono (step (F nat) 1) $ - begin + let open ≤⁻-Reasoning (F nat) in + ≤⁻-mono (step (F nat) 1) $ + begin bind (F nat) (id n) (λ n' → ret (suc n')) - ≤⟨ ≤⁻-mono (λ e → bind (F nat) e (ret ∘ suc)) (id/is-bounded n) ⟩ + ≲⟨ ≤⁻-mono (λ e → bind (F nat) e (ret ∘ suc)) (id/is-bounded n) ⟩ bind (F nat) (step (F nat) n (ret n)) (λ n' → ret (suc n')) - ≡⟨⟩ + ≡⟨⟩ step (F nat) n (ret (suc n)) - ∎ + ∎ id/correct : ∀ n → ◯ (id n ≡ ret n) - id/correct n u = Eq.trans (≤⁻-ext-≡ u (id/is-bounded n)) (step/ext (F nat) (ret n) n u) + id/correct n u = Eq.trans (≤⁻-ext-≡ u (id/is-bounded n)) (step/ext (F nat) (ret n) n u) id/asymptotic : given nat measured-via (λ n → n) , id ∈𝓞(λ n → n) id/asymptotic = f[n]≤g[n]via (≤⁻-mono (λ e → bind (F _) e _) ∘ id/is-bounded) @@ -69,12 +69,12 @@ easy≡hard : ◯ (Easy.id ≡ Hard.id) easy≡hard u = funext λ n → - begin + begin Easy.id n - ≡⟨ Easy.id/correct n u ⟩ + ≡⟨ Easy.id/correct n u ⟩ ret n - ≡˘⟨ Hard.id/correct n u ⟩ + ≡˘⟨ Hard.id/correct n u ⟩ Hard.id n - ∎ - where open ≡-Reasoning + ∎ + where open ≡-Reasoning \ No newline at end of file diff --git a/Examples.Sorting.Comparable.html b/Examples.Sorting.Comparable.html index cc5722e5..3d0d2d05 100644 --- a/Examples.Sorting.Comparable.html +++ b/Examples.Sorting.Comparable.html @@ -5,20 +5,20 @@ open import Data.Nat using (ℕ) module Examples.Sorting.Comparable - (costMonoid : CostMonoid) (fromℕ : ℕ → CostMonoid.ℂ costMonoid) where + (costMonoid : CostMonoid) (fromℕ : ℕ → CostMonoid.ℂ costMonoid) where -open CostMonoid costMonoid using (ℂ) +open CostMonoid costMonoid using (ℂ) open import Calf costMonoid hiding (A) open import Calf.Data.Bool using (bool) open import Calf.Data.IsBounded costMonoid -open import Calf.Data.Product using (∃) +open import Calf.Data.Product using (∃) open import Relation.Nullary open import Relation.Nullary.Negation open import Relation.Nullary.Reflects open import Relation.Binary -open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; module ≡-Reasoning) +open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; module ≡-Reasoning) open import Data.Sum open import Function @@ -27,49 +27,49 @@ field A : tp⁺ _≤_ : val A → val A → Set - ≤-refl : Reflexive _≤_ - ≤-trans : Transitive _≤_ - ≤-total : Total _≤_ - ≤-antisym : Antisymmetric _≡_ _≤_ + ≤-refl : Reflexive _≤_ + ≤-trans : Transitive _≤_ + ≤-total : Total _≤_ + ≤-antisym : Antisymmetric _≡_ _≤_ _≤?_ : cmp (Π A λ x → Π A λ y → F (meta⁺ (Dec (x ≤ y)))) - ≤?-total : (x y : val A) → ◯ (∃ λ p → x ≤? y ≡ ret p) + ≤?-total : (x y : val A) → ◯ (∃ λ p → x ≤? y ≡ ret p) h-cost : (x y : val A) → IsBounded (meta⁺ (Dec (x ≤ y))) (x ≤? y) (fromℕ 1) _≥_ : val A → val A → Set x ≥ y = y ≤ x _≰_ : val A → val A → Set - x ≰ y = ¬ x ≤ y + x ≰ y = ¬ x ≤ y - ≰⇒≥ : _≰_ ⇒ _≥_ + ≰⇒≥ : _≰_ ⇒ _≥_ ≰⇒≥ ¬x≤y with ≤-total _ _ - ... | inj₁ x≤y = contradiction x≤y ¬x≤y + ... | inj₁ x≤y = contradiction x≤y ¬x≤y ... | inj₂ y≤x = y≤x case-≤ : {S : Set} {x y : val A} → (x ≤ y → S) → (x ≰ y → S) → Dec (x ≤ y) → S - case-≤ {S} {x} {y} yes-branch no-branch (yes x≤y) = yes-branch x≤y - case-≤ {S} {x} {y} yes-branch no-branch (no ¬x≤y) = no-branch ¬x≤y + case-≤ {S} {x} {y} yes-branch no-branch (yes x≤y) = yes-branch x≤y + case-≤ {S} {x} {y} yes-branch no-branch (no ¬x≤y) = no-branch ¬x≤y bind/case-≤ : {x y : val A} {f : val B → cmp X} (yes-branch : x ≤ y → cmp (F B)) (no-branch : x ≰ y → cmp (F B)) (d : Dec (x ≤ y)) → bind X (case-≤ yes-branch no-branch d) f ≡ case-≤ (λ h → bind X (yes-branch h) f) (λ h → bind X (no-branch h) f) d - bind/case-≤ yes-branch no-branch (yes x≤y) = refl - bind/case-≤ yes-branch no-branch (no ¬x≤y) = refl + bind/case-≤ yes-branch no-branch (yes x≤y) = refl + bind/case-≤ yes-branch no-branch (no ¬x≤y) = refl case-≤/idem : {S : Set} {x y : val A} (branch : S) (d : Dec (x ≤ y)) → case-≤ {S} {x} {y} (λ _ → branch) (λ _ → branch) d ≡ branch - case-≤/idem branch (yes x≤y) = refl - case-≤/idem branch (no ¬x≤y) = refl + case-≤/idem branch (yes x≤y) = refl + case-≤/idem branch (no ¬x≤y) = refl NatComparable : Comparable NatComparable = record { A = nat - ; _≤_ = _≤_ - ; ≤-refl = ≤-refl - ; ≤-trans = ≤-trans - ; ≤-total = ≤-total - ; ≤-antisym = ≤-antisym - ; _≤?_ = λ x y → step (F (meta⁺ (Dec (x ≤ y)))) (fromℕ 1) (ret (x ≤? y)) - ; ≤?-total = λ x y u → (x ≤? y) , (step/ext (F _) (ret _) (fromℕ 1) u) + ; _≤_ = _≤_ + ; ≤-refl = ≤-refl + ; ≤-trans = ≤-trans + ; ≤-total = ≤-total + ; ≤-antisym = ≤-antisym + ; _≤?_ = λ x y → step (F (meta⁺ (Dec (x ≤ y)))) (fromℕ 1) (ret (x ≤? y)) + ; ≤?-total = λ x y u → (x ≤? y) , (step/ext (F _) (ret _) (fromℕ 1) u) ; h-cost = λ _ _ → ≤⁻-refl } where diff --git a/Examples.Sorting.Core.html b/Examples.Sorting.Core.html index 67e8f766..78dd4a77 100644 --- a/Examples.Sorting.Core.html +++ b/Examples.Sorting.Core.html @@ -6,7 +6,7 @@ open import Examples.Sorting.Comparable module Examples.Sorting.Core - (costMonoid : CostMonoid) (fromℕ : ℕ → CostMonoid.ℂ costMonoid) + (costMonoid : CostMonoid) (fromℕ : ℕ → CostMonoid.ℂ costMonoid) (M : Comparable costMonoid fromℕ) where @@ -14,34 +14,34 @@ open import Calf costMonoid hiding (A) open import Calf.Data.Product using (_×⁺_) -open import Calf.Data.List using (list; []; _∷_; _∷ʳ_; [_]; length; _++_; reverse) +open import Calf.Data.List using (list; []; _∷_; _∷ʳ_; [_]; length; _++_; reverse) open import Relation.Nullary open import Relation.Nullary.Negation open import Relation.Binary -open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; module ≡-Reasoning) -open import Data.Product using (_×_; _,_; ∃; proj₁; proj₂) +open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; module ≡-Reasoning) +open import Data.Product using (_×_; _,_; ∃; proj₁; proj₂) open import Data.Sum using (inj₁; inj₂) -open import Data.Nat as Nat using (ℕ; zero; suc; z≤n; s≤s; _+_; _*_; _^_; ⌊_/2⌋; ⌈_/2⌉) +open import Data.Nat as Nat using (ℕ; zero; suc; z≤n; s≤s; _+_; _*_; _^_; ⌊_/2⌋; ⌈_/2⌉) import Data.Nat.Properties as N -open import Data.List.Properties using (++-assoc; length-++) public +open import Data.List.Properties using (++-assoc; length-++) public open import Data.List.Relation.Binary.Permutation.Propositional public open import Data.List.Relation.Binary.Permutation.Propositional.Properties - using (↭-length; ¬x∷xs↭[]; All-resp-↭; Any-resp-↭; drop-∷; ++-identityʳ) - renaming (++-comm to ++-comm-↭; ++⁺ˡ to ++⁺ˡ-↭; ++⁺ʳ to ++⁺ʳ-↭; ++⁺ to ++⁺-↭; shift to shift-↭) public + using (↭-length; ¬x∷xs↭[]; All-resp-↭; Any-resp-↭; drop-∷; ++-identityʳ) + renaming (++-comm to ++-comm-↭; ++⁺ˡ to ++⁺ˡ-↭; ++⁺ʳ to ++⁺ʳ-↭; ++⁺ to ++⁺-↭; shift to shift-↭) public -open import Data.List.Relation.Unary.All using (All; []; _∷_; map; lookup) public -open import Data.List.Relation.Unary.All.Properties as AllP using () renaming (++⁺ to ++⁺-All) public -open import Data.List.Relation.Unary.Any using (Any; here; there) +open import Data.List.Relation.Unary.All using (All; []; _∷_; map; lookup) public +open import Data.List.Relation.Unary.All.Properties as AllP using () renaming (++⁺ to ++⁺-All) public +open import Data.List.Relation.Unary.Any using (Any; here; there) _≤*_ : val A → val (list A) → Set -_≤*_ x = All (x ≤_) +_≤*_ x = All (x ≤_) ≤-≤* : ∀ {x₁ x₂ l} → x₁ ≤ x₂ → x₂ ≤* l → x₁ ≤* l -≤-≤* x₁≤x₂ = map (≤-trans x₁≤x₂) +≤-≤* x₁≤x₂ = map (≤-trans x₁≤x₂) data Sorted : val (list A) → Set where [] : Sorted [] @@ -50,37 +50,37 @@ sorted : val (list A) → tp⁺ sorted l = meta⁺ (Sorted l) -short-sorted : {l : val (list A)} → length l Nat.≤ 1 → Sorted l +short-sorted : {l : val (list A)} → length l Nat.≤ 1 → Sorted l short-sorted {[]} _ = [] -short-sorted {_ ∷ []} _ = [] ∷ [] -short-sorted {_ ∷ _ ∷ _} (s≤s ()) +short-sorted {_ ∷ []} _ = [] ∷ [] +short-sorted {_ ∷ _ ∷ _} (s≤s ()) -unique-sorted : ∀ {l'₁ l'₂} → Sorted l'₁ → Sorted l'₂ → l'₁ ↭ l'₂ → l'₁ ≡ l'₂ +unique-sorted : ∀ {l'₁ l'₂} → Sorted l'₁ → Sorted l'₂ → l'₁ ↭ l'₂ → l'₁ ≡ l'₂ unique-sorted [] [] ↭ = refl -unique-sorted [] (h₂ ∷ sorted₂) ↭ = contradiction (↭-sym ↭) ¬x∷xs↭[] -unique-sorted (h₁ ∷ sorted₁) [] ↭ = contradiction (↭) ¬x∷xs↭[] +unique-sorted [] (h₂ ∷ sorted₂) ↭ = contradiction (↭-sym ↭) ¬x∷xs↭[] +unique-sorted (h₁ ∷ sorted₁) [] ↭ = contradiction (↭) ¬x∷xs↭[] unique-sorted (h₁ ∷ sorted₁) (h₂ ∷ sorted₂) ↭ with ≤-antisym - (lookup (≤-refl ∷ h₁) (Any-resp-↭ (↭-sym ↭) (here refl))) - (lookup (≤-refl ∷ h₂) (Any-resp-↭ (↭) (here refl))) -... | refl = Eq.cong (_ ∷_) (unique-sorted sorted₁ sorted₂ (drop-∷ ↭)) + (lookup (≤-refl ∷ h₁) (Any-resp-↭ (↭-sym ↭) (here refl))) + (lookup (≤-refl ∷ h₂) (Any-resp-↭ (↭) (here refl))) +... | refl = Eq.cong (_ ∷_) (unique-sorted sorted₁ sorted₂ (drop-∷ ↭)) -join-sorted : ∀ {l₁ mid l₂} → Sorted l₁ → Sorted l₂ → All (_≤ mid) l₁ → All (mid ≤_) l₂ → Sorted (l₁ ++ [ mid ] ++ l₂) +join-sorted : ∀ {l₁ mid l₂} → Sorted l₁ → Sorted l₂ → All (_≤ mid) l₁ → All (mid ≤_) l₂ → Sorted (l₁ ++ [ mid ] ++ l₂) join-sorted [] sorted₂ all₁ all₂ = all₂ ∷ sorted₂ -join-sorted (h ∷ sorted₁) sorted₂ (h' ∷ all₁) all₂ = - ++⁺-All h (h' ∷ ≤-≤* h' all₂) ∷ (join-sorted sorted₁ sorted₂ all₁ all₂) +join-sorted (h ∷ sorted₁) sorted₂ (h' ∷ all₁) all₂ = + ++⁺-All h (h' ∷ ≤-≤* h' all₂) ∷ (join-sorted sorted₁ sorted₂ all₁ all₂) -++⁻ˡ : ∀ xs {ys} → Sorted (xs ++ ys) → Sorted xs +++⁻ˡ : ∀ xs {ys} → Sorted (xs ++ ys) → Sorted xs ++⁻ˡ [] sorted = [] -++⁻ˡ (x ∷ xs) (h ∷ sorted) = AllP.++⁻ˡ xs h ∷ (++⁻ˡ xs sorted) +++⁻ˡ (x ∷ xs) (h ∷ sorted) = AllP.++⁻ˡ xs h ∷ (++⁻ˡ xs sorted) -++⁻ʳ : ∀ xs {ys} → Sorted (xs ++ ys) → Sorted ys +++⁻ʳ : ∀ xs {ys} → Sorted (xs ++ ys) → Sorted ys ++⁻ʳ [] sorted = sorted ++⁻ʳ (x ∷ xs) (h ∷ sorted) = ++⁻ʳ xs sorted -split-sorted₁ : ∀ xs {x} → Sorted (xs ∷ʳ x) → All (_≤ x) xs -split-sorted₁ [] sorted = [] -split-sorted₁ (x ∷ xs) (h ∷ sorted) = proj₂ (AllP.∷ʳ⁻ h) ∷ split-sorted₁ xs sorted +split-sorted₁ : ∀ xs {x} → Sorted (xs ∷ʳ x) → All (_≤ x) xs +split-sorted₁ [] sorted = [] +split-sorted₁ (x ∷ xs) (h ∷ sorted) = proj₂ (AllP.∷ʳ⁻ h) ∷ split-sorted₁ xs sorted uncons₁ : ∀ {x xs} → Sorted (x ∷ xs) → x ≤* xs uncons₁ (h ∷ sorted) = h @@ -89,7 +89,7 @@ uncons₂ (h ∷ sorted) = sorted sorted-of : val (list A) → val (list A) → tp⁺ -sorted-of l l' = meta⁺ (l ↭ l') ×⁺ (sorted l') +sorted-of l l' = meta⁺ (l ↭ l') ×⁺ (sorted l') sort-result : val (list A) → tp⁺ sort-result l = Σ⁺ (list A) (sorted-of l) @@ -118,14 +118,14 @@ funext λ l → let (l₁' , l↭l₁' , sorted₁) = Valuable.value (total₁ l u) in let (l₂' , l↭l₂' , sorted₂) = Valuable.value (total₂ l u) in - begin + begin (sort₁ algorithm) l - ≡⟨ Eq.cong (λ e → bind (F (list A)) e λ (l' , _) → ret l') (Valuable.proof (total₁ l u)) ⟩ + ≡⟨ Eq.cong (λ e → bind (F (list A)) e λ (l' , _) → ret l') (Valuable.proof (total₁ l u)) ⟩ ret l₁' - ≡⟨ Eq.cong ret (unique-sorted sorted₁ sorted₂ (trans (↭-sym l↭l₁') l↭l₂')) ⟩ + ≡⟨ Eq.cong ret (unique-sorted sorted₁ sorted₂ (trans (↭-sym l↭l₁') l↭l₂')) ⟩ ret l₂' - ≡˘⟨ Eq.cong (λ e → bind (F (list A)) e λ (l' , _) → ret l') (Valuable.proof (total₂ l u)) ⟩ + ≡˘⟨ Eq.cong (λ e → bind (F (list A)) e λ (l' , _) → ret l') (Valuable.proof (total₂ l u)) ⟩ (sort₂ algorithm) l - ∎ - where open ≡-Reasoning + ∎ + where open ≡-Reasoning \ No newline at end of file diff --git a/Examples.Sorting.Sequential.Comparable.html b/Examples.Sorting.Sequential.Comparable.html index 734c9c7f..755b2348 100644 --- a/Examples.Sorting.Sequential.Comparable.html +++ b/Examples.Sorting.Sequential.Comparable.html @@ -9,9 +9,9 @@ costMonoid = ℕ-CostMonoid open import Data.Nat using (ℕ) -open CostMonoid costMonoid using (ℂ) +open CostMonoid costMonoid using (ℂ) -fromℕ : ℕ → ℂ +fromℕ : ℕ → ℂ fromℕ n = n open import Examples.Sorting.Comparable costMonoid fromℕ public diff --git a/Examples.Sorting.Sequential.Core.html b/Examples.Sorting.Sequential.Core.html index 6d74e096..c13abdcc 100644 --- a/Examples.Sorting.Sequential.Core.html +++ b/Examples.Sorting.Sequential.Core.html @@ -6,8 +6,8 @@ module Examples.Sorting.Sequential.Core (M : Comparable) where open import Algebra.Cost -open CostMonoid costMonoid - hiding (zero; _+_; _≤_; ≤-refl; ≤-trans) public +open CostMonoid costMonoid + hiding (zero; _+_; _≤_; ≤-refl; ≤-trans) public open import Examples.Sorting.Core costMonoid fromℕ M public \ No newline at end of file diff --git a/Examples.Sorting.Sequential.InsertionSort.html b/Examples.Sorting.Sequential.InsertionSort.html index 8c495d8d..01cd25f4 100644 --- a/Examples.Sorting.Sequential.InsertionSort.html +++ b/Examples.Sorting.Sequential.InsertionSort.html @@ -18,44 +18,44 @@ open import Relation.Nullary open import Relation.Nullary.Negation -open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; module ≡-Reasoning) -open import Data.Product using (∃) +open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; module ≡-Reasoning) +open import Data.Product using (∃) open import Data.Sum using (inj₁; inj₂) open import Function -open import Data.Nat as Nat using (ℕ; zero; suc; z≤n; s≤s; _+_; _*_) +open import Data.Nat as Nat using (ℕ; zero; suc; z≤n; s≤s; _+_; _*_) import Data.Nat.Properties as N open import Data.Nat.Square insert : cmp (Π A λ x → Π (list A) λ l → Π (sorted l) λ _ → F (Σ⁺ (list A) λ l' → sorted-of (x ∷ l) l')) -insert x [] [] = ret ([ x ] , refl , [] ∷ []) +insert x [] [] = ret ([ x ] , refl , [] ∷ []) insert x (y ∷ ys) (h ∷ hs) = - bind (F _) (x ≤? y) $ case-≤ - (λ x≤y → ret (x ∷ (y ∷ ys) , refl , (x≤y ∷ ≤-≤* x≤y h) ∷ (h ∷ hs))) + bind (F _) (x ≤? y) $ case-≤ + (λ x≤y → ret (x ∷ (y ∷ ys) , refl , (x≤y ∷ ≤-≤* x≤y h) ∷ (h ∷ hs))) (λ x≰y → bind (F _) (insert x ys hs) λ (x∷ys' , x∷ys↭x∷ys' , sorted-x∷ys') → ret ( y ∷ x∷ys' - , ( let open PermutationReasoning in - begin - x ∷ y ∷ ys - <<⟨ refl ⟩ - y ∷ (x ∷ ys) - <⟨ x∷ys↭x∷ys' ⟩ + , ( let open PermutationReasoning in + begin + x ∷ y ∷ ys + <<⟨ refl ⟩ + y ∷ (x ∷ ys) + <⟨ x∷ys↭x∷ys' ⟩ y ∷ x∷ys' - ∎ + ∎ ) - , All-resp-↭ x∷ys↭x∷ys' (≰⇒≥ x≰y ∷ h) ∷ sorted-x∷ys' + , All-resp-↭ x∷ys↭x∷ys' (≰⇒≥ x≰y ∷ h) ∷ sorted-x∷ys' )) insert/total : ∀ x l h → IsValuable (insert x l h) insert/total x [] [] u = ↓ refl insert/total x (y ∷ ys) (h ∷ hs) u with ≤?-total x y u -... | yes x≤y , ≡ret rewrite ≡ret = ↓ refl -... | no x≰y , ≡ret rewrite ≡ret | Valuable.proof (insert/total x ys hs u) = ↓ refl +... | yes x≤y , ≡ret rewrite ≡ret = ↓ refl +... | no x≰y , ≡ret rewrite ≡ret | Valuable.proof (insert/total x ys hs u) = ↓ refl insert/cost : cmp (Π A λ _ → Π (list A) λ _ → cost) -insert/cost x l = step⋆ (length l) +insert/cost x l = step⋆ (length l) insert/is-bounded : ∀ x l h → IsBoundedG (Σ⁺ (list A) λ l' → sorted-of (x ∷ l) l') (insert x l h) (insert/cost x l) insert/is-bounded x [] [] = ≤⁻-refl @@ -64,83 +64,83 @@ {x ≤? y} {case-≤ _ _} 1 - (length ys) + (length ys) (h-cost x y) - λ { (yes x≤y) → step-monoˡ-≤⁻ (ret _) (z≤n {length ys}) - ; (no ¬x≤y) → insert/is-bounded x ys hs + λ { (yes x≤y) → step-monoˡ-≤⁻ (ret _) (z≤n {length ys}) + ; (no ¬x≤y) → insert/is-bounded x ys hs } sort : cmp sorting -sort [] = ret ([] , refl , []) +sort [] = ret ([] , refl , []) sort (x ∷ xs) = bind (F (Σ⁺ (list A) (sorted-of (x ∷ xs)))) (sort xs) λ (xs' , xs↭xs' , sorted-xs') → bind (F (Σ⁺ (list A) (sorted-of (x ∷ xs)))) (insert x xs' sorted-xs') λ (x∷xs' , x∷xs↭x∷xs' , sorted-x∷xs') → - ret (x∷xs' , trans (prep x xs↭xs') x∷xs↭x∷xs' , sorted-x∷xs') + ret (x∷xs' , trans (prep x xs↭xs') x∷xs↭x∷xs' , sorted-x∷xs') sort/total : IsTotal sort sort/total [] u = ↓ refl sort/total (x ∷ xs) u = ↓ let (xs' , xs↭xs' , sorted-xs') = Valuable.value (sort/total xs u) in let (x∷xs' , x∷xs↭x∷xs' , sorted-x∷xs') = Valuable.value (insert/total x xs' sorted-xs' u) in - let open ≡-Reasoning in - begin + let open ≡-Reasoning in + begin sort (x ∷ xs) - ≡⟨ - Eq.cong + ≡⟨ + Eq.cong (λ e → bind (F (Σ⁺ (list A) (sorted-of (x ∷ xs)))) e λ (xs' , xs↭xs' , sorted-xs') → bind (F (Σ⁺ (list A) (sorted-of (x ∷ xs)))) (insert x xs' sorted-xs') λ (x∷xs' , x∷xs↭x∷xs' , sorted-x∷xs') → - ret (x∷xs' , trans (prep x xs↭xs') x∷xs↭x∷xs' , sorted-x∷xs')) + ret (x∷xs' , trans (prep x xs↭xs') x∷xs↭x∷xs' , sorted-x∷xs')) (Valuable.proof (sort/total xs u)) - ⟩ + ⟩ ( bind (F (Σ⁺ (list A) (sorted-of (x ∷ xs)))) (insert x xs' sorted-xs') λ (x∷xs' , x∷xs↭x∷xs' , sorted-x∷xs') → ret (x∷xs' , _ , sorted-x∷xs') ) - ≡⟨ - Eq.cong + ≡⟨ + Eq.cong (λ e → bind (F (Σ⁺ (list A) (sorted-of (x ∷ xs)))) e λ (x∷xs' , x∷xs↭x∷xs' , sorted-x∷xs') → - ret (x∷xs' , trans (prep x xs↭xs') x∷xs↭x∷xs' , sorted-x∷xs')) + ret (x∷xs' , trans (prep x xs↭xs') x∷xs↭x∷xs' , sorted-x∷xs')) (Valuable.proof (insert/total x xs' sorted-xs' u)) - ⟩ + ⟩ ret _ - ∎ + ∎ sort/cost : cmp (Π (list A) λ _ → cost) -sort/cost l = step⋆ (length l ²) +sort/cost l = step⋆ (length l ²) sort/is-bounded : ∀ l → IsBoundedG (Σ⁺ (list A) (sorted-of l)) (sort l) (sort/cost l) sort/is-bounded [] = ≤⁻-refl sort/is-bounded (x ∷ xs) = - let open ≤⁻-Reasoning cost in - begin + let open ≤⁻-Reasoning cost in + begin ( bind cost (sort xs) λ (xs' , xs↭xs' , sorted-xs') → bind cost (insert x xs' sorted-xs') λ _ → step⋆ zero ) - ≤⟨ bind-monoʳ-≤⁻ (sort xs) (λ (xs' , xs↭xs' , sorted-xs') → insert/is-bounded x xs' sorted-xs') ⟩ + ≲⟨ bind-monoʳ-≤⁻ (sort xs) (λ (xs' , xs↭xs' , sorted-xs') → insert/is-bounded x xs' sorted-xs') ⟩ ( bind cost (sort xs) λ (xs' , xs↭xs' , sorted-xs') → - step⋆ (length xs') + step⋆ (length xs') ) - ≡˘⟨ - Eq.cong + ≡˘⟨ + Eq.cong (bind cost (sort xs)) - (funext λ (xs' , xs↭xs' , sorted-xs') → Eq.cong step⋆ (↭-length xs↭xs')) - ⟩ + (funext λ (xs' , xs↭xs' , sorted-xs') → Eq.cong step⋆ (↭-length xs↭xs')) + ⟩ ( bind cost (sort xs) λ _ → - step⋆ (length xs) + step⋆ (length xs) ) - ≤⟨ bind-monoˡ-≤⁻ (λ _ → step⋆ (length xs)) (sort/is-bounded xs) ⟩ - step⋆ ((length xs ²) + length xs) - ≤⟨ step⋆-mono-≤⁻ (N.+-mono-≤ (N.*-monoʳ-≤ (length xs) (N.n≤1+n (length xs))) (N.n≤1+n (length xs))) ⟩ - step⋆ (length xs * length (x ∷ xs) + length (x ∷ xs)) - ≡⟨ Eq.cong step⋆ (N.+-comm (length xs * length (x ∷ xs)) (length (x ∷ xs))) ⟩ - step⋆ (length (x ∷ xs) ²) - ≡⟨⟩ + ≲⟨ bind-monoˡ-≤⁻ (λ _ → step⋆ (length xs)) (sort/is-bounded xs) ⟩ + step⋆ ((length xs ²) + length xs) + ≲⟨ step⋆-mono-≤⁻ (N.+-mono-≤ (N.*-monoʳ-≤ (length xs) (N.n≤1+n (length xs))) (N.n≤1+n (length xs))) ⟩ + step⋆ (length xs * length (x ∷ xs) + length (x ∷ xs)) + ≡⟨ Eq.cong step⋆ (N.+-comm (length xs * length (x ∷ xs)) (length (x ∷ xs))) ⟩ + step⋆ (length (x ∷ xs) ²) + ≡⟨⟩ sort/cost (x ∷ xs) - ∎ + ∎ -sort/asymptotic : given (list A) measured-via length , sort ∈𝓞(λ n → n ²) +sort/asymptotic : given (list A) measured-via length , sort ∈𝓞(λ n → n ²) sort/asymptotic = f[n]≤g[n]via sort/is-bounded \ No newline at end of file diff --git a/Examples.Sorting.Sequential.MergeSort.Merge.html b/Examples.Sorting.Sequential.MergeSort.Merge.html index 46c57eb1..d7754ba9 100644 --- a/Examples.Sorting.Sequential.MergeSort.Merge.html +++ b/Examples.Sorting.Sequential.MergeSort.Merge.html @@ -12,61 +12,61 @@ open import Calf.Data.Product open import Calf.Data.Bool using (bool) open import Calf.Data.Nat using (nat) -open import Calf.Data.List using (list; []; _∷_; _∷ʳ_; [_]; length; _++_; reverse) +open import Calf.Data.List using (list; []; _∷_; _∷ʳ_; [_]; length; _++_; reverse) open import Calf.Data.Equality open import Calf.Data.IsBoundedG costMonoid open import Calf.Data.IsBounded costMonoid open import Relation.Nullary -open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; module ≡-Reasoning) +open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; module ≡-Reasoning) open import Function -open import Data.Nat as Nat using (ℕ; zero; suc; z≤n; s≤s; _+_; _*_) +open import Data.Nat as Nat using (ℕ; zero; suc; z≤n; s≤s; _+_; _*_) import Data.Nat.Properties as N open import Examples.Sorting.Sequential.MergeSort.Split M -prep' : ∀ {x : val A} {xs} y {ys l} → x ∷ xs ++ ys ↭ l → x ∷ xs ++ y ∷ ys ↭ y ∷ l +prep' : ∀ {x : val A} {xs} y {ys l} → x ∷ xs ++ ys ↭ l → x ∷ xs ++ y ∷ ys ↭ y ∷ l prep' {x} {xs} y {ys} {l} h = - let open PermutationReasoning in - begin - (x ∷ xs ++ y ∷ ys) - ↭⟨ ++-comm-↭ (x ∷ xs) (y ∷ ys) ⟩ - (y ∷ ys ++ x ∷ xs) - ≡⟨⟩ - y ∷ (ys ++ x ∷ xs) - <⟨ ++-comm-↭ ys (x ∷ xs) ⟩ - y ∷ (x ∷ xs ++ ys) - <⟨ h ⟩ + let open PermutationReasoning in + begin + (x ∷ xs ++ y ∷ ys) + ↭⟨ ++-comm-↭ (x ∷ xs) (y ∷ ys) ⟩ + (y ∷ ys ++ x ∷ xs) + ≡⟨⟩ + y ∷ (ys ++ x ∷ xs) + <⟨ ++-comm-↭ ys (x ∷ xs) ⟩ + y ∷ (x ∷ xs ++ ys) + <⟨ h ⟩ y ∷ l - ∎ + ∎ merge/type : val pair → tp⁺ -merge/type (l₁ , l₂) = Σ⁺ (list A) λ l → sorted-of (l₁ ++ l₂) l +merge/type (l₁ , l₂) = Σ⁺ (list A) λ l → sorted-of (l₁ ++ l₂) l -merge/clocked : cmp $ +merge/clocked : cmp $ Π nat λ k → Π pair λ (l₁ , l₂) → Π (sorted l₁ ×⁺ sorted l₂) λ _ → - Π (meta⁺ (length l₁ + length l₂ ≡ k)) λ _ → + Π (meta⁺ (length l₁ + length l₂ ≡ k)) λ _ → F (merge/type (l₁ , l₂)) -merge/clocked zero ([] , [] ) (sorted₁ , sorted₂ ) h = ret ([] , refl , []) -merge/clocked (suc k) ([] , l₂ ) ([] , sorted₂ ) h = ret (l₂ , refl , sorted₂) -merge/clocked (suc k) (x ∷ xs , [] ) (sorted₁ , sorted₂ ) h = ret (x ∷ xs , ++-identityʳ (x ∷ xs) , sorted₁) +merge/clocked zero ([] , [] ) (sorted₁ , sorted₂ ) h = ret ([] , refl , []) +merge/clocked (suc k) ([] , l₂ ) ([] , sorted₂ ) h = ret (l₂ , refl , sorted₂) +merge/clocked (suc k) (x ∷ xs , [] ) (sorted₁ , sorted₂ ) h = ret (x ∷ xs , ++-identityʳ (x ∷ xs) , sorted₁) merge/clocked (suc k) (x ∷ xs , y ∷ ys) (h₁ ∷ sorted₁ , h₂ ∷ sorted₂) h = - bind (F (merge/type (x ∷ xs , y ∷ ys))) (x ≤? y) $ case-≤ + bind (F (merge/type (x ∷ xs , y ∷ ys))) (x ≤? y) $ case-≤ (λ x≤y → - let h' = N.suc-injective h in + let h' = N.suc-injective h in bind (F (merge/type (x ∷ xs , y ∷ ys))) (merge/clocked k (xs , y ∷ ys) (sorted₁ , h₂ ∷ sorted₂) h') λ (l , l↭xs++y∷ys , l-sorted) → - ret (x ∷ l , prep x l↭xs++y∷ys , All-resp-↭ l↭xs++y∷ys (++⁺-All h₁ (x≤y ∷ ≤-≤* x≤y h₂)) ∷ l-sorted) + ret (x ∷ l , prep x l↭xs++y∷ys , All-resp-↭ l↭xs++y∷ys (++⁺-All h₁ (x≤y ∷ ≤-≤* x≤y h₂)) ∷ l-sorted) ) (λ x≰y → let y≤x = ≰⇒≥ x≰y in - let h' = Eq.trans (Eq.sym (N.+-suc (length xs) (length ys))) (N.suc-injective h) in + let h' = Eq.trans (Eq.sym (N.+-suc (length xs) (length ys))) (N.suc-injective h) in bind (F (merge/type (x ∷ xs , y ∷ ys))) (merge/clocked k (x ∷ xs , ys) (h₁ ∷ sorted₁ , sorted₂) h') λ (l , l↭x∷xs++ys , l-sorted) → - ret (y ∷ l , prep' y l↭x∷xs++ys , All-resp-↭ l↭x∷xs++ys (++⁺-All (y≤x ∷ ≤-≤* y≤x h₁) h₂) ∷ l-sorted) + ret (y ∷ l , prep' y l↭x∷xs++ys , All-resp-↭ l↭x∷xs++ys (++⁺-All (y≤x ∷ ≤-≤* y≤x h₁) h₂) ∷ l-sorted) ) merge/clocked/total : ∀ k p s h → IsValuable (merge/clocked k p s h) @@ -74,26 +74,26 @@ merge/clocked/total (suc k) ([] , l₂ ) ([] , sorted₂ ) h u = ↓ refl merge/clocked/total (suc k) (x ∷ xs , [] ) (sorted₁ , sorted₂ ) h u = ↓ refl merge/clocked/total (suc k) (x ∷ xs , y ∷ ys) (h₁ ∷ sorted₁ , h₂ ∷ sorted₂) h u with ≤?-total x y u -... | yes x≤y , ≡ret +... | yes x≤y , ≡ret rewrite ≡ret - | Valuable.proof (merge/clocked/total k (xs , y ∷ ys) (sorted₁ , h₂ ∷ sorted₂) (N.suc-injective h) u) + | Valuable.proof (merge/clocked/total k (xs , y ∷ ys) (sorted₁ , h₂ ∷ sorted₂) (N.suc-injective h) u) = ↓ refl -... | no x≰y , ≡ret +... | no x≰y , ≡ret rewrite ≡ret - | Valuable.proof (merge/clocked/total k (x ∷ xs , ys) (h₁ ∷ sorted₁ , sorted₂) (Eq.trans (Eq.sym (N.+-suc (length xs) (length ys))) (N.suc-injective h)) u) + | Valuable.proof (merge/clocked/total k (x ∷ xs , ys) (h₁ ∷ sorted₁ , sorted₂) (Eq.trans (Eq.sym (N.+-suc (length xs) (length ys))) (N.suc-injective h)) u) = ↓ refl -merge/clocked/cost : cmp $ +merge/clocked/cost : cmp $ Π nat λ k → Π pair λ (l₁ , l₂) → Π (sorted l₁ ×⁺ sorted l₂) λ _ → - Π (meta⁺ (length l₁ + length l₂ ≡ k)) λ _ → + Π (meta⁺ (length l₁ + length l₂ ≡ k)) λ _ → F unit merge/clocked/cost k _ _ _ = step⋆ k merge/clocked/is-bounded : ∀ k p s h → IsBoundedG (merge/type p) (merge/clocked k p s h) (merge/clocked/cost k p s h) merge/clocked/is-bounded zero ([] , [] ) (sorted₁ , sorted₂ ) h = ≤⁻-refl -merge/clocked/is-bounded (suc k) ([] , l₂ ) ([] , sorted₂ ) h = step⋆-mono-≤⁻ (z≤n {suc k}) -merge/clocked/is-bounded (suc k) (x ∷ xs , [] ) (sorted₁ , [] ) h = step⋆-mono-≤⁻ (z≤n {suc k}) +merge/clocked/is-bounded (suc k) ([] , l₂ ) ([] , sorted₂ ) h = step⋆-mono-≤⁻ (z≤n {suc k}) +merge/clocked/is-bounded (suc k) (x ∷ xs , [] ) (sorted₁ , [] ) h = step⋆-mono-≤⁻ (z≤n {suc k}) merge/clocked/is-bounded (suc k) (x ∷ xs , y ∷ ys) (h₁ ∷ sorted₁ , h₂ ∷ sorted₂) h = bound/bind/const {e = x ≤? y} @@ -101,26 +101,26 @@ 1 k (h-cost x y) - λ { (yes p) → bind-monoˡ-≤⁻ (λ _ → step⋆ zero) (merge/clocked/is-bounded k (xs , y ∷ ys) _ _) - ; (no ¬p) → bind-monoˡ-≤⁻ (λ _ → step⋆ zero) (merge/clocked/is-bounded k (x ∷ xs , ys) _ _) + λ { (yes p) → bind-monoˡ-≤⁻ (λ _ → step⋆ zero) (merge/clocked/is-bounded k (xs , y ∷ ys) _ _) + ; (no ¬p) → bind-monoˡ-≤⁻ (λ _ → step⋆ zero) (merge/clocked/is-bounded k (x ∷ xs , ys) _ _) } -merge : cmp $ +merge : cmp $ Π pair λ (l₁ , l₂) → Π (sorted l₁ ×⁺ sorted l₂) λ _ → F (merge/type (l₁ , l₂)) -merge (l₁ , l₂) s = merge/clocked (length l₁ + length l₂) (l₁ , l₂) s refl +merge (l₁ , l₂) s = merge/clocked (length l₁ + length l₂) (l₁ , l₂) s refl merge/total : ∀ p s → IsValuable (merge p s) -merge/total (l₁ , l₂) s = merge/clocked/total (length l₁ + length l₂) (l₁ , l₂) s refl +merge/total (l₁ , l₂) s = merge/clocked/total (length l₁ + length l₂) (l₁ , l₂) s refl -merge/cost : cmp $ +merge/cost : cmp $ Π pair λ (l₁ , l₂) → Π (sorted l₁ ×⁺ sorted l₂) λ _ → cost -merge/cost (l₁ , l₂) s = merge/clocked/cost (length l₁ + length l₂) (l₁ , l₂) s refl +merge/cost (l₁ , l₂) s = merge/clocked/cost (length l₁ + length l₂) (l₁ , l₂) s refl merge/is-bounded : ∀ p s → IsBoundedG (merge/type p) (merge p s) (merge/cost p s) -merge/is-bounded (l₁ , l₂) s = merge/clocked/is-bounded (length l₁ + length l₂) (l₁ , l₂) s refl +merge/is-bounded (l₁ , l₂) s = merge/clocked/is-bounded (length l₁ + length l₂) (l₁ , l₂) s refl \ No newline at end of file diff --git a/Examples.Sorting.Sequential.MergeSort.Split.html b/Examples.Sorting.Sequential.MergeSort.Split.html index 708013ee..14c3df8a 100644 --- a/Examples.Sorting.Sequential.MergeSort.Split.html +++ b/Examples.Sorting.Sequential.MergeSort.Split.html @@ -14,44 +14,44 @@ open import Calf.Data.List open import Calf.Data.IsBoundedG costMonoid -open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; module ≡-Reasoning) -open import Data.Nat as Nat using (ℕ; zero; suc; _+_; _*_; ⌊_/2⌋; ⌈_/2⌉) -open import Data.Nat.Properties as N using (module ≤-Reasoning) +open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; module ≡-Reasoning) +open import Data.Nat as Nat using (ℕ; zero; suc; _+_; _*_; ⌊_/2⌋; ⌈_/2⌉) +open import Data.Nat.Properties as N using (module ≤-Reasoning) pair = list A ×⁺ list A split/type : val nat → val nat → val (list A) → tp⁺ -split/type k k' l = Σ⁺ pair λ (l₁ , l₂) → meta⁺ (length l₁ ≡ k × length l₂ ≡ k' × l ↭ (l₁ ++ l₂)) +split/type k k' l = Σ⁺ pair λ (l₁ , l₂) → meta⁺ (length l₁ ≡ k × length l₂ ≡ k' × l ↭ (l₁ ++ l₂)) -split/clocked : cmp (Π nat λ k → Π nat λ k' → Π (list A) λ l → Π (meta⁺ (k + k' ≡ length l)) λ _ → F (split/type k k' l)) -split/clocked zero k' l refl = ret (([] , l) , refl , refl , refl) +split/clocked : cmp (Π nat λ k → Π nat λ k' → Π (list A) λ l → Π (meta⁺ (k + k' ≡ length l)) λ _ → F (split/type k k' l)) +split/clocked zero k' l refl = ret (([] , l) , refl , refl , refl) split/clocked (suc k) k' (x ∷ xs) h = - bind (F (split/type (suc k) k' (x ∷ xs))) (split/clocked k k' xs (N.suc-injective h)) λ ((l₁ , l₂) , h₁ , h₂ , xs↭l₁++l₂) → - ret ((x ∷ l₁ , l₂) , Eq.cong suc h₁ , h₂ , prep x xs↭l₁++l₂) + bind (F (split/type (suc k) k' (x ∷ xs))) (split/clocked k k' xs (N.suc-injective h)) λ ((l₁ , l₂) , h₁ , h₂ , xs↭l₁++l₂) → + ret ((x ∷ l₁ , l₂) , Eq.cong suc h₁ , h₂ , prep x xs↭l₁++l₂) split/clocked/total : ∀ k k' l h → IsValuable (split/clocked k k' l h) split/clocked/total zero k' l refl u = ↓ refl split/clocked/total (suc k) k' (x ∷ xs) h u - rewrite Valuable.proof (split/clocked/total k k' xs (N.suc-injective h) u) = ↓ refl + rewrite Valuable.proof (split/clocked/total k k' xs (N.suc-injective h) u) = ↓ refl -split/clocked/cost : cmp (Π nat λ k → Π nat λ k' → Π (list A) λ l → Π (meta⁺ (k + k' ≡ length l)) λ _ → F unit) +split/clocked/cost : cmp (Π nat λ k → Π nat λ k' → Π (list A) λ l → Π (meta⁺ (k + k' ≡ length l)) λ _ → F unit) split/clocked/cost _ _ _ _ = step⋆ zero split/clocked/is-bounded : ∀ k k' l h → IsBoundedG (split/type k k' l) (split/clocked k k' l h) (split/clocked/cost k k' l h) split/clocked/is-bounded zero k' l refl = ≤⁻-refl -split/clocked/is-bounded (suc k) k' (x ∷ xs) h = bind-monoˡ-≤⁻ _ (split/clocked/is-bounded k k' xs (N.suc-injective h)) +split/clocked/is-bounded (suc k) k' (x ∷ xs) h = bind-monoˡ-≤⁻ _ (split/clocked/is-bounded k k' xs (N.suc-injective h)) -split : cmp (Π (list A) λ l → F (split/type ⌊ length l /2⌋ ⌈ length l /2⌉ l)) -split l = split/clocked ⌊ length l /2⌋ ⌈ length l /2⌉ l (N.⌊n/2⌋+⌈n/2⌉≡n (length l)) +split : cmp (Π (list A) λ l → F (split/type ⌊ length l /2⌋ ⌈ length l /2⌉ l)) +split l = split/clocked ⌊ length l /2⌋ ⌈ length l /2⌉ l (N.⌊n/2⌋+⌈n/2⌉≡n (length l)) split/total : ∀ l → IsValuable (split l) -split/total l = split/clocked/total ⌊ length l /2⌋ ⌈ length l /2⌉ l (N.⌊n/2⌋+⌈n/2⌉≡n (length l)) +split/total l = split/clocked/total ⌊ length l /2⌋ ⌈ length l /2⌉ l (N.⌊n/2⌋+⌈n/2⌉≡n (length l)) split/cost : cmp (Π (list A) λ _ → F unit) -split/cost l = split/clocked/cost ⌊ length l /2⌋ ⌈ length l /2⌉ l (N.⌊n/2⌋+⌈n/2⌉≡n (length l)) +split/cost l = split/clocked/cost ⌊ length l /2⌋ ⌈ length l /2⌉ l (N.⌊n/2⌋+⌈n/2⌉≡n (length l)) -split/is-bounded : ∀ l → IsBoundedG (split/type ⌊ length l /2⌋ ⌈ length l /2⌉ l) (split l) (split/cost l) -split/is-bounded l = split/clocked/is-bounded ⌊ length l /2⌋ ⌈ length l /2⌉ l (N.⌊n/2⌋+⌈n/2⌉≡n (length l)) +split/is-bounded : ∀ l → IsBoundedG (split/type ⌊ length l /2⌋ ⌈ length l /2⌉ l) (split l) (split/cost l) +split/is-bounded l = split/clocked/is-bounded ⌊ length l /2⌋ ⌈ length l /2⌉ l (N.⌊n/2⌋+⌈n/2⌉≡n (length l)) \ No newline at end of file diff --git a/Examples.Sorting.Sequential.MergeSort.html b/Examples.Sorting.Sequential.MergeSort.html index 357a8114..7690c139 100644 --- a/Examples.Sorting.Sequential.MergeSort.html +++ b/Examples.Sorting.Sequential.MergeSort.html @@ -12,7 +12,7 @@ open import Calf.Data.Product open import Calf.Data.Bool open import Calf.Data.Nat -open import Calf.Data.List using (list; []; _∷_; _∷ʳ_; [_]; length; _++_; reverse) +open import Calf.Data.List using (list; []; _∷_; _∷ʳ_; [_]; length; _++_; reverse) open import Calf.Data.Equality using (_≡_; refl) open import Calf.Data.IsBoundedG costMonoid open import Calf.Data.IsBounded costMonoid @@ -20,10 +20,10 @@ open import Relation.Nullary open import Relation.Nullary.Negation -open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; module ≡-Reasoning) +open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; module ≡-Reasoning) open import Data.Sum using (inj₁; inj₂) open import Function -open import Data.Nat as Nat using (ℕ; zero; suc; z≤n; s≤s; _+_; _*_; ⌊_/2⌋; ⌈_/2⌉) +open import Data.Nat as Nat using (ℕ; zero; suc; z≤n; s≤s; _+_; _*_; ⌊_/2⌋; ⌈_/2⌉) import Data.Nat.Properties as N open import Data.Nat.Square open import Data.Nat.Log2 @@ -32,205 +32,205 @@ open import Examples.Sorting.Sequential.MergeSort.Split M public open import Examples.Sorting.Sequential.MergeSort.Merge M public -sort/clocked : cmp $ Π nat λ k → Π (list A) λ l → Π (meta⁺ (⌈log₂ length l ⌉ Nat.≤ k)) λ _ → F (sort-result l) -sort/clocked zero l h = ret (l , refl , short-sorted (⌈log₂n⌉≡0⇒n≤1 (N.n≤0⇒n≡0 h))) +sort/clocked : cmp $ Π nat λ k → Π (list A) λ l → Π (meta⁺ (⌈log₂ length l ⌉ Nat.≤ k)) λ _ → F (sort-result l) +sort/clocked zero l h = ret (l , refl , short-sorted (⌈log₂n⌉≡0⇒n≤1 (N.n≤0⇒n≡0 h))) sort/clocked (suc k) l h = bind (F (sort-result l)) (split l) λ ((l₁ , l₂) , length₁ , length₂ , l↭l₁++l₂) → let h₁ , h₂ = - let open ≤-Reasoning in - (begin - ⌈log₂ length l₁ ⌉ - ≡⟨ Eq.cong ⌈log₂_⌉ length₁ ⟩ - ⌈log₂ ⌊ length l /2⌋ ⌉ - ≤⟨ log₂-mono (N.⌊n/2⌋≤⌈n/2⌉ (length l)) ⟩ - ⌈log₂ ⌈ length l /2⌉ ⌉ - ≤⟨ log₂-suc (length l) h ⟩ - k - ∎) , - (begin - ⌈log₂ length l₂ ⌉ - ≡⟨ Eq.cong ⌈log₂_⌉ length₂ ⟩ - ⌈log₂ ⌈ length l /2⌉ ⌉ - ≤⟨ log₂-suc (length l) h ⟩ - k - ∎) - in - bind (F (sort-result l)) (sort/clocked k l₁ h₁) λ (l₁' , l₁↭l₁' , sorted-l₁') → - bind (F (sort-result l)) (sort/clocked k l₂ h₂) λ (l₂' , l₂↭l₂' , sorted-l₂') → - bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → - ret (l' , trans l↭l₁++l₂ (trans (++⁺-↭ l₁↭l₁' l₂↭l₂') l₁'++l₂'↭l) , l'-sorted) - -sort/clocked/total : ∀ k l h → IsValuable (sort/clocked k l h) -sort/clocked/total zero l h u = ↓ refl -sort/clocked/total (suc k) l h u rewrite Valuable.proof (split/total l u) = ↓ - let - ((l₁ , l₂) , length₁ , length₂ , l↭l₁++l₂) = Valuable.value (split/total l u) - h₁ , h₂ = - let open ≤-Reasoning in - (begin - ⌈log₂ length l₁ ⌉ - ≡⟨ Eq.cong ⌈log₂_⌉ length₁ ⟩ - ⌈log₂ ⌊ length l /2⌋ ⌉ - ≤⟨ log₂-mono (N.⌊n/2⌋≤⌈n/2⌉ (length l)) ⟩ - ⌈log₂ ⌈ length l /2⌉ ⌉ - ≤⟨ log₂-suc (length l) h ⟩ - k - ∎) , - (begin - ⌈log₂ length l₂ ⌉ - ≡⟨ Eq.cong ⌈log₂_⌉ length₂ ⟩ - ⌈log₂ ⌈ length l /2⌉ ⌉ - ≤⟨ log₂-suc (length l) h ⟩ - k - ∎) - (l₁' , l₁↭l₁' , sorted-l₁') = Valuable.value (sort/clocked/total k l₁ h₁ u) - (l₂' , l₂↭l₂' , sorted-l₂') = Valuable.value (sort/clocked/total k l₂ h₂ u) - in - let open ≡-Reasoning in - begin - ( bind (F (sort-result l)) (sort/clocked k l₁ h₁) λ (l₁' , l₁↭l₁' , sorted-l₁') → - bind (F (sort-result l)) (sort/clocked k l₂ h₂) λ (l₂' , l₂↭l₂' , sorted-l₂') → - bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → - ret (l' , trans l↭l₁++l₂ (trans (++⁺-↭ l₁↭l₁' l₂↭l₂') l₁'++l₂'↭l) , l'-sorted) - ) - ≡⟨ - Eq.cong - (λ e → - bind (F (sort-result l)) e λ (l₁' , l₁↭l₁' , sorted-l₁') → - bind (F (sort-result l)) (sort/clocked k l₂ h₂) λ (l₂' , l₂↭l₂' , sorted-l₂') → - bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → - ret (l' , trans l↭l₁++l₂ (trans (++⁺-↭ l₁↭l₁' l₂↭l₂') l₁'++l₂'↭l) , l'-sorted) - ) - (Valuable.proof (sort/clocked/total k l₁ h₁ u)) - ⟩ - ( bind (F (sort-result l)) (sort/clocked k l₂ h₂) λ (l₂' , l₂↭l₂' , sorted-l₂') → - bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → - ret (l' , trans l↭l₁++l₂ (trans (++⁺-↭ l₁↭l₁' l₂↭l₂') l₁'++l₂'↭l) , l'-sorted) - ) - ≡⟨ - Eq.cong - (λ e → - bind (F (sort-result l)) e λ (l₂' , l₂↭l₂' , sorted-l₂') → - bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → - ret (l' , trans l↭l₁++l₂ (trans (++⁺-↭ l₁↭l₁' l₂↭l₂') l₁'++l₂'↭l) , l'-sorted) - ) - (Valuable.proof (sort/clocked/total k l₂ h₂ u)) - ⟩ - ( bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → - ret (l' , trans l↭l₁++l₂ (trans (++⁺-↭ l₁↭l₁' l₂↭l₂') l₁'++l₂'↭l) , l'-sorted) - ) - ≡⟨ - Eq.cong - (λ e → - bind (F (sort-result l)) e λ (l' , l₁'++l₂'↭l , l'-sorted) → - ret (l' , trans l↭l₁++l₂ (trans (++⁺-↭ l₁↭l₁' l₂↭l₂') l₁'++l₂'↭l) , l'-sorted) - ) - (Valuable.proof (merge/total (l₁' , l₂') (sorted-l₁' , sorted-l₂') u)) - ⟩ - ret _ - ∎ - -sort/clocked/cost : cmp $ Π nat λ k → Π (list A) λ l → Π (meta⁺ (⌈log₂ length l ⌉ Nat.≤ k)) λ _ → F unit -sort/clocked/cost k l _ = step⋆ (k * length l) - -sort/clocked/is-bounded : ∀ k l h → IsBoundedG (sort-result l) (sort/clocked k l h) (sort/clocked/cost k l h) -sort/clocked/is-bounded zero l h = ≤⁻-refl -sort/clocked/is-bounded (suc k) l h = - bound/bind/const - {e = split l} - {f = λ ((l₁ , l₂) , length₁ , length₂ , l↭l₁++l₂) → - bind (F (sort-result l)) (sort/clocked k l₁ _) λ (l₁' , l₁↭l₁' , sorted-l₁') → - bind (F (sort-result l)) (sort/clocked k l₂ _) λ (l₂' , l₂↭l₂' , sorted-l₂') → - bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → - ret {sort-result l} (l' , ↭-trans l↭l₁++l₂ (↭-trans (_↭_.trans (++⁺ʳ-↭ l₂ l₁↭l₁') (++⁺ˡ-↭ l₁' l₂↭l₂')) (↭-trans l₁'++l₂'↭l _↭_.refl)) , l'-sorted) - } - 0 - (suc k * length l) - (split/is-bounded l) - λ ((l₁ , l₂) , length₁ , length₂ , l↭l₁++l₂) → - Eq.subst - (IsBounded (sort-result l) $ - bind (F (sort-result l)) (sort/clocked k l₁ _) λ (l₁' , l₁↭l₁' , sorted-l₁') → - bind (F (sort-result l)) (sort/clocked k l₂ _) λ (l₂' , l₂↭l₂' , sorted-l₂') → - bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → - ret {sort-result l} (l' , ↭-trans l↭l₁++l₂ (↭-trans (_↭_.trans (++⁺ʳ-↭ l₂ l₁↭l₁') (++⁺ˡ-↭ l₁' l₂↭l₂')) (↭-trans l₁'++l₂'↭l _↭_.refl)) , l'-sorted) - ) - (let open ≡-Reasoning in - begin - k * length l₁ + (k * length l₂ + (length l₁ + length l₂)) - ≡˘⟨ N.+-assoc (k * length l₁) (k * length l₂) (length l₁ + length l₂) ⟩ - (k * length l₁ + k * length l₂) + (length l₁ + length l₂) - ≡˘⟨ Eq.cong (_+ (length l₁ + length l₂)) (N.*-distribˡ-+ k (length l₁) (length l₂)) ⟩ - k * (length l₁ + length l₂) + (length l₁ + length l₂) - ≡˘⟨ N.+-comm (length l₁ + length l₂) (k * (length l₁ + length l₂)) ⟩ - suc k * (length l₁ + length l₂) - ≡˘⟨ Eq.cong (suc k *_) (length-++ l₁) ⟩ - suc k * (length (l₁ ++ l₂)) - ≡˘⟨ Eq.cong (suc k *_) (↭-length l↭l₁++l₂) ⟩ - suc k * length l - ∎) $ - bound/bind/const - {e = sort/clocked k l₁ _} - {f = λ (l₁' , l₁↭l₁' , sorted-l₁') → - bind (F (sort-result l)) (sort/clocked k l₂ _) λ (l₂' , l₂↭l₂' , sorted-l₂') → - bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → - ret {sort-result l} (l' , ↭-trans l↭l₁++l₂ (↭-trans (_↭_.trans (++⁺ʳ-↭ l₂ l₁↭l₁') (++⁺ˡ-↭ l₁' l₂↭l₂')) (↭-trans l₁'++l₂'↭l _↭_.refl)) , l'-sorted) - } - (k * length l₁) - (k * length l₂ + (length l₁ + length l₂)) - (sort/clocked/is-bounded k l₁ _) - λ (l₁' , l₁↭l₁' , sorted-l₁') → - bound/bind/const - {e = sort/clocked k l₂ _} - {f = λ (l₂' , l₂↭l₂' , sorted-l₂') → - bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → - ret {sort-result l} (l' , ↭-trans l↭l₁++l₂ (↭-trans (_↭_.trans (++⁺ʳ-↭ l₂ l₁↭l₁') (++⁺ˡ-↭ l₁' l₂↭l₂')) (↭-trans l₁'++l₂'↭l _↭_.refl)) , l'-sorted) - } - (k * length l₂) - (length l₁ + length l₂) - (sort/clocked/is-bounded k l₂ _) - λ (l₂' , l₂↭l₂' , sorted-l₂') → - Eq.subst - (IsBounded (sort-result l) $ - bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → - ret {sort-result l} (l' , ↭-trans l↭l₁++l₂ (↭-trans (_↭_.trans (++⁺ʳ-↭ l₂ l₁↭l₁') (++⁺ˡ-↭ l₁' l₂↭l₂')) (↭-trans l₁'++l₂'↭l _↭_.refl)) , l'-sorted) - ) - (let open ≡-Reasoning in - begin - length l₁' + length l₂' + 0 - ≡⟨ N.+-identityʳ (length l₁' + length l₂') ⟩ - length l₁' + length l₂' - ≡˘⟨ Eq.cong₂ _+_ (↭-length l₁↭l₁') (↭-length l₂↭l₂') ⟩ - length l₁ + length l₂ - ∎) $ - bound/bind/const {B = sort-result l} - {e = merge (l₁' , l₂') _} - {f = λ (l' , l₁'++l₂'↭l , l'-sorted) → - ret {sort-result l} (l' , ↭-trans l↭l₁++l₂ (↭-trans (_↭_.trans (++⁺ʳ-↭ l₂ l₁↭l₁') (++⁺ˡ-↭ l₁' l₂↭l₂')) (↭-trans l₁'++l₂'↭l _↭_.refl)) , l'-sorted)} - (length l₁' + length l₂') - 0 - (merge/is-bounded (l₁' , l₂') _) - λ _ → - ≤⁻-refl - - -sort : cmp (Π (list A) λ l → F (sort-result l)) -sort l = sort/clocked ⌈log₂ length l ⌉ l N.≤-refl - -sort/total : IsTotal sort -sort/total l = sort/clocked/total ⌈log₂ length l ⌉ l N.≤-refl - -sort/cost : cmp (Π (list A) λ _ → cost) -sort/cost l = sort/clocked/cost ⌈log₂ length l ⌉ l N.≤-refl - -sort/is-bounded : ∀ l → IsBoundedG (sort-result l) (sort l) (sort/cost l) -sort/is-bounded l = sort/clocked/is-bounded ⌈log₂ length l ⌉ l N.≤-refl - -sort/asymptotic : given (list A) measured-via length , sort ∈𝓞(λ n → n * ⌈log₂ n ⌉) -sort/asymptotic = f[n]≤g[n]via λ l → - Eq.subst - (IsBounded (sort-result l) (sort l)) - (N.*-comm ⌈log₂ length l ⌉ (length l)) - (sort/is-bounded l) + let open N.≤-Reasoning in + (begin + ⌈log₂ length l₁ ⌉ + ≡⟨ Eq.cong ⌈log₂_⌉ length₁ ⟩ + ⌈log₂ ⌊ length l /2⌋ ⌉ + ≤⟨ log₂-mono (N.⌊n/2⌋≤⌈n/2⌉ (length l)) ⟩ + ⌈log₂ ⌈ length l /2⌉ ⌉ + ≤⟨ log₂-suc (length l) h ⟩ + k + ∎) , + (begin + ⌈log₂ length l₂ ⌉ + ≡⟨ Eq.cong ⌈log₂_⌉ length₂ ⟩ + ⌈log₂ ⌈ length l /2⌉ ⌉ + ≤⟨ log₂-suc (length l) h ⟩ + k + ∎) + in + bind (F (sort-result l)) (sort/clocked k l₁ h₁) λ (l₁' , l₁↭l₁' , sorted-l₁') → + bind (F (sort-result l)) (sort/clocked k l₂ h₂) λ (l₂' , l₂↭l₂' , sorted-l₂') → + bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → + ret (l' , trans l↭l₁++l₂ (trans (++⁺-↭ l₁↭l₁' l₂↭l₂') l₁'++l₂'↭l) , l'-sorted) + +sort/clocked/total : ∀ k l h → IsValuable (sort/clocked k l h) +sort/clocked/total zero l h u = ↓ refl +sort/clocked/total (suc k) l h u rewrite Valuable.proof (split/total l u) = ↓ + let + ((l₁ , l₂) , length₁ , length₂ , l↭l₁++l₂) = Valuable.value (split/total l u) + h₁ , h₂ = + let open N.≤-Reasoning in + (begin + ⌈log₂ length l₁ ⌉ + ≡⟨ Eq.cong ⌈log₂_⌉ length₁ ⟩ + ⌈log₂ ⌊ length l /2⌋ ⌉ + ≤⟨ log₂-mono (N.⌊n/2⌋≤⌈n/2⌉ (length l)) ⟩ + ⌈log₂ ⌈ length l /2⌉ ⌉ + ≤⟨ log₂-suc (length l) h ⟩ + k + ∎) , + (begin + ⌈log₂ length l₂ ⌉ + ≡⟨ Eq.cong ⌈log₂_⌉ length₂ ⟩ + ⌈log₂ ⌈ length l /2⌉ ⌉ + ≤⟨ log₂-suc (length l) h ⟩ + k + ∎) + (l₁' , l₁↭l₁' , sorted-l₁') = Valuable.value (sort/clocked/total k l₁ h₁ u) + (l₂' , l₂↭l₂' , sorted-l₂') = Valuable.value (sort/clocked/total k l₂ h₂ u) + in + let open ≡-Reasoning in + begin + ( bind (F (sort-result l)) (sort/clocked k l₁ h₁) λ (l₁' , l₁↭l₁' , sorted-l₁') → + bind (F (sort-result l)) (sort/clocked k l₂ h₂) λ (l₂' , l₂↭l₂' , sorted-l₂') → + bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → + ret (l' , trans l↭l₁++l₂ (trans (++⁺-↭ l₁↭l₁' l₂↭l₂') l₁'++l₂'↭l) , l'-sorted) + ) + ≡⟨ + Eq.cong + (λ e → + bind (F (sort-result l)) e λ (l₁' , l₁↭l₁' , sorted-l₁') → + bind (F (sort-result l)) (sort/clocked k l₂ h₂) λ (l₂' , l₂↭l₂' , sorted-l₂') → + bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → + ret (l' , trans l↭l₁++l₂ (trans (++⁺-↭ l₁↭l₁' l₂↭l₂') l₁'++l₂'↭l) , l'-sorted) + ) + (Valuable.proof (sort/clocked/total k l₁ h₁ u)) + ⟩ + ( bind (F (sort-result l)) (sort/clocked k l₂ h₂) λ (l₂' , l₂↭l₂' , sorted-l₂') → + bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → + ret (l' , trans l↭l₁++l₂ (trans (++⁺-↭ l₁↭l₁' l₂↭l₂') l₁'++l₂'↭l) , l'-sorted) + ) + ≡⟨ + Eq.cong + (λ e → + bind (F (sort-result l)) e λ (l₂' , l₂↭l₂' , sorted-l₂') → + bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → + ret (l' , trans l↭l₁++l₂ (trans (++⁺-↭ l₁↭l₁' l₂↭l₂') l₁'++l₂'↭l) , l'-sorted) + ) + (Valuable.proof (sort/clocked/total k l₂ h₂ u)) + ⟩ + ( bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → + ret (l' , trans l↭l₁++l₂ (trans (++⁺-↭ l₁↭l₁' l₂↭l₂') l₁'++l₂'↭l) , l'-sorted) + ) + ≡⟨ + Eq.cong + (λ e → + bind (F (sort-result l)) e λ (l' , l₁'++l₂'↭l , l'-sorted) → + ret (l' , trans l↭l₁++l₂ (trans (++⁺-↭ l₁↭l₁' l₂↭l₂') l₁'++l₂'↭l) , l'-sorted) + ) + (Valuable.proof (merge/total (l₁' , l₂') (sorted-l₁' , sorted-l₂') u)) + ⟩ + ret _ + ∎ + +sort/clocked/cost : cmp $ Π nat λ k → Π (list A) λ l → Π (meta⁺ (⌈log₂ length l ⌉ Nat.≤ k)) λ _ → F unit +sort/clocked/cost k l _ = step⋆ (k * length l) + +sort/clocked/is-bounded : ∀ k l h → IsBoundedG (sort-result l) (sort/clocked k l h) (sort/clocked/cost k l h) +sort/clocked/is-bounded zero l h = ≤⁻-refl +sort/clocked/is-bounded (suc k) l h = + bound/bind/const + {e = split l} + {f = λ ((l₁ , l₂) , length₁ , length₂ , l↭l₁++l₂) → + bind (F (sort-result l)) (sort/clocked k l₁ _) λ (l₁' , l₁↭l₁' , sorted-l₁') → + bind (F (sort-result l)) (sort/clocked k l₂ _) λ (l₂' , l₂↭l₂' , sorted-l₂') → + bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → + ret {sort-result l} (l' , ↭-trans l↭l₁++l₂ (↭-trans (_↭_.trans (++⁺ʳ-↭ l₂ l₁↭l₁') (++⁺ˡ-↭ l₁' l₂↭l₂')) (↭-trans l₁'++l₂'↭l _↭_.refl)) , l'-sorted) + } + 0 + (suc k * length l) + (split/is-bounded l) + λ ((l₁ , l₂) , length₁ , length₂ , l↭l₁++l₂) → + Eq.subst + (IsBounded (sort-result l) $ + bind (F (sort-result l)) (sort/clocked k l₁ _) λ (l₁' , l₁↭l₁' , sorted-l₁') → + bind (F (sort-result l)) (sort/clocked k l₂ _) λ (l₂' , l₂↭l₂' , sorted-l₂') → + bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → + ret {sort-result l} (l' , ↭-trans l↭l₁++l₂ (↭-trans (_↭_.trans (++⁺ʳ-↭ l₂ l₁↭l₁') (++⁺ˡ-↭ l₁' l₂↭l₂')) (↭-trans l₁'++l₂'↭l _↭_.refl)) , l'-sorted) + ) + (let open ≡-Reasoning in + begin + k * length l₁ + (k * length l₂ + (length l₁ + length l₂)) + ≡˘⟨ N.+-assoc (k * length l₁) (k * length l₂) (length l₁ + length l₂) ⟩ + (k * length l₁ + k * length l₂) + (length l₁ + length l₂) + ≡˘⟨ Eq.cong (_+ (length l₁ + length l₂)) (N.*-distribˡ-+ k (length l₁) (length l₂)) ⟩ + k * (length l₁ + length l₂) + (length l₁ + length l₂) + ≡˘⟨ N.+-comm (length l₁ + length l₂) (k * (length l₁ + length l₂)) ⟩ + suc k * (length l₁ + length l₂) + ≡˘⟨ Eq.cong (suc k *_) (length-++ l₁) ⟩ + suc k * (length (l₁ ++ l₂)) + ≡˘⟨ Eq.cong (suc k *_) (↭-length l↭l₁++l₂) ⟩ + suc k * length l + ∎) $ + bound/bind/const + {e = sort/clocked k l₁ _} + {f = λ (l₁' , l₁↭l₁' , sorted-l₁') → + bind (F (sort-result l)) (sort/clocked k l₂ _) λ (l₂' , l₂↭l₂' , sorted-l₂') → + bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → + ret {sort-result l} (l' , ↭-trans l↭l₁++l₂ (↭-trans (_↭_.trans (++⁺ʳ-↭ l₂ l₁↭l₁') (++⁺ˡ-↭ l₁' l₂↭l₂')) (↭-trans l₁'++l₂'↭l _↭_.refl)) , l'-sorted) + } + (k * length l₁) + (k * length l₂ + (length l₁ + length l₂)) + (sort/clocked/is-bounded k l₁ _) + λ (l₁' , l₁↭l₁' , sorted-l₁') → + bound/bind/const + {e = sort/clocked k l₂ _} + {f = λ (l₂' , l₂↭l₂' , sorted-l₂') → + bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → + ret {sort-result l} (l' , ↭-trans l↭l₁++l₂ (↭-trans (_↭_.trans (++⁺ʳ-↭ l₂ l₁↭l₁') (++⁺ˡ-↭ l₁' l₂↭l₂')) (↭-trans l₁'++l₂'↭l _↭_.refl)) , l'-sorted) + } + (k * length l₂) + (length l₁ + length l₂) + (sort/clocked/is-bounded k l₂ _) + λ (l₂' , l₂↭l₂' , sorted-l₂') → + Eq.subst + (IsBounded (sort-result l) $ + bind (F (sort-result l)) (merge (l₁' , l₂') (sorted-l₁' , sorted-l₂')) λ (l' , l₁'++l₂'↭l , l'-sorted) → + ret {sort-result l} (l' , ↭-trans l↭l₁++l₂ (↭-trans (_↭_.trans (++⁺ʳ-↭ l₂ l₁↭l₁') (++⁺ˡ-↭ l₁' l₂↭l₂')) (↭-trans l₁'++l₂'↭l _↭_.refl)) , l'-sorted) + ) + (let open ≡-Reasoning in + begin + length l₁' + length l₂' + 0 + ≡⟨ N.+-identityʳ (length l₁' + length l₂') ⟩ + length l₁' + length l₂' + ≡˘⟨ Eq.cong₂ _+_ (↭-length l₁↭l₁') (↭-length l₂↭l₂') ⟩ + length l₁ + length l₂ + ∎) $ + bound/bind/const {B = sort-result l} + {e = merge (l₁' , l₂') _} + {f = λ (l' , l₁'++l₂'↭l , l'-sorted) → + ret {sort-result l} (l' , ↭-trans l↭l₁++l₂ (↭-trans (_↭_.trans (++⁺ʳ-↭ l₂ l₁↭l₁') (++⁺ˡ-↭ l₁' l₂↭l₂')) (↭-trans l₁'++l₂'↭l _↭_.refl)) , l'-sorted)} + (length l₁' + length l₂') + 0 + (merge/is-bounded (l₁' , l₂') _) + λ _ → + ≤⁻-refl + + +sort : cmp (Π (list A) λ l → F (sort-result l)) +sort l = sort/clocked ⌈log₂ length l ⌉ l N.≤-refl + +sort/total : IsTotal sort +sort/total l = sort/clocked/total ⌈log₂ length l ⌉ l N.≤-refl + +sort/cost : cmp (Π (list A) λ _ → cost) +sort/cost l = sort/clocked/cost ⌈log₂ length l ⌉ l N.≤-refl + +sort/is-bounded : ∀ l → IsBoundedG (sort-result l) (sort l) (sort/cost l) +sort/is-bounded l = sort/clocked/is-bounded ⌈log₂ length l ⌉ l N.≤-refl + +sort/asymptotic : given (list A) measured-via length , sort ∈𝓞(λ n → n * ⌈log₂ n ⌉) +sort/asymptotic = f[n]≤g[n]via λ l → + Eq.subst + (IsBounded (sort-result l) (sort l)) + (N.*-comm ⌈log₂ length l ⌉ (length l)) + (sort/is-bounded l) \ No newline at end of file diff --git a/Examples.Sorting.Sequential.html b/Examples.Sorting.Sequential.html index 52d473cb..73997a4d 100644 --- a/Examples.Sorting.Sequential.html +++ b/Examples.Sorting.Sequential.html @@ -29,10 +29,10 @@ ex/split = Sort.split (6 ∷ 2 ∷ 8 ∷ 3 ∷ 1 ∷ 8 ∷ 5 ∷ []) ex/merge = Sort.merge (2 ∷ 3 ∷ 6 ∷ 8 ∷ [] , 1 ∷ 5 ∷ 8 ∷ []) - ex/sort = Sort.sort (1 ∷ 5 ∷ 3 ∷ 1 ∷ 2 ∷ []) - ex/sort/forward = Sort.sort test/forward -- cost: 32 - ex/sort/backward = Sort.sort test/backward -- cost: 32 - ex/sort/shuffled = Sort.sort test/shuffled -- cost: 47 + ex/sort = Sort.sort (1 ∷ 5 ∷ 3 ∷ 1 ∷ 2 ∷ []) + ex/sort/forward = Sort.sort test/forward -- cost: 32 + ex/sort/backward = Sort.sort test/backward -- cost: 32 + ex/sort/shuffled = Sort.sort test/shuffled -- cost: 47 module SortEquivalence (M : Comparable) where open Comparable M @@ -41,6 +41,6 @@ import Examples.Sorting.Sequential.InsertionSort M as ISort import Examples.Sorting.Sequential.MergeSort M as MSort - isort≡msort : ◯ (ISort.sort algorithm ≡ MSort.sort algorithm) - isort≡msort = IsSort⇒≡ ISort.sort ISort.sort/total MSort.sort MSort.sort/total + isort≡msort : ◯ (ISort.sort algorithm ≡ MSort.sort algorithm) + isort≡msort = IsSort⇒≡ ISort.sort ISort.sort/total MSort.sort MSort.sort/total \ No newline at end of file diff --git a/Examples.TreeSum.html b/Examples.TreeSum.html index 3bd175a3..08b13cc7 100644 --- a/Examples.TreeSum.html +++ b/Examples.TreeSum.html @@ -6,15 +6,15 @@ open import Algebra.Cost parCostMonoid = ℕ²-ParCostMonoid -open ParCostMonoid parCostMonoid +open ParCostMonoid parCostMonoid -open import Calf costMonoid +open import Calf costMonoid open import Calf.Parallel parCostMonoid open import Calf.Data.Nat -open import Calf.Data.IsBounded costMonoid +open import Calf.Data.IsBounded costMonoid -open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; _≢_; module ≡-Reasoning) -open import Data.Nat as Nat using (_+_; _⊔_) +open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; _≢_; module ≡-Reasoning) +open import Data.Nat as Nat using (_+_; _⊔_) open import Data.Nat.Properties as N using () add : cmp (Π nat λ _ → Π nat λ _ → F nat) @@ -44,16 +44,16 @@ depth : val tree → val nat depth (leaf x) = 0 -depth (node t₁ t₂) = suc (depth t₁ ⊔ depth t₂) +depth (node t₁ t₂) = suc (depth t₁ ⊔ depth t₂) sum/bound : cmp (Π tree λ _ → F nat) sum/bound t = step (F nat) (size t , depth t) (ret (sum/spec t)) module _ where - open import Algebra.Definitions (_≡_ {A = ℂ}) + open import Algebra.Definitions (_≡_ {A = ℂ}) - ⊕-comm : Commutative _⊕_ - ⊕-comm (x₁ , x₂) (y₁ , y₂) = Eq.cong₂ _,_ (N.+-comm x₁ y₁) (N.+-comm x₂ y₂) + ⊕-comm : Commutative _⊕_ + ⊕-comm (x₁ , x₂) (y₁ , y₂) = Eq.cong₂ _,_ (N.+-comm x₁ y₁) (N.+-comm x₂ y₂) sum/has-cost : sum ≡ sum/bound sum/has-cost = funext aux @@ -61,18 +61,18 @@ aux : (t : val tree) → sum t ≡ sum/bound t aux (leaf x) = refl aux (node t₁ t₂) = - let open ≡-Reasoning in - begin + let open ≡-Reasoning in + begin bind (F nat) (sum t₁ ∥ sum t₂) (λ (n₁ , n₂) → add n₁ n₂) - ≡⟨ Eq.cong₂ (λ e₁ e₂ → bind (F nat) (e₁ ∥ e₂) (λ (n₁ , n₂) → add n₁ n₂)) (aux t₁) (aux t₂) ⟩ + ≡⟨ Eq.cong₂ (λ e₁ e₂ → bind (F nat) (e₁ ∥ e₂) (λ (n₁ , n₂) → add n₁ n₂)) (aux t₁) (aux t₂) ⟩ bind (F nat) (sum/bound t₁ ∥ sum/bound t₂) (λ (n₁ , n₂) → add n₁ n₂) - ≡⟨⟩ + ≡⟨⟩ step (F nat) - (((size t₁ , depth t₁) ⊗ (size t₂ , depth t₂)) ⊕ (1 , 1)) + (((size t₁ , depth t₁) ⊗ (size t₂ , depth t₂)) ⊕ (1 , 1)) (ret (sum/spec t₁ + sum/spec t₂)) - ≡⟨ Eq.cong (λ c → step (F nat) c (ret (sum/spec t₁ + sum/spec t₂))) (⊕-comm _ (1 , 1)) ⟩ + ≡⟨ Eq.cong (λ c → step (F nat) c (ret (sum/spec t₁ + sum/spec t₂))) (⊕-comm _ (1 , 1)) ⟩ sum/bound (node t₁ t₂) - ∎ + ∎ sum/is-bounded : sum ≤⁻[ (Π tree λ _ → F nat) ] sum/bound sum/is-bounded = ≤⁻-reflexive sum/has-cost diff --git a/Function.Base.html b/Function.Base.html index b1d9ab4d..b94ceedc 100644 --- a/Function.Base.html +++ b/Function.Base.html @@ -43,10 +43,10 @@ -- value of the input to the function. infixr 9 _∘_ _∘₂_ -infixl 8 _ˢ_ -infixl 0 _|>_ -infix 0 case_return_of_ -infixr -1 _$_ +infixl 8 _ˢ_ +infixl 0 _|>_ +infix 0 case_return_of_ +infixr -1 _$_ -- Composition @@ -73,186 +73,200 @@ -- Application - note that _$_ is right associative, as in Haskell. -- If you want a left associative infix application operator, use --- Category.Functor._<$>_ from Category.Monad.Identity.IdentityMonad. +-- RawFunctor._<$>_ from Effect.Functor. -_$_ : ∀ {A : Set a} {B : A → Set b} → - ((x : A) → B x) → ((x : A) → B x) -f $ x = f x -{-# INLINE _$_ #-} +_$_ : ∀ {A : Set a} {B : A → Set b} → + ((x : A) → B x) → ((x : A) → B x) +f $ x = f x +{-# INLINE _$_ #-} --- Flipped application (aka pipe-forward) +-- Flipped application (aka pipe-forward) -_|>_ : ∀ {A : Set a} {B : A → Set b} → - (a : A) → (∀ a → B a) → B a -_|>_ = flip _$_ -{-# INLINE _|>_ #-} +_|>_ : ∀ {A : Set a} {B : A → Set b} → + (a : A) → (∀ a → B a) → B a +_|>_ = flip _$_ +{-# INLINE _|>_ #-} --- The S combinator - written infix as in Conor McBride's paper --- "Outrageous but Meaningful Coincidences: Dependent type-safe syntax --- and evaluation". +-- The S combinator - written infix as in Conor McBride's paper +-- "Outrageous but Meaningful Coincidences: Dependent type-safe syntax +-- and evaluation". -_ˢ_ : ∀ {A : Set a} {B : A → Set b} {C : (x : A) → B x → Set c} → - ((x : A) (y : B x) → C x y) → - (g : (x : A) → B x) → - ((x : A) → C x (g x)) -f ˢ g = λ x → f x (g x) -{-# INLINE _ˢ_ #-} +_ˢ_ : ∀ {A : Set a} {B : A → Set b} {C : (x : A) → B x → Set c} → + ((x : A) (y : B x) → C x y) → + (g : (x : A) → B x) → + ((x : A) → C x (g x)) +f ˢ g = λ x → f x (g x) +{-# INLINE _ˢ_ #-} --- Converting between implicit and explicit function spaces. +-- Converting between implicit and explicit function spaces. -_$- : ∀ {A : Set a} {B : A → Set b} → ((x : A) → B x) → ({x : A} → B x) -f $- = f _ -{-# INLINE _$- #-} +_$- : ∀ {A : Set a} {B : A → Set b} → ((x : A) → B x) → ({x : A} → B x) +f $- = f _ +{-# INLINE _$- #-} -λ- : ∀ {A : Set a} {B : A → Set b} → ({x : A} → B x) → ((x : A) → B x) -λ- f = λ x → f -{-# INLINE λ- #-} +λ- : ∀ {A : Set a} {B : A → Set b} → ({x : A} → B x) → ((x : A) → B x) +λ- f = λ x → f +{-# INLINE λ- #-} --- Case expressions (to be used with pattern-matching lambdas, see --- README.Case). +-- Case expressions (to be used with pattern-matching lambdas, see +-- README.Case). -case_return_of_ : ∀ {A : Set a} (x : A) (B : A → Set b) → - ((x : A) → B x) → B x -case x return B of f = f x -{-# INLINE case_return_of_ #-} +case_returning_of_ : ∀ {A : Set a} (x : A) (B : A → Set b) → + ((x : A) → B x) → B x +case x returning B of f = f x +{-# INLINE case_returning_of_ #-} ------------------------------------------------------------------------- --- Non-dependent versions of dependent operations +------------------------------------------------------------------------ +-- Non-dependent versions of dependent operations --- Any of the above operations for dependent functions will also work --- for non-dependent functions but sometimes Agda has difficulty --- inferring the non-dependency. Primed (′ = \prime) versions of the --- operations are therefore provided below that sometimes have better --- inference properties. +-- Any of the above operations for dependent functions will also work +-- for non-dependent functions but sometimes Agda has difficulty +-- inferring the non-dependency. Primed (′ = \prime) versions of the +-- operations are therefore provided below that sometimes have better +-- inference properties. -infixr 9 _∘′_ _∘₂′_ -infixl 0 _|>′_ -infix 0 case_of_ -infixr -1 _$′_ +infixr 9 _∘′_ _∘₂′_ +infixl 0 _|>′_ +infix 0 case_of_ +infixr -1 _$′_ --- Composition +-- Composition -_∘′_ : (B → C) → (A → B) → (A → C) -f ∘′ g = _∘_ f g +_∘′_ : (B → C) → (A → B) → (A → C) +f ∘′ g = _∘_ f g -_∘₂′_ : (C → D) → (A → B → C) → (A → B → D) -f ∘₂′ g = _∘₂_ f g +_∘₂′_ : (C → D) → (A → B → C) → (A → B → D) +f ∘₂′ g = _∘₂_ f g --- Flipping order of arguments +-- Flipping order of arguments -flip′ : (A → B → C) → (B → A → C) -flip′ = flip +flip′ : (A → B → C) → (B → A → C) +flip′ = flip --- Application +-- Application -_$′_ : (A → B) → (A → B) -_$′_ = _$_ +_$′_ : (A → B) → (A → B) +_$′_ = _$_ --- Flipped application (aka pipe-forward) +-- Flipped application (aka pipe-forward) -_|>′_ : A → (A → B) → B -_|>′_ = _|>_ +_|>′_ : A → (A → B) → B +_|>′_ = _|>_ --- Case expressions (to be used with pattern-matching lambdas, see --- README.Case). +-- Case expressions (to be used with pattern-matching lambdas, see +-- README.Case). -case_of_ : A → (A → B) → B -case x of f = case x return _ of f -{-# INLINE case_of_ #-} +case_of_ : A → (A → B) → B +case x of f = case x returning _ of f +{-# INLINE case_of_ #-} ------------------------------------------------------------------------- --- Operations that are only defined for non-dependent functions +------------------------------------------------------------------------ +-- Operations that are only defined for non-dependent functions -infixl 1 _⟨_⟩_ -infixl 0 _∋_ +infixl 1 _⟨_⟩_ +infixl 0 _∋_ --- Binary application +-- Binary application -_⟨_⟩_ : A → (A → B → C) → B → C -x ⟨ f ⟩ y = f x y +_⟨_⟩_ : A → (A → B → C) → B → C +x ⟨ f ⟩ y = f x y --- In Agda you cannot annotate every subexpression with a type --- signature. This function can be used instead. +-- In Agda you cannot annotate every subexpression with a type +-- signature. This function can be used instead. -_∋_ : (A : Set a) → A → A -A ∋ x = x +_∋_ : (A : Set a) → A → A +A ∋ x = x --- Conversely it is sometimes useful to be able to extract the --- type of a given expression. +-- Conversely it is sometimes useful to be able to extract the +-- type of a given expression. -typeOf : {A : Set a} → A → Set a -typeOf {A = A} _ = A +typeOf : {A : Set a} → A → Set a +typeOf {A = A} _ = A --- Construct an element of the given type by instance search. +-- Construct an element of the given type by instance search. -it : {A : Set a} → {{A}} → A -it {{x}} = x +it : {A : Set a} → {{A}} → A +it {{x}} = x ------------------------------------------------------------------------- --- Composition of a binary function with other functions +------------------------------------------------------------------------ +-- Composition of a binary function with other functions -infixr 0 _-⟪_⟫-_ _-⟨_⟫-_ -infixl 0 _-⟪_⟩-_ -infixr 1 _-⟨_⟩-_ ∣_⟫-_ ∣_⟩-_ -infixl 1 _on_ _on₂_ _-⟪_∣ _-⟨_∣ +infixr 0 _-⟪_⟫-_ _-⟨_⟫-_ +infixl 0 _-⟪_⟩-_ +infixr 1 _-⟨_⟩-_ ∣_⟫-_ ∣_⟩-_ +infixl 1 _on_ _on₂_ _-⟪_∣ _-⟨_∣ --- Two binary functions +-- Two binary functions -_-⟪_⟫-_ : (A → B → C) → (C → D → E) → (A → B → D) → (A → B → E) -f -⟪ _*_ ⟫- g = λ x y → f x y * g x y +_-⟪_⟫-_ : (A → B → C) → (C → D → E) → (A → B → D) → (A → B → E) +f -⟪ _*_ ⟫- g = λ x y → f x y * g x y --- A single binary function on the left +-- A single binary function on the left -_-⟪_∣ : (A → B → C) → (C → B → D) → (A → B → D) -f -⟪ _*_ ∣ = f -⟪ _*_ ⟫- constᵣ +_-⟪_∣ : (A → B → C) → (C → B → D) → (A → B → D) +f -⟪ _*_ ∣ = f -⟪ _*_ ⟫- constᵣ --- A single binary function on the right +-- A single binary function on the right -∣_⟫-_ : (A → C → D) → (A → B → C) → (A → B → D) -∣ _*_ ⟫- g = const -⟪ _*_ ⟫- g +∣_⟫-_ : (A → C → D) → (A → B → C) → (A → B → D) +∣ _*_ ⟫- g = const -⟪ _*_ ⟫- g --- A single unary function on the left +-- A single unary function on the left -_-⟨_∣ : (A → C) → (C → B → D) → (A → B → D) -f -⟨ _*_ ∣ = f ∘₂ const -⟪ _*_ ∣ +_-⟨_∣ : (A → C) → (C → B → D) → (A → B → D) +f -⟨ _*_ ∣ = f ∘₂ const -⟪ _*_ ∣ --- A single unary function on the right +-- A single unary function on the right -∣_⟩-_ : (A → C → D) → (B → C) → (A → B → D) -∣ _*_ ⟩- g = ∣ _*_ ⟫- g ∘₂ constᵣ +∣_⟩-_ : (A → C → D) → (B → C) → (A → B → D) +∣ _*_ ⟩- g = ∣ _*_ ⟫- g ∘₂ constᵣ --- A binary function and a unary function +-- A binary function and a unary function -_-⟪_⟩-_ : (A → B → C) → (C → D → E) → (B → D) → (A → B → E) -f -⟪ _*_ ⟩- g = f -⟪ _*_ ⟫- ∣ constᵣ ⟩- g +_-⟪_⟩-_ : (A → B → C) → (C → D → E) → (B → D) → (A → B → E) +f -⟪ _*_ ⟩- g = f -⟪ _*_ ⟫- ∣ constᵣ ⟩- g --- A unary function and a binary function +-- A unary function and a binary function -_-⟨_⟫-_ : (A → C) → (C → D → E) → (A → B → D) → (A → B → E) -f -⟨ _*_ ⟫- g = f -⟨ const ∣ -⟪ _*_ ⟫- g +_-⟨_⟫-_ : (A → C) → (C → D → E) → (A → B → D) → (A → B → E) +f -⟨ _*_ ⟫- g = f -⟨ const ∣ -⟪ _*_ ⟫- g --- Two unary functions +-- Two unary functions -_-⟨_⟩-_ : (A → C) → (C → D → E) → (B → D) → (A → B → E) -f -⟨ _*_ ⟩- g = f -⟨ const ∣ -⟪ _*_ ⟫- ∣ constᵣ ⟩- g +_-⟨_⟩-_ : (A → C) → (C → D → E) → (B → D) → (A → B → E) +f -⟨ _*_ ⟩- g = f -⟨ const ∣ -⟪ _*_ ⟫- ∣ constᵣ ⟩- g --- A single binary function on both sides +-- A single binary function on both sides -_on₂_ : (C → C → D) → (A → B → C) → (A → B → D) -_*_ on₂ f = f -⟪ _*_ ⟫- f +_on₂_ : (C → C → D) → (A → B → C) → (A → B → D) +_*_ on₂ f = f -⟪ _*_ ⟫- f --- A single unary function on both sides +-- A single unary function on both sides -_on_ : (B → B → C) → (A → B) → (A → A → C) -_*_ on f = f -⟨ _*_ ⟩- f +_on_ : (B → B → C) → (A → B) → (A → A → C) +_*_ on f = f -⟨ _*_ ⟩- f ------------------------------------------------------------------------- --- Deprecated +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. -_-[_]-_ = _-⟪_⟫-_ -{-# WARNING_ON_USAGE _-[_]-_ -"Warning: Function._-[_]-_ was deprecated in v1.4. +-- Version 1.4 + +_-[_]-_ = _-⟪_⟫-_ +{-# WARNING_ON_USAGE _-[_]-_ +"Warning: Function._-[_]-_ was deprecated in v1.4. Please use _-⟪_⟫-_ instead." -#-} +#-} + +-- Version 2.0 + +case_return_of_ = case_returning_of_ +{-# WARNING_ON_USAGE case_return_of_ +"case_return_of_ was deprecated in v2.0. +Please use case_returning_of_ instead." +#-} + \ No newline at end of file diff --git a/Function.Bijection.html b/Function.Bijection.html deleted file mode 100644 index b1f4b787..00000000 --- a/Function.Bijection.html +++ /dev/null @@ -1,129 +0,0 @@ - -Function.Bijection
------------------------------------------------------------------------
--- The Agda standard library
---
--- Bijections
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
--- Note: use of the standard function hierarchy is encouraged. The
--- module `Function` re-exports `Bijective`, `IsBijection` and
--- `Bijection`. The alternative definitions found in this file will
--- eventually be deprecated.
-
-module Function.Bijection where
-
-open import Data.Product
-open import Level
-open import Relation.Binary
-open import Relation.Binary.PropositionalEquality as P
-open import Function.Equality as F
-  using (_⟶_; _⟨$⟩_) renaming (_∘_ to _⟪∘⟫_)
-open import Function.Injection   as Inj  hiding (id; _∘_; injection)
-open import Function.Surjection  as Surj hiding (id; _∘_; surjection)
-open import Function.LeftInverse as Left hiding (id; _∘_; leftInverse)
-
-------------------------------------------------------------------------
--- Bijective functions.
-
-record Bijective {f₁ f₂ t₁ t₂}
-                 {From : Setoid f₁ f₂} {To : Setoid t₁ t₂}
-                 (to : From ⟶ To) :
-                 Set (f₁ ⊔ f₂ ⊔ t₁ ⊔ t₂) where
-  field
-    injective  : Injective  to
-    surjective : Surjective to
-
-  open Surjective surjective public
-
-  left-inverse-of : from LeftInverseOf to
-  left-inverse-of x = injective (right-inverse-of (to ⟨$⟩ x))
-
-------------------------------------------------------------------------
--- The set of all bijections between two setoids.
-
-record Bijection {f₁ f₂ t₁ t₂}
-                 (From : Setoid f₁ f₂) (To : Setoid t₁ t₂) :
-                 Set (f₁ ⊔ f₂ ⊔ t₁ ⊔ t₂) where
-  field
-    to        : From ⟶ To
-    bijective : Bijective to
-
-  open Bijective bijective public
-
-  injection : Injection From To
-  injection = record
-    { to        = to
-    ; injective = injective
-    }
-
-  surjection : Surjection From To
-  surjection = record
-    { to         = to
-    ; surjective = surjective
-    }
-
-  open Surjection surjection public
-    using (equivalence; right-inverse; from-to)
-
-  left-inverse : LeftInverse From To
-  left-inverse = record
-    { to              = to
-    ; from            = from
-    ; left-inverse-of = left-inverse-of
-    }
-
-  open LeftInverse left-inverse public using (to-from)
-
-------------------------------------------------------------------------
--- The set of all bijections between two sets (i.e. bijections with
--- propositional equality)
-
-infix 3 _⤖_
-
-_⤖_ : ∀ {f t} → Set f → Set t → Set _
-From ⤖ To = Bijection (P.setoid From) (P.setoid To)
-
-bijection : ∀ {f t} {From : Set f} {To : Set t} →
-            (to : From → To) (from : To → From) →
-            (∀ {x y} → to x ≡ to y → x ≡ y) →
-            (∀ x → to (from x) ≡ x) →
-            From ⤖ To
-bijection to from inj invʳ = record
-  { to        = P.→-to-⟶ to
-  ; bijective = record
-    { injective  = inj
-    ; surjective = record
-      { from             = P.→-to-⟶ from
-      ; right-inverse-of = invʳ
-      }
-    }
-  }
-
-------------------------------------------------------------------------
--- Identity and composition. (Note that these proofs are superfluous,
--- given that Bijection is equivalent to Function.Inverse.Inverse.)
-
-id : ∀ {s₁ s₂} {S : Setoid s₁ s₂} → Bijection S S
-id {S = S} = record
-  { to        = F.id
-  ; bijective = record
-    { injective  =  Injection.injective   (Inj.id {S = S})
-    ; surjective = Surjection.surjective (Surj.id {S = S})
-    }
-  }
-
-infixr 9 _∘_
-
-_∘_ : ∀ {f₁ f₂ m₁ m₂ t₁ t₂}
-        {F : Setoid f₁ f₂} {M : Setoid m₁ m₂} {T : Setoid t₁ t₂} →
-      Bijection M T → Bijection F M → Bijection F T
-f ∘ g = record
-  { to        = to f ⟪∘⟫ to g
-  ; bijective = record
-    { injective  =  Injection.injective   (Inj._∘_  (injection f)  (injection g))
-    ; surjective = Surjection.surjective (Surj._∘_ (surjection f) (surjection g))
-    }
-  } where open Bijection
-
\ No newline at end of file diff --git a/Function.Bundles.html b/Function.Bundles.html index 3d1dd430..f3c62137 100644 --- a/Function.Bundles.html +++ b/Function.Bundles.html @@ -21,409 +21,522 @@ module Function.Bundles where open import Function.Base using (_∘_) -import Function.Definitions as FunctionDefinitions -import Function.Structures as FunctionStructures -open import Level using (Level; _⊔_; suc) -open import Data.Product using (_,_; proj₁; proj₂) -open import Relation.Binary hiding (_⇔_) -open import Relation.Binary.PropositionalEquality.Core as ≡ - using (_≡_) -import Relation.Binary.PropositionalEquality.Properties as ≡ -open Setoid using (isEquivalence) - -private - variable - a b ℓ₁ ℓ₂ : Level - ------------------------------------------------------------------------- --- Setoid bundles ------------------------------------------------------------------------- - -module _ (From : Setoid a ℓ₁) (To : Setoid b ℓ₂) where - - open Setoid From using () renaming (Carrier to A; _≈_ to _≈₁_) - open Setoid To using () renaming (Carrier to B; _≈_ to _≈₂_) - open FunctionDefinitions _≈₁_ _≈₂_ - open FunctionStructures _≈₁_ _≈₂_ - ------------------------------------------------------------------------- --- Bundles with one element - - -- Called `Func` rather than `Function` in order to avoid clashing - -- with the top-level module. - record Func : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - to : A → B - cong : to Preserves _≈₁_ ⟶ _≈₂_ - - isCongruent : IsCongruent to - isCongruent = record - { cong = cong - ; isEquivalence₁ = isEquivalence From - ; isEquivalence₂ = isEquivalence To - } - - open IsCongruent isCongruent public - using (module Eq₁; module Eq₂) - - - record Injection : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - to : A → B - cong : to Preserves _≈₁_ ⟶ _≈₂_ - injective : Injective to - - function : Func - function = record - { to = to - ; cong = cong - } - - open Func function public - hiding (to; cong) - - isInjection : IsInjection to - isInjection = record - { isCongruent = isCongruent - ; injective = injective - } - - - record Surjection : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - to : A → B - cong : to Preserves _≈₁_ ⟶ _≈₂_ - surjective : Surjective to - - to⁻ : B → A - to⁻ = proj₁ ∘ surjective - - isCongruent : IsCongruent to - isCongruent = record - { cong = cong - ; isEquivalence₁ = isEquivalence From - ; isEquivalence₂ = isEquivalence To - } - - open IsCongruent isCongruent public using (module Eq₁; module Eq₂) - - isSurjection : IsSurjection to - isSurjection = record - { isCongruent = isCongruent - ; surjective = surjective - } - - - record Bijection : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - to : A → B - cong : to Preserves _≈₁_ ⟶ _≈₂_ - bijective : Bijective to - - injective : Injective to - injective = proj₁ bijective - - surjective : Surjective to - surjective = proj₂ bijective - - injection : Injection - injection = record - { cong = cong - ; injective = injective - } - - surjection : Surjection - surjection = record - { cong = cong - ; surjective = surjective - } - - open Injection injection public using (isInjection) - open Surjection surjection public using (isSurjection; to⁻) - - isBijection : IsBijection to - isBijection = record - { isInjection = isInjection - ; surjective = surjective - } - - open IsBijection isBijection public using (module Eq₁; module Eq₂) - - ------------------------------------------------------------------------- --- Bundles with two elements - - record Equivalence : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - to : A → B - from : B → A - to-cong : to Preserves _≈₁_ ⟶ _≈₂_ - from-cong : from Preserves _≈₂_ ⟶ _≈₁_ - - - record LeftInverse : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - to : A → B - from : B → A - to-cong : to Preserves _≈₁_ ⟶ _≈₂_ - from-cong : from Preserves _≈₂_ ⟶ _≈₁_ - inverseˡ : Inverseˡ to from - - isCongruent : IsCongruent to - isCongruent = record - { cong = to-cong - ; isEquivalence₁ = isEquivalence From - ; isEquivalence₂ = isEquivalence To - } - - open IsCongruent isCongruent public using (module Eq₁; module Eq₂) - - isLeftInverse : IsLeftInverse to from - isLeftInverse = record - { isCongruent = isCongruent - ; from-cong = from-cong - ; inverseˡ = inverseˡ - } - - equivalence : Equivalence - equivalence = record - { to-cong = to-cong - ; from-cong = from-cong - } - - - record RightInverse : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - to : A → B - from : B → A - to-cong : to Preserves _≈₁_ ⟶ _≈₂_ - from-cong : from Preserves _≈₂_ ⟶ _≈₁_ - inverseʳ : Inverseʳ to from - - isCongruent : IsCongruent to - isCongruent = record - { cong = to-cong - ; isEquivalence₁ = isEquivalence From - ; isEquivalence₂ = isEquivalence To - } - - isRightInverse : IsRightInverse to from - isRightInverse = record - { isCongruent = isCongruent - ; from-cong = from-cong - ; inverseʳ = inverseʳ - } - - equivalence : Equivalence - equivalence = record - { to-cong = to-cong - ; from-cong = from-cong - } - - - record Inverse : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - to : A → B - from : B → A - to-cong : to Preserves _≈₁_ ⟶ _≈₂_ - from-cong : from Preserves _≈₂_ ⟶ _≈₁_ - inverse : Inverseᵇ to from - - inverseˡ : Inverseˡ to from - inverseˡ = proj₁ inverse - - inverseʳ : Inverseʳ to from - inverseʳ = proj₂ inverse - - leftInverse : LeftInverse - leftInverse = record - { to-cong = to-cong - ; from-cong = from-cong - ; inverseˡ = inverseˡ - } - - rightInverse : RightInverse - rightInverse = record - { to-cong = to-cong - ; from-cong = from-cong - ; inverseʳ = inverseʳ - } - - open LeftInverse leftInverse public using (isLeftInverse) - open RightInverse rightInverse public using (isRightInverse) - - isInverse : IsInverse to from - isInverse = record - { isLeftInverse = isLeftInverse - ; inverseʳ = inverseʳ - } - - open IsInverse isInverse public using (module Eq₁; module Eq₂) - - ------------------------------------------------------------------------- --- Bundles with three elements - - record BiEquivalence : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - to : A → B - from₁ : B → A - from₂ : B → A - to-cong : to Preserves _≈₁_ ⟶ _≈₂_ - from₁-cong : from₁ Preserves _≈₂_ ⟶ _≈₁_ - from₂-cong : from₂ Preserves _≈₂_ ⟶ _≈₁_ - - - record BiInverse : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - to : A → B - from₁ : B → A - from₂ : B → A - to-cong : to Preserves _≈₁_ ⟶ _≈₂_ - from₁-cong : from₁ Preserves _≈₂_ ⟶ _≈₁_ - from₂-cong : from₂ Preserves _≈₂_ ⟶ _≈₁_ - inverseˡ : Inverseˡ to from₁ - inverseʳ : Inverseʳ to from₂ - - to-isCongruent : IsCongruent to - to-isCongruent = record - { cong = to-cong - ; isEquivalence₁ = isEquivalence From - ; isEquivalence₂ = isEquivalence To - } - - isBiInverse : IsBiInverse to from₁ from₂ - isBiInverse = record - { to-isCongruent = to-isCongruent - ; from₁-cong = from₁-cong - ; from₂-cong = from₂-cong - ; inverseˡ = inverseˡ - ; inverseʳ = inverseʳ - } - - biEquivalence : BiEquivalence - biEquivalence = record - { to-cong = to-cong - ; from₁-cong = from₁-cong - ; from₂-cong = from₂-cong - } - - ------------------------------------------------------------------------- --- Bundles specialised for propositional equality ------------------------------------------------------------------------- - -infix 3 _⟶_ _↣_ _↠_ _⤖_ _⇔_ _↩_ _↪_ _↩↪_ _↔_ -_⟶_ : Set a → Set b → Set _ -A ⟶ B = Func (≡.setoid A) (≡.setoid B) - -_↣_ : Set a → Set b → Set _ -A ↣ B = Injection (≡.setoid A) (≡.setoid B) - -_↠_ : Set a → Set b → Set _ -A ↠ B = Surjection (≡.setoid A) (≡.setoid B) - -_⤖_ : Set a → Set b → Set _ -A ⤖ B = Bijection (≡.setoid A) (≡.setoid B) - -_⇔_ : Set a → Set b → Set _ -A ⇔ B = Equivalence (≡.setoid A) (≡.setoid B) - -_↩_ : Set a → Set b → Set _ -A ↩ B = LeftInverse (≡.setoid A) (≡.setoid B) - -_↪_ : Set a → Set b → Set _ -A ↪ B = RightInverse (≡.setoid A) (≡.setoid B) - -_↩↪_ : Set a → Set b → Set _ -A ↩↪ B = BiInverse (≡.setoid A) (≡.setoid B) - -_↔_ : Set a → Set b → Set _ -A ↔ B = Inverse (≡.setoid A) (≡.setoid B) - --- We now define some constructors for the above that --- automatically provide the required congruency proofs. - -module _ {A : Set a} {B : Set b} where - - open FunctionDefinitions {A = A} {B} _≡_ _≡_ - - mk⟶ : (A → B) → A ⟶ B - mk⟶ to = record - { to = to - ; cong = ≡.cong to - } - - mk↣ : ∀ {to : A → B} → Injective to → A ↣ B - mk↣ {to} inj = record - { to = to - ; cong = ≡.cong to - ; injective = inj - } - - mk↠ : ∀ {to : A → B} → Surjective to → A ↠ B - mk↠ {to} surj = record - { to = to - ; cong = ≡.cong to - ; surjective = surj - } - - mk⤖ : ∀ {to : A → B} → Bijective to → A ⤖ B - mk⤖ {to} bij = record - { to = to - ; cong = ≡.cong to - ; bijective = bij - } - - mk⇔ : ∀ (to : A → B) (from : B → A) → A ⇔ B - mk⇔ to from = record - { to = to - ; from = from - ; to-cong = ≡.cong to - ; from-cong = ≡.cong from - } - - mk↩ : ∀ {to : A → B} {from : B → A} → Inverseˡ to from → A ↩ B - mk↩ {to} {from} invˡ = record - { to = to - ; from = from - ; to-cong = ≡.cong to - ; from-cong = ≡.cong from - ; inverseˡ = invˡ - } - - mk↪ : ∀ {to : A → B} {from : B → A} → Inverseʳ to from → A ↪ B - mk↪ {to} {from} invʳ = record - { to = to - ; from = from - ; to-cong = ≡.cong to - ; from-cong = ≡.cong from - ; inverseʳ = invʳ - } - - mk↩↪ : ∀ {to : A → B} {from₁ : B → A} {from₂ : B → A} → - Inverseˡ to from₁ → Inverseʳ to from₂ → A ↩↪ B - mk↩↪ {to} {from₁} {from₂} invˡ invʳ = record - { to = to - ; from₁ = from₁ - ; from₂ = from₂ - ; to-cong = ≡.cong to - ; from₁-cong = ≡.cong from₁ - ; from₂-cong = ≡.cong from₂ - ; inverseˡ = invˡ - ; inverseʳ = invʳ - } - - mk↔ : ∀ {to : A → B} {from : B → A} → Inverseᵇ to from → A ↔ B - mk↔ {to} {from} inv = record - { to = to - ; from = from - ; to-cong = ≡.cong to - ; from-cong = ≡.cong from - ; inverse = inv - } - - -- Sometimes the implicit arguments above cannot be inferred - mk↔′ : ∀ (to : A → B) (from : B → A) → Inverseˡ to from → Inverseʳ to from → A ↔ B - mk↔′ to from invˡ invʳ = mk↔ {to = to} {from = from} (invˡ , invʳ) +open import Function.Definitions +import Function.Structures as FunctionStructures +open import Level using (Level; _⊔_; suc) +open import Data.Product.Base using (_,_; proj₁; proj₂) +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Binary.Core using (_Preserves_⟶_) +open import Relation.Binary.PropositionalEquality.Core as ≡ + using (_≡_) +import Relation.Binary.PropositionalEquality.Properties as ≡ +open import Function.Consequences.Propositional +open Setoid using (isEquivalence) + +private + variable + a b ℓ₁ ℓ₂ : Level + +------------------------------------------------------------------------ +-- Setoid bundles +------------------------------------------------------------------------ + +module _ (From : Setoid a ℓ₁) (To : Setoid b ℓ₂) where + + open Setoid From using () renaming (Carrier to A; _≈_ to _≈₁_) + open Setoid To using () renaming (Carrier to B; _≈_ to _≈₂_) + open FunctionStructures _≈₁_ _≈₂_ + +------------------------------------------------------------------------ +-- Bundles with one element + + -- Called `Func` rather than `Function` in order to avoid clashing + -- with the top-level module. + record Func : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + to : A → B + cong : Congruent _≈₁_ _≈₂_ to + + isCongruent : IsCongruent to + isCongruent = record + { cong = cong + ; isEquivalence₁ = isEquivalence From + ; isEquivalence₂ = isEquivalence To + } + + open IsCongruent isCongruent public + using (module Eq₁; module Eq₂) + + + record Injection : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + to : A → B + cong : Congruent _≈₁_ _≈₂_ to + injective : Injective _≈₁_ _≈₂_ to + + function : Func + function = record + { to = to + ; cong = cong + } + + open Func function public + hiding (to; cong) + + isInjection : IsInjection to + isInjection = record + { isCongruent = isCongruent + ; injective = injective + } + + + record Surjection : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + to : A → B + cong : Congruent _≈₁_ _≈₂_ to + surjective : Surjective _≈₁_ _≈₂_ to + + function : Func + function = record + { to = to + ; cong = cong + } + + open Func function public + hiding (to; cong) + + isSurjection : IsSurjection to + isSurjection = record + { isCongruent = isCongruent + ; surjective = surjective + } + + open IsSurjection isSurjection public + using + ( strictlySurjective + ) + + to⁻ : B → A + to⁻ = proj₁ ∘ surjective + + to∘to⁻ : ∀ x → to (to⁻ x) ≈₂ x + to∘to⁻ = proj₂ ∘ strictlySurjective + + + record Bijection : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + to : A → B + cong : Congruent _≈₁_ _≈₂_ to + bijective : Bijective _≈₁_ _≈₂_ to + + injective : Injective _≈₁_ _≈₂_ to + injective = proj₁ bijective + + surjective : Surjective _≈₁_ _≈₂_ to + surjective = proj₂ bijective + + injection : Injection + injection = record + { cong = cong + ; injective = injective + } + + surjection : Surjection + surjection = record + { cong = cong + ; surjective = surjective + } + + open Injection injection public using (isInjection) + open Surjection surjection public using (isSurjection; to⁻; strictlySurjective) + + isBijection : IsBijection to + isBijection = record + { isInjection = isInjection + ; surjective = surjective + } + + open IsBijection isBijection public using (module Eq₁; module Eq₂) + + +------------------------------------------------------------------------ +-- Bundles with two elements + +module _ (From : Setoid a ℓ₁) (To : Setoid b ℓ₂) where + + open Setoid From using () renaming (Carrier to A; _≈_ to _≈₁_) + open Setoid To using () renaming (Carrier to B; _≈_ to _≈₂_) + open FunctionStructures _≈₁_ _≈₂_ + + record Equivalence : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + to : A → B + from : B → A + to-cong : Congruent _≈₁_ _≈₂_ to + from-cong : Congruent _≈₂_ _≈₁_ from + + toFunction : Func From To + toFunction = record + { to = to + ; cong = to-cong + } + + open Func toFunction public + using (module Eq₁; module Eq₂) + renaming (isCongruent to to-isCongruent) + + fromFunction : Func To From + fromFunction = record + { to = from + ; cong = from-cong + } + + open Func fromFunction public + using () + renaming (isCongruent to from-isCongruent) + + + record LeftInverse : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + to : A → B + from : B → A + to-cong : Congruent _≈₁_ _≈₂_ to + from-cong : Congruent _≈₂_ _≈₁_ from + inverseˡ : Inverseˡ _≈₁_ _≈₂_ to from + + isCongruent : IsCongruent to + isCongruent = record + { cong = to-cong + ; isEquivalence₁ = isEquivalence From + ; isEquivalence₂ = isEquivalence To + } + + isLeftInverse : IsLeftInverse to from + isLeftInverse = record + { isCongruent = isCongruent + ; from-cong = from-cong + ; inverseˡ = inverseˡ + } + + open IsLeftInverse isLeftInverse public + using (module Eq₁; module Eq₂; strictlyInverseˡ; isSurjection) + + equivalence : Equivalence + equivalence = record + { to-cong = to-cong + ; from-cong = from-cong + } + + isSplitSurjection : IsSplitSurjection to + isSplitSurjection = record + { from = from + ; isLeftInverse = isLeftInverse + } + + surjection : Surjection From To + surjection = record + { to = to + ; cong = to-cong + ; surjective = λ y → from y , inverseˡ + } + + + + record RightInverse : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + to : A → B + from : B → A + to-cong : Congruent _≈₁_ _≈₂_ to + from-cong : from Preserves _≈₂_ ⟶ _≈₁_ + inverseʳ : Inverseʳ _≈₁_ _≈₂_ to from + + isCongruent : IsCongruent to + isCongruent = record + { cong = to-cong + ; isEquivalence₁ = isEquivalence From + ; isEquivalence₂ = isEquivalence To + } + + isRightInverse : IsRightInverse to from + isRightInverse = record + { isCongruent = isCongruent + ; from-cong = from-cong + ; inverseʳ = inverseʳ + } + + open IsRightInverse isRightInverse public + using (module Eq₁; module Eq₂; strictlyInverseʳ) + + equivalence : Equivalence + equivalence = record + { to-cong = to-cong + ; from-cong = from-cong + } + + + record Inverse : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + to : A → B + from : B → A + to-cong : Congruent _≈₁_ _≈₂_ to + from-cong : Congruent _≈₂_ _≈₁_ from + inverse : Inverseᵇ _≈₁_ _≈₂_ to from + + inverseˡ : Inverseˡ _≈₁_ _≈₂_ to from + inverseˡ = proj₁ inverse + + inverseʳ : Inverseʳ _≈₁_ _≈₂_ to from + inverseʳ = proj₂ inverse + + leftInverse : LeftInverse + leftInverse = record + { to-cong = to-cong + ; from-cong = from-cong + ; inverseˡ = inverseˡ + } + + rightInverse : RightInverse + rightInverse = record + { to-cong = to-cong + ; from-cong = from-cong + ; inverseʳ = inverseʳ + } + + open LeftInverse leftInverse public using (isLeftInverse; strictlyInverseˡ) + open RightInverse rightInverse public using (isRightInverse; strictlyInverseʳ) + + isInverse : IsInverse to from + isInverse = record + { isLeftInverse = isLeftInverse + ; inverseʳ = inverseʳ + } + + open IsInverse isInverse public using (module Eq₁; module Eq₂) + + +------------------------------------------------------------------------ +-- Bundles with three elements + + record BiEquivalence : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + to : A → B + from₁ : B → A + from₂ : B → A + to-cong : Congruent _≈₁_ _≈₂_ to + from₁-cong : Congruent _≈₂_ _≈₁_ from₁ + from₂-cong : Congruent _≈₂_ _≈₁_ from₂ + + + record BiInverse : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + to : A → B + from₁ : B → A + from₂ : B → A + to-cong : Congruent _≈₁_ _≈₂_ to + from₁-cong : Congruent _≈₂_ _≈₁_ from₁ + from₂-cong : Congruent _≈₂_ _≈₁_ from₂ + inverseˡ : Inverseˡ _≈₁_ _≈₂_ to from₁ + inverseʳ : Inverseʳ _≈₁_ _≈₂_ to from₂ + + to-isCongruent : IsCongruent to + to-isCongruent = record + { cong = to-cong + ; isEquivalence₁ = isEquivalence From + ; isEquivalence₂ = isEquivalence To + } + + isBiInverse : IsBiInverse to from₁ from₂ + isBiInverse = record + { to-isCongruent = to-isCongruent + ; from₁-cong = from₁-cong + ; from₂-cong = from₂-cong + ; inverseˡ = inverseˡ + ; inverseʳ = inverseʳ + } + + biEquivalence : BiEquivalence + biEquivalence = record + { to-cong = to-cong + ; from₁-cong = from₁-cong + ; from₂-cong = from₂-cong + } + +------------------------------------------------------------------------ +-- Other + + -- A left inverse is also known as a “split surjection”. + -- + -- As the name implies, a split surjection is a special kind of + -- surjection where the witness generated in the domain in the + -- function for elements `x₁` and `x₂` are equal if `x₁ ≈ x₂` . + -- + -- The difference is the `from-cong` law --- generally, the section + -- (called `Surjection.to⁻` or `SplitSurjection.from`) of a surjection + -- need not respect equality, whereas it must in a split surjection. + -- + -- The two notions coincide when the equivalence relation on `B` is + -- propositional equality (because all functions respect propositional + -- equality). + -- + -- For further background on (split) surjections, one may consult any + -- general mathematical references which work without the principle + -- of choice. For example: + -- + -- https://ncatlab.org/nlab/show/split+epimorphism. + -- + -- The connection to set-theoretic notions with the same names is + -- justified by the setoid type theory/homotopy type theory + -- observation/definition that (∃x : A. P) = ∥ Σx : A. P ∥ --- i.e., + -- we can read set-theoretic ∃ as squashed/propositionally truncated Σ. + -- + -- We see working with setoids as working in the MLTT model of a setoid + -- type theory, in which ∥ X ∥ is interpreted as the setoid with carrier + -- set X and the equivalence relation that relates all elements. + -- All maps into ∥ X ∥ respect equality, so in the idiomatic definitions + -- here, we drop the corresponding trivial `cong` field completely. + + SplitSurjection : Set _ + SplitSurjection = LeftInverse + + module SplitSurjection (splitSurjection : SplitSurjection) = + LeftInverse splitSurjection + +------------------------------------------------------------------------ +-- Bundles specialised for propositional equality +------------------------------------------------------------------------ + +infix 3 _⟶_ _↣_ _↠_ _⤖_ _⇔_ _↩_ _↪_ _↩↪_ _↔_ +_⟶_ : Set a → Set b → Set _ +A ⟶ B = Func (≡.setoid A) (≡.setoid B) + +_↣_ : Set a → Set b → Set _ +A ↣ B = Injection (≡.setoid A) (≡.setoid B) + +_↠_ : Set a → Set b → Set _ +A ↠ B = Surjection (≡.setoid A) (≡.setoid B) + +_⤖_ : Set a → Set b → Set _ +A ⤖ B = Bijection (≡.setoid A) (≡.setoid B) + +_⇔_ : Set a → Set b → Set _ +A ⇔ B = Equivalence (≡.setoid A) (≡.setoid B) + +_↩_ : Set a → Set b → Set _ +A ↩ B = LeftInverse (≡.setoid A) (≡.setoid B) + +_↪_ : Set a → Set b → Set _ +A ↪ B = RightInverse (≡.setoid A) (≡.setoid B) + +_↩↪_ : Set a → Set b → Set _ +A ↩↪ B = BiInverse (≡.setoid A) (≡.setoid B) + +_↔_ : Set a → Set b → Set _ +A ↔ B = Inverse (≡.setoid A) (≡.setoid B) + +-- We now define some constructors for the above that +-- automatically provide the required congruency proofs. + +module _ {A : Set a} {B : Set b} where + + mk⟶ : (A → B) → A ⟶ B + mk⟶ to = record + { to = to + ; cong = ≡.cong to + } + + mk↣ : ∀ {to : A → B} → Injective _≡_ _≡_ to → A ↣ B + mk↣ {to} inj = record + { to = to + ; cong = ≡.cong to + ; injective = inj + } + + mk↠ : ∀ {to : A → B} → Surjective _≡_ _≡_ to → A ↠ B + mk↠ {to} surj = record + { to = to + ; cong = ≡.cong to + ; surjective = surj + } + + mk⤖ : ∀ {to : A → B} → Bijective _≡_ _≡_ to → A ⤖ B + mk⤖ {to} bij = record + { to = to + ; cong = ≡.cong to + ; bijective = bij + } + + mk⇔ : ∀ (to : A → B) (from : B → A) → A ⇔ B + mk⇔ to from = record + { to = to + ; from = from + ; to-cong = ≡.cong to + ; from-cong = ≡.cong from + } + + mk↩ : ∀ {to : A → B} {from : B → A} → Inverseˡ _≡_ _≡_ to from → A ↩ B + mk↩ {to} {from} invˡ = record + { to = to + ; from = from + ; to-cong = ≡.cong to + ; from-cong = ≡.cong from + ; inverseˡ = invˡ + } + + mk↪ : ∀ {to : A → B} {from : B → A} → Inverseʳ _≡_ _≡_ to from → A ↪ B + mk↪ {to} {from} invʳ = record + { to = to + ; from = from + ; to-cong = ≡.cong to + ; from-cong = ≡.cong from + ; inverseʳ = invʳ + } + + mk↩↪ : ∀ {to : A → B} {from₁ : B → A} {from₂ : B → A} → + Inverseˡ _≡_ _≡_ to from₁ → Inverseʳ _≡_ _≡_ to from₂ → A ↩↪ B + mk↩↪ {to} {from₁} {from₂} invˡ invʳ = record + { to = to + ; from₁ = from₁ + ; from₂ = from₂ + ; to-cong = ≡.cong to + ; from₁-cong = ≡.cong from₁ + ; from₂-cong = ≡.cong from₂ + ; inverseˡ = invˡ + ; inverseʳ = invʳ + } + + mk↔ : ∀ {to : A → B} {from : B → A} → Inverseᵇ _≡_ _≡_ to from → A ↔ B + mk↔ {to} {from} inv = record + { to = to + ; from = from + ; to-cong = ≡.cong to + ; from-cong = ≡.cong from + ; inverse = inv + } + + + -- Strict variant of the above. + mk↠ₛ : ∀ {to : A → B} → StrictlySurjective _≡_ to → A ↠ B + mk↠ₛ = mk↠ ∘ strictlySurjective⇒surjective + + mk↔ₛ′ : ∀ (to : A → B) (from : B → A) → + StrictlyInverseˡ _≡_ to from → + StrictlyInverseʳ _≡_ to from → + A ↔ B + mk↔ₛ′ to from invˡ invʳ = mk↔ {to} {from} + ( strictlyInverseˡ⇒inverseˡ to invˡ + , strictlyInverseʳ⇒inverseʳ to invʳ + ) + +------------------------------------------------------------------------ +-- Other +------------------------------------------------------------------------ + +-- Alternative syntax for the application of functions + +module _ {From : Setoid a ℓ₁} {To : Setoid b ℓ₂} where + open Setoid + + infixl 5 _⟨$⟩_ + _⟨$⟩_ : Func From To → Carrier From → Carrier To + _⟨$⟩_ = Func.to \ No newline at end of file diff --git a/Function.Consequences.Propositional.html b/Function.Consequences.Propositional.html new file mode 100644 index 00000000..32703a4e --- /dev/null +++ b/Function.Consequences.Propositional.html @@ -0,0 +1,55 @@ + +Function.Consequences.Propositional
------------------------------------------------------------------------
+-- The Agda standard library
+--
+-- Relationships between properties of functions where the equality
+-- over both the domain and codomain is assumed to be _≡_
+------------------------------------------------------------------------
+
+{-# OPTIONS --cubical-compatible --safe #-}
+
+module Function.Consequences.Propositional
+  {a b} {A : Set a} {B : Set b}
+  where
+
+open import Relation.Binary.PropositionalEquality.Core using (_≡_; _≢_; cong)
+open import Relation.Binary.PropositionalEquality.Properties
+  using (setoid)
+open import Function.Definitions
+open import Relation.Nullary.Negation.Core using (contraposition)
+
+import Function.Consequences.Setoid (setoid A) (setoid B) as Setoid
+
+------------------------------------------------------------------------
+-- Re-export setoid properties
+
+open Setoid public
+  hiding
+  ( strictlySurjective⇒surjective
+  ; strictlyInverseˡ⇒inverseˡ
+  ; strictlyInverseʳ⇒inverseʳ
+  )
+
+------------------------------------------------------------------------
+-- Properties that rely on congruence
+
+private
+  variable
+    f : A → B
+    f⁻¹ : B → A
+
+strictlySurjective⇒surjective : StrictlySurjective _≡_ f →
+                                 Surjective _≡_ _≡_ f
+strictlySurjective⇒surjective =
+ Setoid.strictlySurjective⇒surjective (cong _)
+
+strictlyInverseˡ⇒inverseˡ : ∀ f → StrictlyInverseˡ _≡_ f f⁻¹ →
+                            Inverseˡ _≡_ _≡_ f f⁻¹
+strictlyInverseˡ⇒inverseˡ f =
+  Setoid.strictlyInverseˡ⇒inverseˡ (cong _)
+
+strictlyInverseʳ⇒inverseʳ : ∀ f → StrictlyInverseʳ _≡_ f f⁻¹ →
+                            Inverseʳ _≡_ _≡_ f f⁻¹
+strictlyInverseʳ⇒inverseʳ f =
+  Setoid.strictlyInverseʳ⇒inverseʳ (cong _)
+
\ No newline at end of file diff --git a/Function.Consequences.Setoid.html b/Function.Consequences.Setoid.html new file mode 100644 index 00000000..045e91fd --- /dev/null +++ b/Function.Consequences.Setoid.html @@ -0,0 +1,94 @@ + +Function.Consequences.Setoid
------------------------------------------------------------------------
+-- The Agda standard library
+--
+-- Relationships between properties of functions where the equality
+-- over both the domain and codomain are assumed to be setoids.
+------------------------------------------------------------------------
+
+{-# OPTIONS --cubical-compatible --safe #-}
+
+open import Relation.Binary.Bundles using (Setoid)
+
+module Function.Consequences.Setoid
+  {a b ℓ₁ ℓ₂}
+  (S : Setoid a ℓ₁)
+  (T : Setoid b ℓ₂)
+  where
+
+open import Function.Definitions
+open import Relation.Nullary.Negation.Core
+
+import Function.Consequences as C
+
+private
+  open module S = Setoid S using () renaming (Carrier to A; _≈_ to ≈₁)
+  open module T = Setoid T using () renaming (Carrier to B; _≈_ to ≈₂)
+
+  variable
+    f : A → B
+    f⁻¹ : B → A
+
+------------------------------------------------------------------------
+-- Injective
+
+contraInjective : Injective ≈₁ ≈₂ f →
+                  ∀ {x y} → ¬ (≈₁ x y) → ¬ (≈₂ (f x) (f y))
+contraInjective = C.contraInjective ≈₂
+
+------------------------------------------------------------------------
+-- Inverseˡ
+
+inverseˡ⇒surjective : Inverseˡ ≈₁ ≈₂ f f⁻¹ → Surjective ≈₁ ≈₂ f
+inverseˡ⇒surjective = C.inverseˡ⇒surjective ≈₂
+
+------------------------------------------------------------------------
+-- Inverseʳ
+
+inverseʳ⇒injective : ∀ f → Inverseʳ ≈₁ ≈₂ f f⁻¹ → Injective ≈₁ ≈₂ f
+inverseʳ⇒injective f = C.inverseʳ⇒injective ≈₂ f T.refl S.sym S.trans
+
+------------------------------------------------------------------------
+-- Inverseᵇ
+
+inverseᵇ⇒bijective : Inverseᵇ ≈₁ ≈₂ f f⁻¹ → Bijective ≈₁ ≈₂ f
+inverseᵇ⇒bijective = C.inverseᵇ⇒bijective ≈₂ T.refl S.sym S.trans
+
+------------------------------------------------------------------------
+-- StrictlySurjective
+
+surjective⇒strictlySurjective : Surjective ≈₁ ≈₂ f →
+                                 StrictlySurjective ≈₂ f
+surjective⇒strictlySurjective =
+  C.surjective⇒strictlySurjective ≈₂ S.refl
+
+strictlySurjective⇒surjective : Congruent ≈₁ ≈₂ f →
+                                 StrictlySurjective ≈₂ f →
+                                 Surjective ≈₁ ≈₂ f
+strictlySurjective⇒surjective =
+  C.strictlySurjective⇒surjective T.trans
+
+------------------------------------------------------------------------
+-- StrictlyInverseˡ
+
+inverseˡ⇒strictlyInverseˡ : Inverseˡ ≈₁ ≈₂ f f⁻¹ →
+                            StrictlyInverseˡ ≈₂ f f⁻¹
+inverseˡ⇒strictlyInverseˡ = C.inverseˡ⇒strictlyInverseˡ ≈₁ ≈₂ S.refl
+
+strictlyInverseˡ⇒inverseˡ : Congruent ≈₁ ≈₂ f →
+                            StrictlyInverseˡ ≈₂ f f⁻¹ →
+                            Inverseˡ ≈₁ ≈₂ f f⁻¹
+strictlyInverseˡ⇒inverseˡ = C.strictlyInverseˡ⇒inverseˡ T.trans
+
+------------------------------------------------------------------------
+-- StrictlyInverseʳ
+
+inverseʳ⇒strictlyInverseʳ : Inverseʳ ≈₁ ≈₂ f f⁻¹ →
+                            StrictlyInverseʳ ≈₁ f f⁻¹
+inverseʳ⇒strictlyInverseʳ = C.inverseʳ⇒strictlyInverseʳ ≈₁ ≈₂ T.refl
+
+strictlyInverseʳ⇒inverseʳ : Congruent ≈₂ ≈₁ f⁻¹ →
+                            StrictlyInverseʳ ≈₁ f f⁻¹ →
+                            Inverseʳ ≈₁ ≈₂ f f⁻¹
+strictlyInverseʳ⇒inverseʳ = C.strictlyInverseʳ⇒inverseʳ S.trans
+
\ No newline at end of file diff --git a/Function.Consequences.html b/Function.Consequences.html index a99d4fa4..cba5f2b1 100644 --- a/Function.Consequences.html +++ b/Function.Consequences.html @@ -2,57 +2,115 @@ Function.Consequences
------------------------------------------------------------------------
 -- The Agda standard library
 --
--- Relationships between properties of functions
-------------------------------------------------------------------------
+-- Relationships between properties of functions. See
+-- `Function.Consequences.Propositional` for specialisations to
+-- propositional equality.
+------------------------------------------------------------------------
 
-{-# OPTIONS --cubical-compatible --safe #-}
+{-# OPTIONS --cubical-compatible --safe #-}
 
-module Function.Consequences where
+module Function.Consequences where
 
-open import Data.Product
-open import Function.Definitions
-open import Level
-open import Relation.Binary
-import Relation.Binary.Reasoning.Setoid as SetoidReasoning
-open import Relation.Nullary.Negation using (¬_)
-open import Relation.Nullary.Negation.Core using (contraposition)
+open import Data.Product.Base as Prod
+open import Function.Definitions
+open import Level using (Level)
+open import Relation.Binary.Core using (Rel)
+open import Relation.Binary.Bundles using (Setoid)
+open import Relation.Binary.Definitions using (Reflexive; Symmetric; Transitive)
+open import Relation.Nullary.Negation.Core using (¬_; contraposition)
 
-private
-  variable
-    a b ℓ₁ ℓ₂ : Level
-    A : Set a
-    B : Set b
+private
+  variable
+    a b ℓ₁ ℓ₂ : Level
+    A B : Set a
+    ≈₁ ≈₂ : Rel A ℓ₁
+    f f⁻¹ : A → B
 
-module _ (≈₁ : Rel A ℓ₁) (≈₂ : Rel B ℓ₂) {f f⁻¹} where
+------------------------------------------------------------------------
+-- Injective
 
-  inverseˡ⇒surjective : Inverseˡ ≈₁ ≈₂ f f⁻¹ → Surjective ≈₁ ≈₂ f
-  inverseˡ⇒surjective invˡ y = (f⁻¹ y , invˡ y)
+contraInjective : ∀ (≈₂ : Rel B ℓ₂) → Injective ≈₁ ≈₂ f →
+                  ∀ {x y} → ¬ (≈₁ x y) → ¬ (≈₂ (f x) (f y))
+contraInjective _ inj p = contraposition inj p
 
-  inverseʳ⇒surjective : Inverseʳ ≈₁ ≈₂ f f⁻¹ → Surjective ≈₂ ≈₁ f⁻¹
-  inverseʳ⇒surjective invʳ y = (f y , invʳ y)
+------------------------------------------------------------------------
+-- Inverseˡ
 
-module _ (From : Setoid a ℓ₁) {≈₂ : Rel B ℓ₂} where
+inverseˡ⇒surjective : ∀ (≈₂ : Rel B ℓ₂) →
+                      Inverseˡ ≈₁ ≈₂ f f⁻¹ →
+                      Surjective ≈₁ ≈₂ f
+inverseˡ⇒surjective ≈₂ invˡ y = (_ , invˡ)
 
-  open Setoid From using () renaming (Carrier to A; _≈_ to ≈₁)
+------------------------------------------------------------------------
+-- Inverseʳ
 
-  inverseʳ⇒injective : ∀ {f f⁻¹} → Congruent ≈₂ ≈₁ f⁻¹ →
-                       Inverseʳ ≈₁ ≈₂ f f⁻¹ → Injective ≈₁ ≈₂ f
-  inverseʳ⇒injective {f} {f⁻¹} cong₂ invʳ {x} {y} x≈y = begin
-    x         ≈˘⟨ invʳ x ⟩
-    f⁻¹ (f x) ≈⟨  cong₂ x≈y ⟩
-    f⁻¹ (f y) ≈⟨  invʳ y ⟩
-    y         ∎
-    where open SetoidReasoning From
+inverseʳ⇒injective : ∀ (≈₂ : Rel B ℓ₂) f →
+                     Reflexive ≈₂ →
+                     Symmetric ≈₁ →
+                     Transitive ≈₁ →
+                     Inverseʳ ≈₁ ≈₂ f f⁻¹ →
+                     Injective ≈₁ ≈₂ f
+inverseʳ⇒injective ≈₂ f refl sym trans invʳ {x} {y} fx≈fy =
+  trans (sym (invʳ refl)) (invʳ fx≈fy)
 
-  inverseᵇ⇒bijective : ∀ {f f⁻¹} → Congruent ≈₂ ≈₁ f⁻¹ → Inverseᵇ ≈₁ ≈₂ f f⁻¹ → Bijective ≈₁ ≈₂ f
-  inverseᵇ⇒bijective cong₂ (invˡ , invʳ) =
-    (inverseʳ⇒injective cong₂ invʳ , inverseˡ⇒surjective ≈₁ ≈₂ invˡ)
+------------------------------------------------------------------------
+-- Inverseᵇ
 
-module _
-  {f : A → B} (_≈₁_ : Rel A ℓ₁) (_≈₂_ : Rel B ℓ₂)
-  where
+inverseᵇ⇒bijective : ∀ (≈₂ : Rel B ℓ₂) →
+                     Reflexive ≈₂ →
+                     Symmetric ≈₁ →
+                     Transitive ≈₁ →
+                     Inverseᵇ ≈₁ ≈₂ f f⁻¹ →
+                     Bijective ≈₁ ≈₂ f
+inverseᵇ⇒bijective {f = f} ≈₂ refl sym trans (invˡ , invʳ) =
+  (inverseʳ⇒injective ≈₂ f refl sym trans invʳ , inverseˡ⇒surjective ≈₂ invˡ)
 
-  contraInjective : Injective _≈₁_ _≈₂_ f →
-                    ∀ {x y} → ¬ (x ≈₁ y) → ¬ (f x ≈₂ f y)
-  contraInjective inj p = contraposition inj p
+------------------------------------------------------------------------
+-- StrictlySurjective
+
+surjective⇒strictlySurjective : ∀ (≈₂ : Rel B ℓ₂) →
+                                 Reflexive ≈₁ →
+                                 Surjective ≈₁ ≈₂ f →
+                                 StrictlySurjective ≈₂ f
+surjective⇒strictlySurjective _ refl surj x =
+  Prod.map₂ (λ v → v refl) (surj x)
+
+strictlySurjective⇒surjective : Transitive ≈₂ →
+                                 Congruent ≈₁ ≈₂ f →
+                                 StrictlySurjective ≈₂ f →
+                                 Surjective ≈₁ ≈₂ f
+strictlySurjective⇒surjective trans cong surj x =
+  Prod.map₂ (λ fy≈x z≈y → trans (cong z≈y) fy≈x) (surj x)
+
+------------------------------------------------------------------------
+-- StrictlyInverseˡ
+
+inverseˡ⇒strictlyInverseˡ : ∀ (≈₁ : Rel A ℓ₁) (≈₂ : Rel B ℓ₂) →
+                            Reflexive ≈₁ →
+                            Inverseˡ ≈₁ ≈₂ f f⁻¹ →
+                            StrictlyInverseˡ ≈₂ f f⁻¹
+inverseˡ⇒strictlyInverseˡ _ _ refl sinv x = sinv refl
+
+strictlyInverseˡ⇒inverseˡ : Transitive ≈₂ →
+                            Congruent ≈₁ ≈₂ f →
+                            StrictlyInverseˡ ≈₂ f f⁻¹ →
+                            Inverseˡ ≈₁ ≈₂ f f⁻¹
+strictlyInverseˡ⇒inverseˡ trans cong sinv {x} y≈f⁻¹x =
+  trans (cong y≈f⁻¹x) (sinv x)
+
+------------------------------------------------------------------------
+-- StrictlyInverseʳ
+
+inverseʳ⇒strictlyInverseʳ : ∀ (≈₁ : Rel A ℓ₁) (≈₂ : Rel B ℓ₂) →
+                            Reflexive ≈₂ →
+                            Inverseʳ ≈₁ ≈₂ f f⁻¹ →
+                            StrictlyInverseʳ ≈₁ f f⁻¹
+inverseʳ⇒strictlyInverseʳ _ _ refl sinv x = sinv refl
+
+strictlyInverseʳ⇒inverseʳ : Transitive ≈₁ →
+                            Congruent ≈₂ ≈₁ f⁻¹ →
+                            StrictlyInverseʳ ≈₁ f f⁻¹ →
+                            Inverseʳ ≈₁ ≈₂ f f⁻¹
+strictlyInverseʳ⇒inverseʳ trans cong sinv {x} y≈f⁻¹x =
+  trans (cong y≈f⁻¹x) (sinv x)
\ No newline at end of file diff --git a/Function.Construct.Composition.html b/Function.Construct.Composition.html index d84ffb04..d53eb462 100644 --- a/Function.Construct.Composition.html +++ b/Function.Construct.Composition.html @@ -9,280 +9,281 @@ module Function.Construct.Composition where -open import Data.Product using (_,_) -open import Function -open import Level using (Level) -open import Relation.Binary as B hiding (_⇔_; IsEquivalence) - -private - variable - a b c ℓ₁ ℓ₂ ℓ₃ : Level - A B C : Set a - ------------------------------------------------------------------------- --- Properties - -module _ (≈₁ : Rel A ℓ₁) (≈₂ : Rel B ℓ₂) (≈₃ : Rel C ℓ₃) - {f : A → B} {g : B → C} - where - - congruent : Congruent ≈₁ ≈₂ f → Congruent ≈₂ ≈₃ g → - Congruent ≈₁ ≈₃ (g ∘ f) - congruent f-cong g-cong = g-cong ∘ f-cong - - injective : Injective ≈₁ ≈₂ f → Injective ≈₂ ≈₃ g → - Injective ≈₁ ≈₃ (g ∘ f) - injective f-inj g-inj = f-inj ∘ g-inj - - surjective : Transitive ≈₃ → Congruent ≈₂ ≈₃ g → - Surjective ≈₁ ≈₂ f → Surjective ≈₂ ≈₃ g → - Surjective ≈₁ ≈₃ (g ∘ f) - surjective trans g-cong f-sur g-sur x with g-sur x - ... | y , fy≈x with f-sur y - ... | z , fz≈y = z , trans (g-cong fz≈y) fy≈x - - bijective : Transitive ≈₃ → Congruent ≈₂ ≈₃ g → - Bijective ≈₁ ≈₂ f → Bijective ≈₂ ≈₃ g → - Bijective ≈₁ ≈₃ (g ∘ f) - bijective trans g-cong (f-inj , f-sur) (g-inj , g-sur) = - injective f-inj g-inj , surjective trans g-cong f-sur g-sur - -module _ (≈₁ : Rel A ℓ₁) (≈₂ : Rel B ℓ₂) (≈₃ : Rel C ℓ₃) - (f : A → B) {f⁻¹ : B → A} {g : B → C} (g⁻¹ : C → B) - where - - inverseˡ : Transitive ≈₃ → Congruent ≈₂ ≈₃ g → - Inverseˡ ≈₁ ≈₂ f f⁻¹ → Inverseˡ ≈₂ ≈₃ g g⁻¹ → - Inverseˡ ≈₁ ≈₃ (g ∘ f) (f⁻¹ ∘ g⁻¹) - inverseˡ trn g-cong f-inv g-inv x = trn (g-cong (f-inv _)) (g-inv x) - - inverseʳ : Transitive ≈₁ → Congruent ≈₂ ≈₁ f⁻¹ → - Inverseʳ ≈₁ ≈₂ f f⁻¹ → Inverseʳ ≈₂ ≈₃ g g⁻¹ → - Inverseʳ ≈₁ ≈₃ (g ∘ f) (f⁻¹ ∘ g⁻¹) - inverseʳ trn f⁻¹-cong f-inv g-inv x = trn (f⁻¹-cong (g-inv _)) (f-inv x) - - inverseᵇ : Transitive ≈₁ → Transitive ≈₃ → - Congruent ≈₂ ≈₃ g → Congruent ≈₂ ≈₁ f⁻¹ → - Inverseᵇ ≈₁ ≈₂ f f⁻¹ → Inverseᵇ ≈₂ ≈₃ g g⁻¹ → - Inverseᵇ ≈₁ ≈₃ (g ∘ f) (f⁻¹ ∘ g⁻¹) - inverseᵇ trn₁ trn₃ g-cong f⁻¹-cong (f-invˡ , f-invʳ) (g-invˡ , g-invʳ) = - inverseˡ trn₃ g-cong f-invˡ g-invˡ , inverseʳ trn₁ f⁻¹-cong f-invʳ g-invʳ - ------------------------------------------------------------------------- --- Structures - -module _ {≈₁ : Rel A ℓ₁} {≈₂ : Rel B ℓ₂} {≈₃ : Rel C ℓ₃} - {f : A → B} {g : B → C} - where - - isCongruent : IsCongruent ≈₁ ≈₂ f → IsCongruent ≈₂ ≈₃ g → - IsCongruent ≈₁ ≈₃ (g ∘ f) - isCongruent f-cong g-cong = record - { cong = G.cong ∘ F.cong - ; isEquivalence₁ = F.isEquivalence₁ - ; isEquivalence₂ = G.isEquivalence₂ - } where module F = IsCongruent f-cong; module G = IsCongruent g-cong - - isInjection : IsInjection ≈₁ ≈₂ f → IsInjection ≈₂ ≈₃ g → - IsInjection ≈₁ ≈₃ (g ∘ f) - isInjection f-inj g-inj = record - { isCongruent = isCongruent F.isCongruent G.isCongruent - ; injective = injective ≈₁ ≈₂ ≈₃ F.injective G.injective - } where module F = IsInjection f-inj; module G = IsInjection g-inj - - isSurjection : IsSurjection ≈₁ ≈₂ f → IsSurjection ≈₂ ≈₃ g → - IsSurjection ≈₁ ≈₃ (g ∘ f) - isSurjection f-surj g-surj = record - { isCongruent = isCongruent F.isCongruent G.isCongruent - ; surjective = surjective ≈₁ ≈₂ ≈₃ G.Eq₂.trans G.cong F.surjective G.surjective - } where module F = IsSurjection f-surj; module G = IsSurjection g-surj - - isBijection : IsBijection ≈₁ ≈₂ f → IsBijection ≈₂ ≈₃ g → - IsBijection ≈₁ ≈₃ (g ∘ f) - isBijection f-bij g-bij = record - { isInjection = isInjection F.isInjection G.isInjection - ; surjective = surjective ≈₁ ≈₂ ≈₃ G.Eq₂.trans G.cong F.surjective G.surjective - } where module F = IsBijection f-bij; module G = IsBijection g-bij - -module _ {≈₁ : Rel A ℓ₁} {≈₂ : Rel B ℓ₂} {≈₃ : Rel C ℓ₃} - {f : A → B} {g : B → C} {f⁻¹ : B → A} {g⁻¹ : C → B} - where - - isLeftInverse : IsLeftInverse ≈₁ ≈₂ f f⁻¹ → IsLeftInverse ≈₂ ≈₃ g g⁻¹ → - IsLeftInverse ≈₁ ≈₃ (g ∘ f) (f⁻¹ ∘ g⁻¹) - isLeftInverse f-invˡ g-invˡ = record - { isCongruent = isCongruent F.isCongruent G.isCongruent - ; from-cong = congruent ≈₃ ≈₂ ≈₁ G.from-cong F.from-cong - ; inverseˡ = inverseˡ ≈₁ ≈₂ ≈₃ f _ G.Eq₂.trans G.to-cong F.inverseˡ G.inverseˡ - } where module F = IsLeftInverse f-invˡ; module G = IsLeftInverse g-invˡ - - isRightInverse : IsRightInverse ≈₁ ≈₂ f f⁻¹ → IsRightInverse ≈₂ ≈₃ g g⁻¹ → - IsRightInverse ≈₁ ≈₃ (g ∘ f) (f⁻¹ ∘ g⁻¹) - isRightInverse f-invʳ g-invʳ = record - { isCongruent = isCongruent F.isCongruent G.isCongruent - ; from-cong = congruent ≈₃ ≈₂ ≈₁ G.from-cong F.from-cong - ; inverseʳ = inverseʳ ≈₁ ≈₂ ≈₃ _ g⁻¹ F.Eq₁.trans F.from-cong F.inverseʳ G.inverseʳ - } where module F = IsRightInverse f-invʳ; module G = IsRightInverse g-invʳ - - isInverse : IsInverse ≈₁ ≈₂ f f⁻¹ → IsInverse ≈₂ ≈₃ g g⁻¹ → - IsInverse ≈₁ ≈₃ (g ∘ f) (f⁻¹ ∘ g⁻¹) - isInverse f-inv g-inv = record - { isLeftInverse = isLeftInverse F.isLeftInverse G.isLeftInverse - ; inverseʳ = inverseʳ ≈₁ ≈₂ ≈₃ _ g⁻¹ F.Eq₁.trans F.from-cong F.inverseʳ G.inverseʳ - } where module F = IsInverse f-inv; module G = IsInverse g-inv - ------------------------------------------------------------------------- --- Setoid bundles - -module _ {R : Setoid a ℓ₁} {S : Setoid b ℓ₂} {T : Setoid c ℓ₃} where - - open Setoid renaming (_≈_ to ≈) - - function : Func R S → Func S T → Func R T - function f g = record - { to = G.to ∘ F.to - ; cong = congruent (≈ R) (≈ S) (≈ T) F.cong G.cong - } where module F = Func f; module G = Func g - - injection : Injection R S → Injection S T → Injection R T - injection inj₁ inj₂ = record - { to = G.to ∘ F.to - ; cong = congruent (≈ R) (≈ S) (≈ T) F.cong G.cong - ; injective = injective (≈ R) (≈ S) (≈ T) F.injective G.injective - } where module F = Injection inj₁; module G = Injection inj₂ - - surjection : Surjection R S → Surjection S T → Surjection R T - surjection surj₁ surj₂ = record - { to = G.to ∘ F.to - ; cong = congruent (≈ R) (≈ S) (≈ T) F.cong G.cong - ; surjective = surjective (≈ R) (≈ S) (≈ T) G.Eq₂.trans G.cong F.surjective G.surjective - } where module F = Surjection surj₁; module G = Surjection surj₂ - - bijection : Bijection R S → Bijection S T → Bijection R T - bijection bij₁ bij₂ = record - { to = G.to ∘ F.to - ; cong = congruent (≈ R) (≈ S) (≈ T) F.cong G.cong - ; bijective = bijective (≈ R) (≈ S) (≈ T) (trans T) G.cong F.bijective G.bijective - } where module F = Bijection bij₁; module G = Bijection bij₂ - - equivalence : Equivalence R S → Equivalence S T → Equivalence R T - equivalence equiv₁ equiv₂ = record - { to = G.to ∘ F.to - ; from = F.from ∘ G.from - ; to-cong = congruent (≈ R) (≈ S) (≈ T) F.to-cong G.to-cong - ; from-cong = congruent (≈ T) (≈ S) (≈ R) G.from-cong F.from-cong - } where module F = Equivalence equiv₁; module G = Equivalence equiv₂ - - leftInverse : LeftInverse R S → LeftInverse S T → LeftInverse R T - leftInverse invˡ₁ invˡ₂ = record - { to = G.to ∘ F.to - ; from = F.from ∘ G.from - ; to-cong = congruent (≈ R) (≈ S) (≈ T) F.to-cong G.to-cong - ; from-cong = congruent (≈ T) (≈ S) (≈ R) G.from-cong F.from-cong - ; inverseˡ = inverseˡ (≈ R) (≈ S) (≈ T) F.to _ (trans T) G.to-cong F.inverseˡ G.inverseˡ - } where module F = LeftInverse invˡ₁; module G = LeftInverse invˡ₂ - - rightInverse : RightInverse R S → RightInverse S T → RightInverse R T - rightInverse invʳ₁ invʳ₂ = record - { to = G.to ∘ F.to - ; from = F.from ∘ G.from - ; to-cong = congruent (≈ R) (≈ S) (≈ T) F.to-cong G.to-cong - ; from-cong = congruent (≈ T) (≈ S) (≈ R) G.from-cong F.from-cong - ; inverseʳ = inverseʳ (≈ R) (≈ S) (≈ T) _ G.from (trans R) F.from-cong F.inverseʳ G.inverseʳ - } where module F = RightInverse invʳ₁; module G = RightInverse invʳ₂ - - inverse : Inverse R S → Inverse S T → Inverse R T - inverse inv₁ inv₂ = record - { to = G.to ∘ F.to - ; from = F.from ∘ G.from - ; to-cong = congruent (≈ R) (≈ S) (≈ T) F.to-cong G.to-cong - ; from-cong = congruent (≈ T) (≈ S) (≈ R) G.from-cong F.from-cong - ; inverse = inverseᵇ (≈ R) (≈ S) (≈ T) _ G.from (trans R) (trans T) G.to-cong F.from-cong F.inverse G.inverse - } where module F = Inverse inv₁; module G = Inverse inv₂ - ------------------------------------------------------------------------- --- Propositional bundles - -infix 8 _⟶-∘_ _↣-∘_ _↠-∘_ _⤖-∘_ _⇔-∘_ _↩-∘_ _↪-∘_ _↔-∘_ - -_⟶-∘_ : (A ⟶ B) → (B ⟶ C) → (A ⟶ C) -_⟶-∘_ = function - -_↣-∘_ : A ↣ B → B ↣ C → A ↣ C -_↣-∘_ = injection - -_↠-∘_ : A ↠ B → B ↠ C → A ↠ C -_↠-∘_ = surjection - -_⤖-∘_ : A ⤖ B → B ⤖ C → A ⤖ C -_⤖-∘_ = bijection - -_⇔-∘_ : A ⇔ B → B ⇔ C → A ⇔ C -_⇔-∘_ = equivalence - -_↩-∘_ : A ↩ B → B ↩ C → A ↩ C -_↩-∘_ = leftInverse - -_↪-∘_ : A ↪ B → B ↪ C → A ↪ C -_↪-∘_ = rightInverse - -_↔-∘_ : A ↔ B → B ↔ C → A ↔ C -_↔-∘_ = inverse - - ------------------------------------------------------------------------- --- DEPRECATED NAMES ------------------------------------------------------------------------- --- Please use the new names as continuing support for the old names is --- not guaranteed. - --- Version v2.0 - -_∘-⟶_ = _⟶-∘_ -{-# WARNING_ON_USAGE _∘-⟶_ -"Warning: _∘-⟶_ was deprecated in v2.0. +open import Data.Product.Base as Product using (_,_) +open import Function.Base using (_∘_; flip) +open import Function.Bundles +open import Function.Definitions +open import Function.Structures +open import Level using (Level) +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Binary.Definitions using (Transitive) + +private + variable + a b c ℓ₁ ℓ₂ ℓ₃ : Level + A B C : Set a + +------------------------------------------------------------------------ +-- Properties + +module _ (≈₁ : Rel A ℓ₁) (≈₂ : Rel B ℓ₂) (≈₃ : Rel C ℓ₃) + {f : A → B} {g : B → C} + where + + congruent : Congruent ≈₁ ≈₂ f → Congruent ≈₂ ≈₃ g → + Congruent ≈₁ ≈₃ (g ∘ f) + congruent f-cong g-cong = g-cong ∘ f-cong + + injective : Injective ≈₁ ≈₂ f → Injective ≈₂ ≈₃ g → + Injective ≈₁ ≈₃ (g ∘ f) + injective f-inj g-inj = f-inj ∘ g-inj + + surjective : Surjective ≈₁ ≈₂ f → Surjective ≈₂ ≈₃ g → + Surjective ≈₁ ≈₃ (g ∘ f) + surjective f-sur g-sur x with g-sur x + ... | y , gproof with f-sur y + ... | z , fproof = z , gproof ∘ fproof + + bijective : Bijective ≈₁ ≈₂ f → Bijective ≈₂ ≈₃ g → + Bijective ≈₁ ≈₃ (g ∘ f) + bijective = Product.zip′ injective surjective + +module _ (≈₁ : Rel A ℓ₁) (≈₂ : Rel B ℓ₂) (≈₃ : Rel C ℓ₃) + {f : A → B} {f⁻¹ : B → A} {g : B → C} {g⁻¹ : C → B} + where + + inverseˡ : Inverseˡ ≈₁ ≈₂ f f⁻¹ → Inverseˡ ≈₂ ≈₃ g g⁻¹ → + Inverseˡ ≈₁ ≈₃ (g ∘ f) (f⁻¹ ∘ g⁻¹) + inverseˡ f-inv g-inv = g-inv ∘ f-inv + + inverseʳ : Inverseʳ ≈₁ ≈₂ f f⁻¹ → Inverseʳ ≈₂ ≈₃ g g⁻¹ → + Inverseʳ ≈₁ ≈₃ (g ∘ f) (f⁻¹ ∘ g⁻¹) + inverseʳ f-inv g-inv = f-inv ∘ g-inv + + inverseᵇ : Inverseᵇ ≈₁ ≈₂ f f⁻¹ → Inverseᵇ ≈₂ ≈₃ g g⁻¹ → + Inverseᵇ ≈₁ ≈₃ (g ∘ f) (f⁻¹ ∘ g⁻¹) + inverseᵇ = Product.zip′ inverseˡ inverseʳ + +------------------------------------------------------------------------ +-- Structures + +module _ {≈₁ : Rel A ℓ₁} {≈₂ : Rel B ℓ₂} {≈₃ : Rel C ℓ₃} + {f : A → B} {g : B → C} + where + + isCongruent : IsCongruent ≈₁ ≈₂ f → IsCongruent ≈₂ ≈₃ g → + IsCongruent ≈₁ ≈₃ (g ∘ f) + isCongruent f-cong g-cong = record + { cong = G.cong ∘ F.cong + ; isEquivalence₁ = F.isEquivalence₁ + ; isEquivalence₂ = G.isEquivalence₂ + } where module F = IsCongruent f-cong; module G = IsCongruent g-cong + + isInjection : IsInjection ≈₁ ≈₂ f → IsInjection ≈₂ ≈₃ g → + IsInjection ≈₁ ≈₃ (g ∘ f) + isInjection f-inj g-inj = record + { isCongruent = isCongruent F.isCongruent G.isCongruent + ; injective = injective ≈₁ ≈₂ ≈₃ F.injective G.injective + } where module F = IsInjection f-inj; module G = IsInjection g-inj + + isSurjection : IsSurjection ≈₁ ≈₂ f → IsSurjection ≈₂ ≈₃ g → + IsSurjection ≈₁ ≈₃ (g ∘ f) + isSurjection f-surj g-surj = record + { isCongruent = isCongruent F.isCongruent G.isCongruent + ; surjective = surjective ≈₁ ≈₂ ≈₃ F.surjective G.surjective + } where module F = IsSurjection f-surj; module G = IsSurjection g-surj + + isBijection : IsBijection ≈₁ ≈₂ f → IsBijection ≈₂ ≈₃ g → + IsBijection ≈₁ ≈₃ (g ∘ f) + isBijection f-bij g-bij = record + { isInjection = isInjection F.isInjection G.isInjection + ; surjective = surjective ≈₁ ≈₂ ≈₃ F.surjective G.surjective + } where module F = IsBijection f-bij; module G = IsBijection g-bij + +module _ {≈₁ : Rel A ℓ₁} {≈₂ : Rel B ℓ₂} {≈₃ : Rel C ℓ₃} + {f : A → B} {g : B → C} {f⁻¹ : B → A} {g⁻¹ : C → B} + where + + isLeftInverse : IsLeftInverse ≈₁ ≈₂ f f⁻¹ → IsLeftInverse ≈₂ ≈₃ g g⁻¹ → + IsLeftInverse ≈₁ ≈₃ (g ∘ f) (f⁻¹ ∘ g⁻¹) + isLeftInverse f-invˡ g-invˡ = record + { isCongruent = isCongruent F.isCongruent G.isCongruent + ; from-cong = congruent ≈₃ ≈₂ ≈₁ G.from-cong F.from-cong + ; inverseˡ = inverseˡ ≈₁ ≈₂ ≈₃ F.inverseˡ G.inverseˡ + } where module F = IsLeftInverse f-invˡ; module G = IsLeftInverse g-invˡ + + isRightInverse : IsRightInverse ≈₁ ≈₂ f f⁻¹ → IsRightInverse ≈₂ ≈₃ g g⁻¹ → + IsRightInverse ≈₁ ≈₃ (g ∘ f) (f⁻¹ ∘ g⁻¹) + isRightInverse f-invʳ g-invʳ = record + { isCongruent = isCongruent F.isCongruent G.isCongruent + ; from-cong = congruent ≈₃ ≈₂ ≈₁ G.from-cong F.from-cong + ; inverseʳ = inverseʳ ≈₁ ≈₂ ≈₃ F.inverseʳ G.inverseʳ + } where module F = IsRightInverse f-invʳ; module G = IsRightInverse g-invʳ + + isInverse : IsInverse ≈₁ ≈₂ f f⁻¹ → IsInverse ≈₂ ≈₃ g g⁻¹ → + IsInverse ≈₁ ≈₃ (g ∘ f) (f⁻¹ ∘ g⁻¹) + isInverse f-inv g-inv = record + { isLeftInverse = isLeftInverse F.isLeftInverse G.isLeftInverse + ; inverseʳ = inverseʳ ≈₁ ≈₂ ≈₃ F.inverseʳ G.inverseʳ + } where module F = IsInverse f-inv; module G = IsInverse g-inv + +------------------------------------------------------------------------ +-- Setoid bundles + +module _ {R : Setoid a ℓ₁} {S : Setoid b ℓ₂} {T : Setoid c ℓ₃} where + + open Setoid renaming (_≈_ to ≈) + + function : Func R S → Func S T → Func R T + function f g = record + { to = G.to ∘ F.to + ; cong = congruent (≈ R) (≈ S) (≈ T) F.cong G.cong + } where module F = Func f; module G = Func g + + injection : Injection R S → Injection S T → Injection R T + injection inj₁ inj₂ = record + { to = G.to ∘ F.to + ; cong = congruent (≈ R) (≈ S) (≈ T) F.cong G.cong + ; injective = injective (≈ R) (≈ S) (≈ T) F.injective G.injective + } where module F = Injection inj₁; module G = Injection inj₂ + + surjection : Surjection R S → Surjection S T → Surjection R T + surjection surj₁ surj₂ = record + { to = G.to ∘ F.to + ; cong = congruent (≈ R) (≈ S) (≈ T) F.cong G.cong + ; surjective = surjective (≈ R) (≈ S) (≈ T) F.surjective G.surjective + } where module F = Surjection surj₁; module G = Surjection surj₂ + + bijection : Bijection R S → Bijection S T → Bijection R T + bijection bij₁ bij₂ = record + { to = G.to ∘ F.to + ; cong = congruent (≈ R) (≈ S) (≈ T) F.cong G.cong + ; bijective = bijective (≈ R) (≈ S) (≈ T) F.bijective G.bijective + } where module F = Bijection bij₁; module G = Bijection bij₂ + + equivalence : Equivalence R S → Equivalence S T → Equivalence R T + equivalence equiv₁ equiv₂ = record + { to = G.to ∘ F.to + ; from = F.from ∘ G.from + ; to-cong = congruent (≈ R) (≈ S) (≈ T) F.to-cong G.to-cong + ; from-cong = congruent (≈ T) (≈ S) (≈ R) G.from-cong F.from-cong + } where module F = Equivalence equiv₁; module G = Equivalence equiv₂ + + leftInverse : LeftInverse R S → LeftInverse S T → LeftInverse R T + leftInverse invˡ₁ invˡ₂ = record + { to = G.to ∘ F.to + ; from = F.from ∘ G.from + ; to-cong = congruent (≈ R) (≈ S) (≈ T) F.to-cong G.to-cong + ; from-cong = congruent (≈ T) (≈ S) (≈ R) G.from-cong F.from-cong + ; inverseˡ = inverseˡ (≈ R) (≈ S) (≈ T) F.inverseˡ G.inverseˡ + } where module F = LeftInverse invˡ₁; module G = LeftInverse invˡ₂ + + rightInverse : RightInverse R S → RightInverse S T → RightInverse R T + rightInverse invʳ₁ invʳ₂ = record + { to = G.to ∘ F.to + ; from = F.from ∘ G.from + ; to-cong = congruent (≈ R) (≈ S) (≈ T) F.to-cong G.to-cong + ; from-cong = congruent (≈ T) (≈ S) (≈ R) G.from-cong F.from-cong + ; inverseʳ = inverseʳ (≈ R) (≈ S) (≈ T) F.inverseʳ G.inverseʳ + } where module F = RightInverse invʳ₁; module G = RightInverse invʳ₂ + + inverse : Inverse R S → Inverse S T → Inverse R T + inverse inv₁ inv₂ = record + { to = G.to ∘ F.to + ; from = F.from ∘ G.from + ; to-cong = congruent (≈ R) (≈ S) (≈ T) F.to-cong G.to-cong + ; from-cong = congruent (≈ T) (≈ S) (≈ R) G.from-cong F.from-cong + ; inverse = inverseᵇ (≈ R) (≈ S) (≈ T) F.inverse G.inverse + } where module F = Inverse inv₁; module G = Inverse inv₂ + +------------------------------------------------------------------------ +-- Propositional bundles + +-- Notice the flipped order of the arguments to mirror composition. + +infix 8 _⟶-∘_ _↣-∘_ _↠-∘_ _⤖-∘_ _⇔-∘_ _↩-∘_ _↪-∘_ _↔-∘_ + +_⟶-∘_ : (B ⟶ C) → (A ⟶ B) → (A ⟶ C) +_⟶-∘_ = flip function + +_↣-∘_ : B ↣ C → A ↣ B → A ↣ C +_↣-∘_ = flip injection + +_↠-∘_ : B ↠ C → A ↠ B → A ↠ C +_↠-∘_ = flip surjection + +_⤖-∘_ : B ⤖ C → A ⤖ B → A ⤖ C +_⤖-∘_ = flip bijection + +_⇔-∘_ : B ⇔ C → A ⇔ B → A ⇔ C +_⇔-∘_ = flip equivalence + +_↩-∘_ : B ↩ C → A ↩ B → A ↩ C +_↩-∘_ = flip leftInverse + +_↪-∘_ : B ↪ C → A ↪ B → A ↪ C +_↪-∘_ = flip rightInverse + +_↔-∘_ : B ↔ C → A ↔ B → A ↔ C +_↔-∘_ = flip inverse + + +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version v2.0 + +infix 8 _∘-⟶_ _∘-↣_ _∘-↠_ _∘-⤖_ _∘-⇔_ _∘-↩_ _∘-↪_ _∘-↔_ + +_∘-⟶_ = _⟶-∘_ +{-# WARNING_ON_USAGE _∘-⟶_ +"Warning: _∘-⟶_ was deprecated in v2.0. Please use _⟶-∘_ instead." -#-} +#-} -_∘-↣_ = _↣-∘_ -{-# WARNING_ON_USAGE _∘-↣_ -"Warning: _∘-↣_ was deprecated in v2.0. +_∘-↣_ = _↣-∘_ +{-# WARNING_ON_USAGE _∘-↣_ +"Warning: _∘-↣_ was deprecated in v2.0. Please use _↣-∘_ instead." -#-} +#-} -_∘-↠_ = _↠-∘_ -{-# WARNING_ON_USAGE _∘-↠_ -"Warning: _∘-↠_ was deprecated in v2.0. +_∘-↠_ = _↠-∘_ +{-# WARNING_ON_USAGE _∘-↠_ +"Warning: _∘-↠_ was deprecated in v2.0. Please use _↠-∘_ instead." -#-} +#-} -_∘-⤖_ = _⤖-∘_ -{-# WARNING_ON_USAGE _∘-⤖_ -"Warning: _∘-⤖_ was deprecated in v2.0. +_∘-⤖_ = _⤖-∘_ +{-# WARNING_ON_USAGE _∘-⤖_ +"Warning: _∘-⤖_ was deprecated in v2.0. Please use _⤖-∘_ instead." -#-} +#-} -_∘-⇔_ = _⇔-∘_ -{-# WARNING_ON_USAGE _∘-⇔_ -"Warning: _∘-⇔_ was deprecated in v2.0. +_∘-⇔_ = _⇔-∘_ +{-# WARNING_ON_USAGE _∘-⇔_ +"Warning: _∘-⇔_ was deprecated in v2.0. Please use _⇔-∘_ instead." -#-} +#-} -_∘-↩_ = _↩-∘_ -{-# WARNING_ON_USAGE _∘-↩_ -"Warning: _∘-↩_ was deprecated in v2.0. +_∘-↩_ = _↩-∘_ +{-# WARNING_ON_USAGE _∘-↩_ +"Warning: _∘-↩_ was deprecated in v2.0. Please use _↩-∘_ instead." -#-} +#-} -_∘-↪_ = _↪-∘_ -{-# WARNING_ON_USAGE _∘-↪_ -"Warning: _∘-↪_ was deprecated in v2.0. +_∘-↪_ = _↪-∘_ +{-# WARNING_ON_USAGE _∘-↪_ +"Warning: _∘-↪_ was deprecated in v2.0. Please use _↪-∘_ instead." -#-} +#-} -_∘-↔_ = _↔-∘_ -{-# WARNING_ON_USAGE _∘-↔_ -"Warning: _∘-↔_ was deprecated in v2.0. +_∘-↔_ = _↔-∘_ +{-# WARNING_ON_USAGE _∘-↔_ +"Warning: _∘-↔_ was deprecated in v2.0. Please use _↔-∘_ instead." -#-} +#-} \ No newline at end of file diff --git a/Function.Construct.Identity.html b/Function.Construct.Identity.html index 71c5b987..e279d677 100644 --- a/Function.Construct.Identity.html +++ b/Function.Construct.Identity.html @@ -9,253 +9,257 @@ module Function.Construct.Identity where -open import Data.Product using (_,_) -open import Function.Base using (id) -open import Function.Bundles -import Function.Definitions as Definitions -import Function.Structures as Structures -open import Level -open import Relation.Binary as B hiding (_⇔_; IsEquivalence) -open import Relation.Binary.PropositionalEquality using (_≡_; setoid) - -private - variable - a ℓ : Level - A : Set a - ------------------------------------------------------------------------- --- Properties - -module _ (_≈_ : Rel A ℓ) where - - open Definitions _≈_ _≈_ - - congruent : Congruent id - congruent = id - - injective : Injective id - injective = id - - surjective : Reflexive _≈_ → Surjective id - surjective refl x = x , refl - - bijective : Reflexive _≈_ → Bijective id - bijective refl = injective , surjective refl - - inverseˡ : Reflexive _≈_ → Inverseˡ id id - inverseˡ refl x = refl - - inverseʳ : Reflexive _≈_ → Inverseʳ id id - inverseʳ refl x = refl - - inverseᵇ : Reflexive _≈_ → Inverseᵇ id id - inverseᵇ refl = inverseˡ refl , inverseʳ refl - ------------------------------------------------------------------------- --- Structures - -module _ {_≈_ : Rel A ℓ} (isEq : B.IsEquivalence _≈_) where - - open Structures _≈_ _≈_ - open B.IsEquivalence isEq - - isCongruent : IsCongruent id - isCongruent = record - { cong = id - ; isEquivalence₁ = isEq - ; isEquivalence₂ = isEq - } - - isInjection : IsInjection id - isInjection = record - { isCongruent = isCongruent - ; injective = injective _≈_ - } - - isSurjection : IsSurjection id - isSurjection = record - { isCongruent = isCongruent - ; surjective = surjective _≈_ refl - } - - isBijection : IsBijection id - isBijection = record - { isInjection = isInjection - ; surjective = surjective _≈_ refl - } - - isLeftInverse : IsLeftInverse id id - isLeftInverse = record - { isCongruent = isCongruent - ; from-cong = id - ; inverseˡ = inverseˡ _≈_ refl - } - - isRightInverse : IsRightInverse id id - isRightInverse = record - { isCongruent = isCongruent - ; from-cong = id - ; inverseʳ = inverseʳ _≈_ refl - } - - isInverse : IsInverse id id - isInverse = record - { isLeftInverse = isLeftInverse - ; inverseʳ = inverseʳ _≈_ refl - } - ------------------------------------------------------------------------- --- Setoid bundles - -module _ (S : Setoid a ℓ) where - - open Setoid S - - function : Func S S - function = record - { to = id - ; cong = id - } - - injection : Injection S S - injection = record - { to = id - ; cong = id - ; injective = injective _≈_ - } - - surjection : Surjection S S - surjection = record - { to = id - ; cong = id - ; surjective = surjective _≈_ refl - } - - bijection : Bijection S S - bijection = record - { to = id - ; cong = id - ; bijective = bijective _≈_ refl - } - - equivalence : Equivalence S S - equivalence = record - { to = id - ; from = id - ; to-cong = id - ; from-cong = id - } - - leftInverse : LeftInverse S S - leftInverse = record - { to = id - ; from = id - ; to-cong = id - ; from-cong = id - ; inverseˡ = inverseˡ _≈_ refl - } - - rightInverse : RightInverse S S - rightInverse = record - { to = id - ; from = id - ; to-cong = id - ; from-cong = id - ; inverseʳ = inverseʳ _≈_ refl - } - - inverse : Inverse S S - inverse = record - { to = id - ; from = id - ; to-cong = id - ; from-cong = id - ; inverse = inverseᵇ _≈_ refl - } - ------------------------------------------------------------------------- --- Propositional bundles - -module _ (A : Set a) where - - ⟶-id : A ⟶ A - ⟶-id = function (setoid A) - - ↣-id : A ↣ A - ↣-id = injection (setoid A) - - ↠-id : A ↠ A - ↠-id = surjection (setoid A) - - ⤖-id : A ⤖ A - ⤖-id = bijection (setoid A) - - ⇔-id : A ⇔ A - ⇔-id = equivalence (setoid A) - - ↩-id : A ↩ A - ↩-id = leftInverse (setoid A) - - ↪-id : A ↪ A - ↪-id = rightInverse (setoid A) - - ↔-id : A ↔ A - ↔-id = inverse (setoid A) - - ------------------------------------------------------------------------- --- DEPRECATED NAMES ------------------------------------------------------------------------- --- Please use the new names as continuing support for the old names is --- not guaranteed. - --- Version v2.0 - -id-⟶ = ⟶-id -{-# WARNING_ON_USAGE id-⟶ -"Warning: id-⟶ was deprecated in v2.0. +open import Data.Product.Base using (_,_) +open import Function.Base using (id) +open import Function.Bundles +import Function.Definitions as Definitions +import Function.Structures as Structures +open import Level using (Level) +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Binary.Structures as B hiding (IsEquivalence) +open import Relation.Binary.Definitions using (Reflexive) +open import Relation.Binary.PropositionalEquality.Core using (_≡_) +open import Relation.Binary.PropositionalEquality.Properties using (setoid) + +private + variable + a ℓ : Level + A : Set a + +------------------------------------------------------------------------ +-- Properties + +module _ (_≈_ : Rel A ℓ) where + + open Definitions + + congruent : Congruent _≈_ _≈_ id + congruent = id + + injective : Injective _≈_ _≈_ id + injective = id + + surjective : Surjective _≈_ _≈_ id + surjective x = x , id + + bijective : Bijective _≈_ _≈_ id + bijective = injective , surjective + + inverseˡ : Inverseˡ _≈_ _≈_ id id + inverseˡ = id + + inverseʳ : Inverseʳ _≈_ _≈_ id id + inverseʳ = id + + inverseᵇ : Inverseᵇ _≈_ _≈_ id id + inverseᵇ = inverseˡ , inverseʳ + +------------------------------------------------------------------------ +-- Structures + +module _ {_≈_ : Rel A ℓ} (isEq : B.IsEquivalence _≈_) where + + open Structures _≈_ _≈_ + open B.IsEquivalence isEq + + isCongruent : IsCongruent id + isCongruent = record + { cong = id + ; isEquivalence₁ = isEq + ; isEquivalence₂ = isEq + } + + isInjection : IsInjection id + isInjection = record + { isCongruent = isCongruent + ; injective = injective _≈_ + } + + isSurjection : IsSurjection id + isSurjection = record + { isCongruent = isCongruent + ; surjective = surjective _≈_ + } + + isBijection : IsBijection id + isBijection = record + { isInjection = isInjection + ; surjective = surjective _≈_ + } + + isLeftInverse : IsLeftInverse id id + isLeftInverse = record + { isCongruent = isCongruent + ; from-cong = id + ; inverseˡ = inverseˡ _≈_ + } + + isRightInverse : IsRightInverse id id + isRightInverse = record + { isCongruent = isCongruent + ; from-cong = id + ; inverseʳ = inverseʳ _≈_ + } + + isInverse : IsInverse id id + isInverse = record + { isLeftInverse = isLeftInverse + ; inverseʳ = inverseʳ _≈_ + } + +------------------------------------------------------------------------ +-- Setoid bundles + +module _ (S : Setoid a ℓ) where + + open Setoid S + + function : Func S S + function = record + { to = id + ; cong = id + } + + injection : Injection S S + injection = record + { to = id + ; cong = id + ; injective = injective _≈_ + } + + surjection : Surjection S S + surjection = record + { to = id + ; cong = id + ; surjective = surjective _≈_ + } + + bijection : Bijection S S + bijection = record + { to = id + ; cong = id + ; bijective = bijective _≈_ + } + + equivalence : Equivalence S S + equivalence = record + { to = id + ; from = id + ; to-cong = id + ; from-cong = id + } + + leftInverse : LeftInverse S S + leftInverse = record + { to = id + ; from = id + ; to-cong = id + ; from-cong = id + ; inverseˡ = inverseˡ _≈_ + } + + rightInverse : RightInverse S S + rightInverse = record + { to = id + ; from = id + ; to-cong = id + ; from-cong = id + ; inverseʳ = inverseʳ _≈_ + } + + inverse : Inverse S S + inverse = record + { to = id + ; from = id + ; to-cong = id + ; from-cong = id + ; inverse = inverseᵇ _≈_ + } + +------------------------------------------------------------------------ +-- Propositional bundles + +module _ (A : Set a) where + + ⟶-id : A ⟶ A + ⟶-id = function (setoid A) + + ↣-id : A ↣ A + ↣-id = injection (setoid A) + + ↠-id : A ↠ A + ↠-id = surjection (setoid A) + + ⤖-id : A ⤖ A + ⤖-id = bijection (setoid A) + + ⇔-id : A ⇔ A + ⇔-id = equivalence (setoid A) + + ↩-id : A ↩ A + ↩-id = leftInverse (setoid A) + + ↪-id : A ↪ A + ↪-id = rightInverse (setoid A) + + ↔-id : A ↔ A + ↔-id = inverse (setoid A) + + +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version v2.0 + +id-⟶ = ⟶-id +{-# WARNING_ON_USAGE id-⟶ +"Warning: id-⟶ was deprecated in v2.0. Please use ⟶-id instead." -#-} +#-} -id-↣ = ↣-id -{-# WARNING_ON_USAGE id-↣ -"Warning: id-↣ was deprecated in v2.0. +id-↣ = ↣-id +{-# WARNING_ON_USAGE id-↣ +"Warning: id-↣ was deprecated in v2.0. Please use ↣-id instead." -#-} +#-} -id-↠ = ↠-id -{-# WARNING_ON_USAGE id-↠ -"Warning: id-↠ was deprecated in v2.0. +id-↠ = ↠-id +{-# WARNING_ON_USAGE id-↠ +"Warning: id-↠ was deprecated in v2.0. Please use ↠-id instead." -#-} +#-} -id-⤖ = ⤖-id -{-# WARNING_ON_USAGE id-⤖ -"Warning: id-⤖ was deprecated in v2.0. +id-⤖ = ⤖-id +{-# WARNING_ON_USAGE id-⤖ +"Warning: id-⤖ was deprecated in v2.0. Please use ⤖-id instead." -#-} +#-} -id-⇔ = ⇔-id -{-# WARNING_ON_USAGE id-⇔ -"Warning: id-⇔ was deprecated in v2.0. +id-⇔ = ⇔-id +{-# WARNING_ON_USAGE id-⇔ +"Warning: id-⇔ was deprecated in v2.0. Please use ⇔-id instead." -#-} +#-} -id-↩ = ↩-id -{-# WARNING_ON_USAGE id-↩ -"Warning: id-↩ was deprecated in v2.0. +id-↩ = ↩-id +{-# WARNING_ON_USAGE id-↩ +"Warning: id-↩ was deprecated in v2.0. Please use ↩-id instead." -#-} +#-} -id-↪ = ↪-id -{-# WARNING_ON_USAGE id-↪ -"Warning: id-↪ was deprecated in v2.0. +id-↪ = ↪-id +{-# WARNING_ON_USAGE id-↪ +"Warning: id-↪ was deprecated in v2.0. Please use ↪-id instead." -#-} +#-} -id-↔ = ↔-id -{-# WARNING_ON_USAGE id-↔ -"Warning: id-↔ was deprecated in v2.0. +id-↔ = ↔-id +{-# WARNING_ON_USAGE id-↔ +"Warning: id-↔ was deprecated in v2.0. Please use ↔-id instead." -#-} +#-} \ No newline at end of file diff --git a/Function.Construct.Symmetry.html b/Function.Construct.Symmetry.html index c488d8f5..bd00b2c8 100644 --- a/Function.Construct.Symmetry.html +++ b/Function.Construct.Symmetry.html @@ -9,231 +9,239 @@ module Function.Construct.Symmetry where -open import Data.Product using (_,_; swap; proj₁; proj₂) -open import Function -open import Level using (Level) -open import Relation.Binary hiding (_⇔_) -open import Relation.Binary.PropositionalEquality - -private - variable - a b c ℓ₁ ℓ₂ ℓ₃ : Level - A B C : Set a - ------------------------------------------------------------------------- --- Properties - -module _ {≈₁ : Rel A ℓ₁} {≈₂ : Rel B ℓ₂} {f : A → B} - ((inj , surj) : Bijective ≈₁ ≈₂ f) - where - - private - f⁻¹ = proj₁ ∘ surj - f∘f⁻¹≡id = proj₂ ∘ surj - - injective : Symmetric ≈₂ → Transitive ≈₂ → Congruent ≈₁ ≈₂ f → Injective ≈₂ ≈₁ f⁻¹ - injective sym trans cong gx≈gy = trans (trans (sym (f∘f⁻¹≡id _)) (cong gx≈gy)) (f∘f⁻¹≡id _) - - surjective : Surjective ≈₂ ≈₁ f⁻¹ - surjective x = f x , inj (proj₂ (surj (f x))) - - bijective : Symmetric ≈₂ → Transitive ≈₂ → Congruent ≈₁ ≈₂ f → Bijective ≈₂ ≈₁ f⁻¹ - bijective sym trans cong = injective sym trans cong , surjective - -module _ (≈₁ : Rel A ℓ₁) (≈₂ : Rel B ℓ₂) - (f : A → B) {f⁻¹ : B → A} - where - - inverseʳ : Inverseˡ ≈₁ ≈₂ f f⁻¹ → Inverseʳ ≈₂ ≈₁ f⁻¹ f - inverseʳ inv = inv - - inverseˡ : Inverseʳ ≈₁ ≈₂ f f⁻¹ → Inverseˡ ≈₂ ≈₁ f⁻¹ f - inverseˡ inv = inv - - inverseᵇ : Inverseᵇ ≈₁ ≈₂ f f⁻¹ → Inverseᵇ ≈₂ ≈₁ f⁻¹ f - inverseᵇ (invˡ , invʳ) = (invʳ , invˡ) - ------------------------------------------------------------------------- --- Structures - -module _ {≈₁ : Rel A ℓ₁} {≈₂ : Rel B ℓ₂} - {f : A → B} (isBij : IsBijection ≈₁ ≈₂ f) - where - - private - module IB = IsBijection isBij - f⁻¹ = proj₁ ∘ IB.surjective - - -- We can only flip a bijection if the witness produced by the - -- surjection proof respects the equality on the codomain. - isBijection : Congruent ≈₂ ≈₁ f⁻¹ → IsBijection ≈₂ ≈₁ f⁻¹ - isBijection f⁻¹-cong = record - { isInjection = record - { isCongruent = record - { cong = f⁻¹-cong - ; isEquivalence₁ = IB.Eq₂.isEquivalence - ; isEquivalence₂ = IB.Eq₁.isEquivalence - } - ; injective = injective IB.bijective IB.Eq₂.sym IB.Eq₂.trans IB.cong - } - ; surjective = surjective {≈₂ = ≈₂} IB.bijective - } - -module _ {≈₁ : Rel A ℓ₁} {f : A → B} (isBij : IsBijection ≈₁ _≡_ f) where - - -- We can always flip a bijection if using the equality over the - -- codomain is propositional equality. - isBijection-≡ : IsBijection _≡_ ≈₁ _ - isBijection-≡ = isBijection isBij (IB.Eq₁.reflexive ∘ cong _) - where module IB = IsBijection isBij - -module _ {≈₁ : Rel A ℓ₁} {≈₂ : Rel B ℓ₂} - {f : A → B} {f⁻¹ : B → A} - where - - isCongruent : IsCongruent ≈₁ ≈₂ f → Congruent ≈₂ ≈₁ f⁻¹ → IsCongruent ≈₂ ≈₁ f⁻¹ - isCongruent ic cg = record - { cong = cg - ; isEquivalence₁ = IC.isEquivalence₂ - ; isEquivalence₂ = IC.isEquivalence₁ - } where module IC = IsCongruent ic - - isLeftInverse : IsRightInverse ≈₁ ≈₂ f f⁻¹ → IsLeftInverse ≈₂ ≈₁ f⁻¹ f - isLeftInverse inv = record - { isCongruent = isCongruent F.isCongruent F.from-cong - ; from-cong = F.cong₁ - ; inverseˡ = inverseˡ ≈₁ ≈₂ f {f⁻¹} F.inverseʳ - } where module F = IsRightInverse inv - - isRightInverse : IsLeftInverse ≈₁ ≈₂ f f⁻¹ → IsRightInverse ≈₂ ≈₁ f⁻¹ f - isRightInverse inv = record - { isCongruent = isCongruent F.isCongruent F.from-cong - ; from-cong = F.to-cong - ; inverseʳ = inverseʳ ≈₁ ≈₂ f {f⁻¹} F.inverseˡ - } where module F = IsLeftInverse inv - - isInverse : IsInverse ≈₁ ≈₂ f f⁻¹ → IsInverse ≈₂ ≈₁ f⁻¹ f - isInverse f-inv = record - { isLeftInverse = isLeftInverse F.isRightInverse - ; inverseʳ = inverseʳ ≈₁ ≈₂ f F.inverseˡ - } where module F = IsInverse f-inv - ------------------------------------------------------------------------- --- Setoid bundles - -module _ {R : Setoid a ℓ₁} {S : Setoid b ℓ₂} (bij : Bijection R S) where - - private - module IB = Bijection bij - from = proj₁ ∘ IB.surjective - - -- We can only flip a bijection if the witness produced by the - -- surjection proof respects the equality on the codomain. - bijection : Congruent IB.Eq₂._≈_ IB.Eq₁._≈_ from → Bijection S R - bijection cong = record - { to = from - ; cong = cong - ; bijective = bijective IB.bijective IB.Eq₂.sym IB.Eq₂.trans IB.cong - } - --- We can always flip a bijection if using the equality over the --- codomain is propositional equality. -bijection-≡ : {R : Setoid a ℓ₁} {B : Set b} → - Bijection R (setoid B) → Bijection (setoid B) R -bijection-≡ bij = bijection bij (B.Eq₁.reflexive ∘ cong _) - where module B = Bijection bij - -module _ {R : Setoid a ℓ₁} {S : Setoid b ℓ₂} where - - equivalence : Equivalence R S → Equivalence S R - equivalence equiv = record - { to = E.from - ; from = E.to - ; to-cong = E.from-cong - ; from-cong = E.to-cong - } where module E = Equivalence equiv - - rightInverse : LeftInverse R S → RightInverse S R - rightInverse left = record - { to = L.from - ; from = L.to - ; to-cong = L.from-cong - ; from-cong = L.to-cong - ; inverseʳ = L.inverseˡ - } where module L = LeftInverse left - - leftInverse : RightInverse R S → LeftInverse S R - leftInverse right = record - { to = R.from - ; from = R.to - ; to-cong = R.from-cong - ; from-cong = R.to-cong - ; inverseˡ = R.inverseʳ - } where module R = RightInverse right - - inverse : Inverse R S → Inverse S R - inverse inv = record - { to = I.from - ; from = I.to - ; to-cong = I.from-cong - ; from-cong = I.to-cong - ; inverse = swap I.inverse - } where module I = Inverse inv - ------------------------------------------------------------------------- --- Propositional bundles - -⤖-sym : A ⤖ B → B ⤖ A -⤖-sym b = bijection b (cong _) - -⇔-sym : A ⇔ B → B ⇔ A -⇔-sym = equivalence - -↩-sym : A ↩ B → B ↪ A -↩-sym = rightInverse - -↪-sym : A ↪ B → B ↩ A -↪-sym = leftInverse - -↔-sym : A ↔ B → B ↔ A -↔-sym = inverse - - ------------------------------------------------------------------------- --- DEPRECATED NAMES ------------------------------------------------------------------------- --- Please use the new names as continuing support for the old names is --- not guaranteed. - --- Version v2.0 - -sym-⤖ = ⤖-sym -{-# WARNING_ON_USAGE sym-⤖ -"Warning: sym-⤖ was deprecated in v2.0. +open import Data.Product.Base using (_,_; swap; proj₁; proj₂) +open import Function.Base using (_∘_) +open import Function.Definitions + using (Bijective; Injective; Surjective; Inverseˡ; Inverseʳ; Inverseᵇ; Congruent) +open import Function.Structures + using (IsBijection; IsCongruent; IsRightInverse; IsLeftInverse; IsInverse) +open import Function.Bundles + using (Bijection; Equivalence; LeftInverse; RightInverse; Inverse; _⤖_; _⇔_; _↩_; _↪_; _↔_) +open import Level using (Level) +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Definitions using (Reflexive; Symmetric; Transitive) +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Binary.PropositionalEquality + using (_≡_; cong; setoid) + +private + variable + a b c ℓ₁ ℓ₂ ℓ₃ : Level + A B C : Set a + +------------------------------------------------------------------------ +-- Properties + +module _ {≈₁ : Rel A ℓ₁} {≈₂ : Rel B ℓ₂} {f : A → B} + ((inj , surj) : Bijective ≈₁ ≈₂ f) + where + + private + f⁻¹ = proj₁ ∘ surj + f∘f⁻¹≡id = proj₂ ∘ surj + + injective : Reflexive ≈₁ → Symmetric ≈₂ → Transitive ≈₂ → + Congruent ≈₁ ≈₂ f → Injective ≈₂ ≈₁ f⁻¹ + injective refl sym trans cong gx≈gy = + trans (trans (sym (f∘f⁻¹≡id _ refl)) (cong gx≈gy)) (f∘f⁻¹≡id _ refl) + + surjective : Reflexive ≈₁ → Transitive ≈₂ → Surjective ≈₂ ≈₁ f⁻¹ + surjective refl trans x = f x , inj ∘ trans (f∘f⁻¹≡id _ refl) + + bijective : Reflexive ≈₁ → Symmetric ≈₂ → Transitive ≈₂ → + Congruent ≈₁ ≈₂ f → Bijective ≈₂ ≈₁ f⁻¹ + bijective refl sym trans cong = injective refl sym trans cong , surjective refl trans + +module _ (≈₁ : Rel A ℓ₁) (≈₂ : Rel B ℓ₂) {f : A → B} {f⁻¹ : B → A} where + + inverseʳ : Inverseˡ ≈₁ ≈₂ f f⁻¹ → Inverseʳ ≈₂ ≈₁ f⁻¹ f + inverseʳ inv = inv + + inverseˡ : Inverseʳ ≈₁ ≈₂ f f⁻¹ → Inverseˡ ≈₂ ≈₁ f⁻¹ f + inverseˡ inv = inv + + inverseᵇ : Inverseᵇ ≈₁ ≈₂ f f⁻¹ → Inverseᵇ ≈₂ ≈₁ f⁻¹ f + inverseᵇ (invˡ , invʳ) = (invʳ , invˡ) + +------------------------------------------------------------------------ +-- Structures + +module _ {≈₁ : Rel A ℓ₁} {≈₂ : Rel B ℓ₂} + {f : A → B} (isBij : IsBijection ≈₁ ≈₂ f) + where + + private + module IB = IsBijection isBij + f⁻¹ = proj₁ ∘ IB.surjective + + -- We can only flip a bijection if the witness produced by the + -- surjection proof respects the equality on the codomain. + isBijection : Congruent ≈₂ ≈₁ f⁻¹ → IsBijection ≈₂ ≈₁ f⁻¹ + isBijection f⁻¹-cong = record + { isInjection = record + { isCongruent = record + { cong = f⁻¹-cong + ; isEquivalence₁ = IB.Eq₂.isEquivalence + ; isEquivalence₂ = IB.Eq₁.isEquivalence + } + ; injective = injective IB.bijective IB.Eq₁.refl IB.Eq₂.sym IB.Eq₂.trans IB.cong + } + ; surjective = surjective IB.bijective IB.Eq₁.refl IB.Eq₂.trans + } + +module _ {≈₁ : Rel A ℓ₁} {f : A → B} (isBij : IsBijection ≈₁ _≡_ f) where + + -- We can always flip a bijection if using the equality over the + -- codomain is propositional equality. + isBijection-≡ : IsBijection _≡_ ≈₁ _ + isBijection-≡ = isBijection isBij (IB.Eq₁.reflexive ∘ cong _) + where module IB = IsBijection isBij + +module _ {≈₁ : Rel A ℓ₁} {≈₂ : Rel B ℓ₂} {f : A → B} {f⁻¹ : B → A} where + + isCongruent : IsCongruent ≈₁ ≈₂ f → Congruent ≈₂ ≈₁ f⁻¹ → IsCongruent ≈₂ ≈₁ f⁻¹ + isCongruent ic cg = record + { cong = cg + ; isEquivalence₁ = F.isEquivalence₂ + ; isEquivalence₂ = F.isEquivalence₁ + } where module F = IsCongruent ic + + isLeftInverse : IsRightInverse ≈₁ ≈₂ f f⁻¹ → IsLeftInverse ≈₂ ≈₁ f⁻¹ f + isLeftInverse inv = record + { isCongruent = isCongruent F.isCongruent F.from-cong + ; from-cong = F.to-cong + ; inverseˡ = inverseˡ ≈₁ ≈₂ F.inverseʳ + } where module F = IsRightInverse inv + + isRightInverse : IsLeftInverse ≈₁ ≈₂ f f⁻¹ → IsRightInverse ≈₂ ≈₁ f⁻¹ f + isRightInverse inv = record + { isCongruent = isCongruent F.isCongruent F.from-cong + ; from-cong = F.to-cong + ; inverseʳ = inverseʳ ≈₁ ≈₂ F.inverseˡ + } where module F = IsLeftInverse inv + + isInverse : IsInverse ≈₁ ≈₂ f f⁻¹ → IsInverse ≈₂ ≈₁ f⁻¹ f + isInverse f-inv = record + { isLeftInverse = isLeftInverse F.isRightInverse + ; inverseʳ = inverseʳ ≈₁ ≈₂ F.inverseˡ + } where module F = IsInverse f-inv + +------------------------------------------------------------------------ +-- Setoid bundles + +module _ {R : Setoid a ℓ₁} {S : Setoid b ℓ₂} (bij : Bijection R S) where + + private + module IB = Bijection bij + from = proj₁ ∘ IB.surjective + + -- We can only flip a bijection if the witness produced by the + -- surjection proof respects the equality on the codomain. + bijection : Congruent IB.Eq₂._≈_ IB.Eq₁._≈_ from → Bijection S R + bijection cong = record + { to = from + ; cong = cong + ; bijective = bijective IB.bijective IB.Eq₁.refl IB.Eq₂.sym IB.Eq₂.trans IB.cong + } + +-- We can always flip a bijection if using the equality over the +-- codomain is propositional equality. +bijection-≡ : {R : Setoid a ℓ₁} {B : Set b} → + Bijection R (setoid B) → Bijection (setoid B) R +bijection-≡ bij = bijection bij (B.Eq₁.reflexive ∘ cong _) + where module B = Bijection bij + +module _ {R : Setoid a ℓ₁} {S : Setoid b ℓ₂} where + + equivalence : Equivalence R S → Equivalence S R + equivalence equiv = record + { to = E.from + ; from = E.to + ; to-cong = E.from-cong + ; from-cong = E.to-cong + } where module E = Equivalence equiv + + rightInverse : LeftInverse R S → RightInverse S R + rightInverse left = record + { to = L.from + ; from = L.to + ; to-cong = L.from-cong + ; from-cong = L.to-cong + ; inverseʳ = L.inverseˡ + } where module L = LeftInverse left + + leftInverse : RightInverse R S → LeftInverse S R + leftInverse right = record + { to = R.from + ; from = R.to + ; to-cong = R.from-cong + ; from-cong = R.to-cong + ; inverseˡ = R.inverseʳ + } where module R = RightInverse right + + inverse : Inverse R S → Inverse S R + inverse inv = record + { to = I.from + ; from = I.to + ; to-cong = I.from-cong + ; from-cong = I.to-cong + ; inverse = swap I.inverse + } where module I = Inverse inv + +------------------------------------------------------------------------ +-- Propositional bundles + +⤖-sym : A ⤖ B → B ⤖ A +⤖-sym b = bijection b (cong _) + +⇔-sym : A ⇔ B → B ⇔ A +⇔-sym = equivalence + +↩-sym : A ↩ B → B ↪ A +↩-sym = rightInverse + +↪-sym : A ↪ B → B ↩ A +↪-sym = leftInverse + +↔-sym : A ↔ B → B ↔ A +↔-sym = inverse + + +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version v2.0 + +sym-⤖ = ⤖-sym +{-# WARNING_ON_USAGE sym-⤖ +"Warning: sym-⤖ was deprecated in v2.0. Please use ⤖-sym instead." -#-} +#-} -sym-⇔ = ⇔-sym -{-# WARNING_ON_USAGE sym-⇔ -"Warning: sym-⇔ was deprecated in v2.0. +sym-⇔ = ⇔-sym +{-# WARNING_ON_USAGE sym-⇔ +"Warning: sym-⇔ was deprecated in v2.0. Please use ⇔-sym instead." -#-} +#-} -sym-↩ = ↩-sym -{-# WARNING_ON_USAGE sym-↩ -"Warning: sym-↩ was deprecated in v2.0. +sym-↩ = ↩-sym +{-# WARNING_ON_USAGE sym-↩ +"Warning: sym-↩ was deprecated in v2.0. Please use ↩-sym instead." -#-} +#-} -sym-↪ = ↪-sym -{-# WARNING_ON_USAGE sym-↪ -"Warning: sym-↪ was deprecated in v2.0. +sym-↪ = ↪-sym +{-# WARNING_ON_USAGE sym-↪ +"Warning: sym-↪ was deprecated in v2.0. Please use ↪-sym instead." -#-} +#-} -sym-↔ = ↔-sym -{-# WARNING_ON_USAGE sym-↔ -"Warning: sym-↔ was deprecated in v2.0. +sym-↔ = ↔-sym +{-# WARNING_ON_USAGE sym-↔ +"Warning: sym-↔ was deprecated in v2.0. Please use ↔-sym instead." -#-} +#-} \ No newline at end of file diff --git a/Function.Definitions.Core1.html b/Function.Definitions.Core1.html deleted file mode 100644 index 20694ae6..00000000 --- a/Function.Definitions.Core1.html +++ /dev/null @@ -1,27 +0,0 @@ - -Function.Definitions.Core1
------------------------------------------------------------------------
--- The Agda standard library
---
--- Definitions for types of functions that only require an equality
--- relation over the domain.
-------------------------------------------------------------------------
-
--- The contents of this file should usually be accessed from `Function`.
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-open import Relation.Binary
-
-module Function.Definitions.Core1
-  {a b ℓ₁} {A : Set a} {B : Set b} (_≈₁_ : Rel A ℓ₁)
-  where
-
-open import Level using (_⊔_)
-
-------------------------------------------------------------------------
--- Definitions
-
--- (Note the name `RightInverse` is used for the bundle)
-Inverseʳ : (A → B) → (B → A) → Set (a ⊔ ℓ₁)
-Inverseʳ f g = ∀ x → g (f x) ≈₁ x
-
\ No newline at end of file diff --git a/Function.Definitions.Core2.html b/Function.Definitions.Core2.html deleted file mode 100644 index 4a94f24e..00000000 --- a/Function.Definitions.Core2.html +++ /dev/null @@ -1,31 +0,0 @@ - -Function.Definitions.Core2
------------------------------------------------------------------------
--- The Agda standard library
---
--- Definitions for types of functions that only require an equality
--- relation over the co-domain.
-------------------------------------------------------------------------
-
--- The contents of this file should usually be accessed from `Function`.
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-open import Relation.Binary
-
-module Function.Definitions.Core2
-  {a b ℓ₂} {A : Set a} {B : Set b} (_≈₂_ : Rel B ℓ₂)
-  where
-
-open import Data.Product using (∃)
-open import Level using (Level; _⊔_)
-
-------------------------------------------------------------------------
--- Definitions
-
-Surjective : (A → B) → Set (a ⊔ b ⊔ ℓ₂)
-Surjective f = ∀ y → ∃ λ x → f x ≈₂ y
-
--- (Note the name `LeftInverse` is used for the bundle)
-Inverseˡ : (A → B) → (B → A) → Set (b ⊔ ℓ₂)
-Inverseˡ f g = ∀ x → f (g x) ≈₂ x
-
\ No newline at end of file diff --git a/Function.Definitions.html b/Function.Definitions.html index 2d256362..9e0b0fdf 100644 --- a/Function.Definitions.html +++ b/Function.Definitions.html @@ -9,41 +9,58 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary +module Function.Definitions where -module Function.Definitions - {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b} - (_≈₁_ : Rel A ℓ₁) -- Equality over the domain - (_≈₂_ : Rel B ℓ₂) -- Equality over the codomain - where +open import Data.Product.Base using (∃; _×_) +open import Level using (Level) +open import Relation.Binary.Core using (Rel) -open import Data.Product using (∃; _×_) -import Function.Definitions.Core1 as Core₁ -import Function.Definitions.Core2 as Core₂ -open import Function.Base -open import Level using (_⊔_) +private + variable + a ℓ₁ ℓ₂ : Level + A B : Set a ------------------------------------------------------------------------- --- Definitions +------------------------------------------------------------------------ +-- Basic definitions -Congruent : (A → B) → Set (a ⊔ ℓ₁ ⊔ ℓ₂) -Congruent f = ∀ {x y} → x ≈₁ y → f x ≈₂ f y +module _ + (_≈₁_ : Rel A ℓ₁) -- Equality over the domain + (_≈₂_ : Rel B ℓ₂) -- Equality over the codomain + where -Injective : (A → B) → Set (a ⊔ ℓ₁ ⊔ ℓ₂) -Injective f = ∀ {x y} → f x ≈₂ f y → x ≈₁ y + Congruent : (A → B) → Set _ + Congruent f = ∀ {x y} → x ≈₁ y → f x ≈₂ f y -open Core₂ {A = A} _≈₂_ public - using (Surjective) + Injective : (A → B) → Set _ + Injective f = ∀ {x y} → f x ≈₂ f y → x ≈₁ y -Bijective : (A → B) → Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) -Bijective f = Injective f × Surjective f + Surjective : (A → B) → Set _ + Surjective f = ∀ y → ∃ λ x → ∀ {z} → z ≈₁ x → f z ≈₂ y -open Core₂ {A = A} _≈₂_ public - using (Inverseˡ) + Bijective : (A → B) → Set _ + Bijective f = Injective f × Surjective f -open Core₁ {B = B} _≈₁_ public - using (Inverseʳ) + Inverseˡ : (A → B) → (B → A) → Set _ + Inverseˡ f g = ∀ {x y} → y ≈₁ g x → f y ≈₂ x -Inverseᵇ : (A → B) → (B → A) → Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) -Inverseᵇ f g = Inverseˡ f g × Inverseʳ f g + Inverseʳ : (A → B) → (B → A) → Set _ + Inverseʳ f g = ∀ {x y} → y ≈₂ f x → g y ≈₁ x + + Inverseᵇ : (A → B) → (B → A) → Set _ + Inverseᵇ f g = Inverseˡ f g × Inverseʳ f g + +------------------------------------------------------------------------ +-- Strict definitions + +-- These are often easier to use once but much harder to compose and +-- reason about. + +StrictlySurjective : Rel B ℓ₂ → (A → B) → Set _ +StrictlySurjective _≈₂_ f = ∀ y → ∃ λ x → f x ≈₂ y + +StrictlyInverseˡ : Rel B ℓ₂ → (A → B) → (B → A) → Set _ +StrictlyInverseˡ _≈₂_ f g = ∀ y → f (g y) ≈₂ y + +StrictlyInverseʳ : Rel A ℓ₁ → (A → B) → (B → A) → Set _ +StrictlyInverseʳ _≈₁_ f g = ∀ x → g (f x) ≈₁ x \ No newline at end of file diff --git a/Function.Dependent.Bundles.html b/Function.Dependent.Bundles.html new file mode 100644 index 00000000..3503d395 --- /dev/null +++ b/Function.Dependent.Bundles.html @@ -0,0 +1,52 @@ + +Function.Dependent.Bundles
------------------------------------------------------------------------
+-- The Agda standard library
+--
+-- Bundles for types of functions
+------------------------------------------------------------------------
+
+-- The contents of this file should usually be accessed from `Function`.
+
+-- Note that these bundles differ from those found elsewhere in other
+-- library hierarchies as they take Setoids as parameters. This is
+-- because a function is of no use without knowing what its domain and
+-- codomain is, as well which equalities are being considered over them.
+-- One consequence of this is that they are not built from the
+-- definitions found in `Function.Structures` as is usually the case in
+-- other library hierarchies, as this would duplicate the equality
+-- axioms.
+
+{-# OPTIONS --cubical-compatible --safe #-}
+
+module Function.Dependent.Bundles where
+
+open import Level using (Level; _⊔_)
+open import Relation.Binary.Bundles using (Setoid)
+open import Relation.Binary.Indexed.Heterogeneous using (IndexedSetoid)
+
+private
+  variable
+    a b ℓ₁ ℓ₂ : Level
+
+------------------------------------------------------------------------
+-- Setoid bundles
+------------------------------------------------------------------------
+
+module _
+  (From : Setoid a ℓ₁)
+  (To : IndexedSetoid (Setoid.Carrier From) b ℓ₂)
+  where
+
+  open Setoid From using () renaming (Carrier to A; _≈_ to _≈₁_)
+  open IndexedSetoid To using () renaming (Carrier to B; _≈_ to _≈₂_)
+
+------------------------------------------------------------------------
+-- Bundles with one element
+
+  -- Called `Func` rather than `Function` in order to avoid clashing
+  -- with the top-level module.
+  record Func : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
+    field
+      to   : (x : A) → B x
+      cong : ∀ {x y} → x ≈₁ y → to x ≈₂ to y
+
\ No newline at end of file diff --git a/Function.Equality.html b/Function.Equality.html deleted file mode 100644 index 8ba9dc80..00000000 --- a/Function.Equality.html +++ /dev/null @@ -1,126 +0,0 @@ - -Function.Equality
------------------------------------------------------------------------
--- The Agda standard library
---
--- Function setoids and related constructions
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
--- Note: use of the standard function hierarchy is encouraged. The
--- module `Function` re-exports `Congruent`, `IsBijection` and
--- `Bijection`. The alternative definitions found in this file will
--- eventually be deprecated.
-
-module Function.Equality where
-
-import Function.Base as Fun
-open import Level
-open import Relation.Binary using (Setoid)
-open import Relation.Binary.Indexed.Heterogeneous
-  using (IndexedSetoid; _=[_]⇒_)
-import Relation.Binary.Indexed.Heterogeneous.Construct.Trivial
-  as Trivial
-
-------------------------------------------------------------------------
--- Functions which preserve equality
-
-record Π {f₁ f₂ t₁ t₂}
-         (From : Setoid f₁ f₂)
-         (To : IndexedSetoid (Setoid.Carrier From) t₁ t₂) :
-         Set (f₁ ⊔ f₂ ⊔ t₁ ⊔ t₂) where
-  infixl 5 _⟨$⟩_
-  field
-    _⟨$⟩_ : (x : Setoid.Carrier From) → IndexedSetoid.Carrier To x
-    cong  : Setoid._≈_ From =[ _⟨$⟩_ ]⇒ IndexedSetoid._≈_ To
-
-open Π public
-
-infixr 0 _⟶_
-
-_⟶_ : ∀ {f₁ f₂ t₁ t₂} → Setoid f₁ f₂ → Setoid t₁ t₂ → Set _
-From ⟶ To = Π From (Trivial.indexedSetoid To)
-
-------------------------------------------------------------------------
--- Identity and composition.
-
-id : ∀ {a₁ a₂} {A : Setoid a₁ a₂} → A ⟶ A
-id = record { _⟨$⟩_ = Fun.id; cong = Fun.id }
-
-infixr 9 _∘_
-
-_∘_ : ∀ {a₁ a₂} {A : Setoid a₁ a₂}
-        {b₁ b₂} {B : Setoid b₁ b₂}
-        {c₁ c₂} {C : Setoid c₁ c₂} →
-      B ⟶ C → A ⟶ B → A ⟶ C
-f ∘ g = record
-  { _⟨$⟩_ = Fun._∘_ (_⟨$⟩_ f) (_⟨$⟩_ g)
-  ; cong  = Fun._∘_ (cong  f) (cong  g)
-  }
-
--- Constant equality-preserving function.
-
-const : ∀ {a₁ a₂} {A : Setoid a₁ a₂}
-          {b₁ b₂} {B : Setoid b₁ b₂} →
-        Setoid.Carrier B → A ⟶ B
-const {B = B} b = record
-  { _⟨$⟩_ = Fun.const b
-  ; cong  = Fun.const (Setoid.refl B)
-  }
-
-------------------------------------------------------------------------
--- Function setoids
-
--- Dependent.
-
-setoid : ∀ {f₁ f₂ t₁ t₂}
-         (From : Setoid f₁ f₂) →
-         IndexedSetoid (Setoid.Carrier From) t₁ t₂ →
-         Setoid _ _
-setoid From To = record
-  { Carrier       = Π From To
-  ; _≈_           = λ f g → ∀ {x y} → x ≈₁ y → f ⟨$⟩ x ≈₂ g ⟨$⟩ y
-  ; isEquivalence = record
-    { refl  = λ {f} → cong f
-    ; sym   = λ f∼g x∼y → To.sym (f∼g (From.sym x∼y))
-    ; trans = λ f∼g g∼h x∼y → To.trans (f∼g From.refl) (g∼h x∼y)
-    }
-  }
-  where
-  open module From = Setoid From using () renaming (_≈_ to _≈₁_)
-  open module To = IndexedSetoid To   using () renaming (_≈_ to _≈₂_)
-
--- Non-dependent.
-
-infixr 0 _⇨_
-
-_⇨_ : ∀ {f₁ f₂ t₁ t₂} → Setoid f₁ f₂ → Setoid t₁ t₂ → Setoid _ _
-From ⇨ To = setoid From (Trivial.indexedSetoid To)
-
--- A variant of setoid which uses the propositional equality setoid
--- for the domain, and a more convenient definition of _≈_.
-
-≡-setoid : ∀ {f t₁ t₂} (From : Set f) → IndexedSetoid From t₁ t₂ → Setoid _ _
-≡-setoid From To = record
-  { Carrier       = (x : From) → Carrier x
-  ; _≈_           = λ f g → ∀ x → f x ≈ g x
-  ; isEquivalence = record
-    { refl  = λ {f} x → refl
-    ; sym   = λ f∼g x → sym (f∼g x)
-    ; trans = λ f∼g g∼h x → trans (f∼g x) (g∼h x)
-    }
-  } where open IndexedSetoid To
-
--- Parameter swapping function.
-
-flip : ∀ {a₁ a₂} {A : Setoid a₁ a₂}
-         {b₁ b₂} {B : Setoid b₁ b₂}
-         {c₁ c₂} {C : Setoid c₁ c₂} →
-       A ⟶ B ⇨ C → B ⟶ A ⇨ C
-flip {B = B} f = record
-  { _⟨$⟩_ = λ b → record
-    { _⟨$⟩_ = λ a → f ⟨$⟩ a ⟨$⟩ b
-    ; cong  = λ a₁≈a₂ → cong f a₁≈a₂ (Setoid.refl B) }
-  ; cong  = λ b₁≈b₂ a₁≈a₂ → cong f a₁≈a₂ b₁≈b₂
-  }
-
\ No newline at end of file diff --git a/Function.Equivalence.html b/Function.Equivalence.html deleted file mode 100644 index 41ef89e0..00000000 --- a/Function.Equivalence.html +++ /dev/null @@ -1,130 +0,0 @@ - -Function.Equivalence
------------------------------------------------------------------------
--- The Agda standard library
---
--- Equivalence (coinhabitance)
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-module Function.Equivalence where
-
--- Note: use of the standard function hierarchy is encouraged. The
--- module `Function` re-exports `Congruent` and `IsCongruent`.
--- The alternative definitions found in this file will eventually be
--- deprecated.
-
-open import Function.Base using (flip)
-open import Function.Equality as F
-  using (_⟶_; _⟨$⟩_) renaming (_∘_ to _⟪∘⟫_)
-open import Level
-open import Relation.Binary hiding (_⇔_)
-import Relation.Binary.PropositionalEquality as P
-
-------------------------------------------------------------------------
--- Setoid equivalence
-
-record Equivalence {f₁ f₂ t₁ t₂}
-                   (From : Setoid f₁ f₂) (To : Setoid t₁ t₂) :
-                   Set (f₁ ⊔ f₂ ⊔ t₁ ⊔ t₂) where
-  field
-    to   : From ⟶ To
-    from : To ⟶ From
-
-------------------------------------------------------------------------
--- The set of all equivalences between two sets (i.e. equivalences
--- with propositional equality)
-
-infix 3 _⇔_
-
-_⇔_ : ∀ {f t} → Set f → Set t → Set _
-From ⇔ To = Equivalence (P.setoid From) (P.setoid To)
-
-equivalence : ∀ {f t} {From : Set f} {To : Set t} →
-              (From → To) → (To → From) → From ⇔ To
-equivalence to from = record
-  { to   = P.→-to-⟶ to
-  ; from = P.→-to-⟶ from
-  }
-
-------------------------------------------------------------------------
--- Equivalence is an equivalence relation
-
--- Identity and composition (reflexivity and transitivity).
-
-id : ∀ {s₁ s₂} → Reflexive (Equivalence {s₁} {s₂})
-id {x = S} = record
-  { to   = F.id
-  ; from = F.id
-  }
-
-infixr 9 _∘_
-
-_∘_ : ∀ {f₁ f₂ m₁ m₂ t₁ t₂} →
-      TransFlip (Equivalence {f₁} {f₂} {m₁} {m₂})
-                (Equivalence {m₁} {m₂} {t₁} {t₂})
-                (Equivalence {f₁} {f₂} {t₁} {t₂})
-f ∘ g = record
-  { to   = to   f ⟪∘⟫ to   g
-  ; from = from g ⟪∘⟫ from f
-  } where open Equivalence
-
--- Symmetry.
-
-sym : ∀ {f₁ f₂ t₁ t₂} →
-      Sym (Equivalence {f₁} {f₂} {t₁} {t₂})
-          (Equivalence {t₁} {t₂} {f₁} {f₂})
-sym eq = record
-  { from       = to
-  ; to         = from
-  } where open Equivalence eq
-
--- For fixed universe levels we can construct setoids.
-
-setoid : (s₁ s₂ : Level) → Setoid (suc (s₁ ⊔ s₂)) (s₁ ⊔ s₂)
-setoid s₁ s₂ = record
-  { Carrier       = Setoid s₁ s₂
-  ; _≈_           = Equivalence
-  ; isEquivalence = record
-    { refl  = id
-    ; sym   = sym
-    ; trans = flip _∘_
-    }
-  }
-
-⇔-setoid : (ℓ : Level) → Setoid (suc ℓ) ℓ
-⇔-setoid ℓ = record
-  { Carrier       = Set ℓ
-  ; _≈_           = _⇔_
-  ; isEquivalence = record
-    { refl  = id
-    ; sym   = sym
-    ; trans = flip _∘_
-    }
-  }
-
-------------------------------------------------------------------------
--- Transformations
-
-map : ∀ {f₁ f₂ t₁ t₂} {From : Setoid f₁ f₂} {To : Setoid t₁ t₂}
-        {f₁′ f₂′ t₁′ t₂′}
-        {From′ : Setoid f₁′ f₂′} {To′ : Setoid t₁′ t₂′} →
-      ((From ⟶ To) → (From′ ⟶ To′)) →
-      ((To ⟶ From) → (To′ ⟶ From′)) →
-      Equivalence From To → Equivalence From′ To′
-map t f eq = record { to = t to; from = f from }
-  where open Equivalence eq
-
-zip : ∀ {f₁₁ f₂₁ t₁₁ t₂₁}
-        {From₁ : Setoid f₁₁ f₂₁} {To₁ : Setoid t₁₁ t₂₁}
-        {f₁₂ f₂₂ t₁₂ t₂₂}
-        {From₂ : Setoid f₁₂ f₂₂} {To₂ : Setoid t₁₂ t₂₂}
-        {f₁ f₂ t₁ t₂} {From : Setoid f₁ f₂} {To : Setoid t₁ t₂} →
-      ((From₁ ⟶ To₁) → (From₂ ⟶ To₂) → (From ⟶ To)) →
-      ((To₁ ⟶ From₁) → (To₂ ⟶ From₂) → (To ⟶ From)) →
-      Equivalence From₁ To₁ → Equivalence From₂ To₂ →
-      Equivalence From To
-zip t f eq₁ eq₂ =
-  record { to = t (to eq₁) (to eq₂); from = f (from eq₁) (from eq₂) }
-  where open Equivalence
-
\ No newline at end of file diff --git a/Function.HalfAdjointEquivalence.html b/Function.HalfAdjointEquivalence.html deleted file mode 100644 index c4c114f4..00000000 --- a/Function.HalfAdjointEquivalence.html +++ /dev/null @@ -1,115 +0,0 @@ - -Function.HalfAdjointEquivalence
------------------------------------------------------------------------
--- The Agda standard library
---
--- Half adjoint equivalences
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-module Function.HalfAdjointEquivalence where
-
-open import Function.Base
-open import Function.Equality using (_⟨$⟩_)
-open import Function.Inverse as Inv using (_↔_; module Inverse)
-open import Level
-open import Relation.Binary.PropositionalEquality
-
--- Half adjoint equivalences (see the HoTT book).
-
-record _≃_ {a b} (A : Set a) (B : Set b) : Set (a ⊔ b) where
-  field
-    to               : A → B
-    from             : B → A
-    left-inverse-of  : ∀ x → from (to x) ≡ x
-    right-inverse-of : ∀ x → to (from x) ≡ x
-    left-right       :
-      ∀ x → cong to (left-inverse-of x) ≡ right-inverse-of (to x)
-
-  -- Half adjoint equivalences can be turned into inverses.
-
-  inverse : A ↔ B
-  inverse = Inv.inverse to from left-inverse-of right-inverse-of
-
-  -- The forward direction of a half adjoint equivalence is injective.
-
-  injective : ∀ {x y} → to x ≡ to y → x ≡ y
-  injective {x} {y} to-x≡to-y =
-    x            ≡⟨ sym (left-inverse-of _) ⟩
-    from (to x)  ≡⟨ cong from to-x≡to-y ⟩
-    from (to y)  ≡⟨ left-inverse-of _ ⟩
-    y            ∎
-    where
-    open ≡-Reasoning
-
--- Inverses can be turned into half adjoint equivalences.
---
--- (This proof is based on one in the HoTT book.)
-
-↔→≃ : ∀ {a b} {A : Set a} {B : Set b} → A ↔ B → A ≃ B
-↔→≃ A↔B = record
-  { to               = to   ⟨$⟩_
-  ; from             = from ⟨$⟩_
-  ; left-inverse-of  = left-inverse-of
-  ; right-inverse-of = right-inverse-of
-  ; left-right       = left-right
-  }
-  where
-  open ≡-Reasoning
-  open module A↔B = Inverse A↔B using (to; from; left-inverse-of)
-
-  right-inverse-of : ∀ x → to ⟨$⟩ (from ⟨$⟩ x) ≡ x
-  right-inverse-of x =
-    to ⟨$⟩ (from ⟨$⟩ x)                      ≡⟨ sym (A↔B.right-inverse-of _) ⟩
-    to ⟨$⟩ (from ⟨$⟩ (to ⟨$⟩ (from ⟨$⟩ x)))  ≡⟨ cong (to ⟨$⟩_) (left-inverse-of _) ⟩
-    to ⟨$⟩ (from ⟨$⟩ x)                      ≡⟨ A↔B.right-inverse-of _ ⟩
-    x                                        ∎
-
-  left-right :
-    ∀ x →
-    cong (to ⟨$⟩_) (left-inverse-of x) ≡ right-inverse-of (to ⟨$⟩ x)
-  left-right x =
-    cong (to ⟨$⟩_) (left-inverse-of x)               ≡⟨⟩
-
-    trans refl (cong (to ⟨$⟩_) (left-inverse-of _))  ≡⟨ cong (λ p → trans p (cong (to ⟨$⟩_) _))
-                                                          (sym (trans-symˡ (A↔B.right-inverse-of _))) ⟩
-    trans (trans (sym (A↔B.right-inverse-of _))
-               (A↔B.right-inverse-of _))
-      (cong (to ⟨$⟩_) (left-inverse-of _))           ≡⟨ trans-assoc (sym (A↔B.right-inverse-of _)) ⟩
-
-    trans (sym (A↔B.right-inverse-of _))
-      (trans (A↔B.right-inverse-of _)
-         (cong (to ⟨$⟩_) (left-inverse-of _)))       ≡⟨ cong (trans (sym (A↔B.right-inverse-of _))) lemma ⟩
-
-    trans (sym (A↔B.right-inverse-of _))
-      (trans (cong (to ⟨$⟩_) (left-inverse-of _))
-         (trans (A↔B.right-inverse-of _) refl))      ≡⟨⟩
-
-    right-inverse-of (to ⟨$⟩ x)                      ∎
-    where
-    lemma =
-      trans (A↔B.right-inverse-of _)
-        (cong (to ⟨$⟩_) (left-inverse-of _))             ≡⟨ cong (trans (A↔B.right-inverse-of _)) (sym (cong-id _)) ⟩
-
-      trans (A↔B.right-inverse-of _)
-        (cong id (cong (to ⟨$⟩_) (left-inverse-of _)))   ≡⟨ sym (naturality A↔B.right-inverse-of) ⟩
-
-      trans (cong ((to ⟨$⟩_) ∘ (from ⟨$⟩_))
-                 (cong (to ⟨$⟩_) (left-inverse-of _)))
-        (A↔B.right-inverse-of _)                         ≡⟨ cong (λ p → trans p (A↔B.right-inverse-of _))
-                                                              (sym (cong-∘ _)) ⟩
-      trans (cong ((to ⟨$⟩_) ∘ (from ⟨$⟩_) ∘ (to ⟨$⟩_))
-                      (left-inverse-of _))
-        (A↔B.right-inverse-of _)                         ≡⟨ cong (λ p → trans p (A↔B.right-inverse-of _))
-                                                              (cong-∘ _) ⟩
-      trans (cong (to ⟨$⟩_)
-                 (cong ((from ⟨$⟩_) ∘ (to ⟨$⟩_))
-                    (left-inverse-of _)))
-        (A↔B.right-inverse-of _)                         ≡⟨ cong (λ p → trans (cong (to ⟨$⟩_) p) _)
-                                                              (cong-≡id left-inverse-of) ⟩
-      trans (cong (to ⟨$⟩_) (left-inverse-of _))
-        (A↔B.right-inverse-of _)                         ≡⟨ cong (trans (cong (to ⟨$⟩_) (left-inverse-of _)))
-                                                              (sym (trans-reflʳ _)) ⟩
-      trans (cong (to ⟨$⟩_) (left-inverse-of _))
-        (trans (A↔B.right-inverse-of _) refl)            ∎
-
\ No newline at end of file diff --git a/Function.Indexed.Relation.Binary.Equality.html b/Function.Indexed.Relation.Binary.Equality.html new file mode 100644 index 00000000..4057a27b --- /dev/null +++ b/Function.Indexed.Relation.Binary.Equality.html @@ -0,0 +1,29 @@ + +Function.Indexed.Relation.Binary.Equality
------------------------------------------------------------------------
+-- The Agda standard library
+--
+-- Function setoids and related constructions
+------------------------------------------------------------------------
+
+{-# OPTIONS --cubical-compatible --safe #-}
+
+module Function.Indexed.Relation.Binary.Equality where
+
+open import Relation.Binary using (Setoid)
+open import Relation.Binary.Indexed.Heterogeneous using (IndexedSetoid)
+
+-- A variant of setoid which uses the propositional equality setoid
+-- for the domain, and a more convenient definition of _≈_.
+
+≡-setoid : ∀ {f t₁ t₂} (From : Set f) → IndexedSetoid From t₁ t₂ → Setoid _ _
+≡-setoid From To = record
+  { Carrier       = (x : From) → Carrier x
+  ; _≈_           = λ f g → ∀ x → f x ≈ g x
+  ; isEquivalence = record
+    { refl  = λ {f} x → refl
+    ; sym   = λ f∼g x → sym (f∼g x)
+    ; trans = λ f∼g g∼h x → trans (f∼g x) (g∼h x)
+    }
+  } where open IndexedSetoid To
+
+
\ No newline at end of file diff --git a/Function.Injection.html b/Function.Injection.html deleted file mode 100644 index c7821b65..00000000 --- a/Function.Injection.html +++ /dev/null @@ -1,80 +0,0 @@ - -Function.Injection
------------------------------------------------------------------------
--- The Agda standard library
---
--- Injections
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
--- Note: use of the standard function hierarchy is encouraged. The
--- module `Function` re-exports `Injective`, `IsInjection` and
--- `Injection`. The alternative definitions found in this file will
--- eventually be deprecated.
-
-module Function.Injection where
-
-open import Function as Fun using () renaming (_∘_ to _⟨∘⟩_)
-open import Level
-open import Relation.Binary
-open import Function.Equality as F
-  using (_⟶_; _⟨$⟩_ ; Π) renaming (_∘_ to _⟪∘⟫_)
-open import Relation.Binary.PropositionalEquality as P using (_≡_)
-
-------------------------------------------------------------------------
--- Injective functions
-
-Injective : ∀ {a₁ a₂ b₁ b₂} {A : Setoid a₁ a₂} {B : Setoid b₁ b₂} →
-            A ⟶ B → Set _
-Injective {A = A} {B} f = ∀ {x y} → f ⟨$⟩ x ≈₂ f ⟨$⟩ y → x ≈₁ y
-  where
-  open Setoid A renaming (_≈_ to _≈₁_)
-  open Setoid B renaming (_≈_ to _≈₂_)
-
-------------------------------------------------------------------------
--- The set of all injections between two setoids
-
-record Injection {f₁ f₂ t₁ t₂}
-                 (From : Setoid f₁ f₂) (To : Setoid t₁ t₂) :
-                 Set (f₁ ⊔ f₂ ⊔ t₁ ⊔ t₂) where
-  field
-    to        : From ⟶ To
-    injective : Injective to
-
-  open Π to public
-
-------------------------------------------------------------------------
--- The set of all injections from one set to another (i.e. injections
--- with propositional equality)
-
-infix 3 _↣_
-
-_↣_ : ∀ {f t} → Set f → Set t → Set _
-From ↣ To = Injection (P.setoid From) (P.setoid To)
-
-injection : ∀ {f t} {From : Set f} {To : Set t} → (to : From → To) →
-            (∀ {x y} → to x ≡ to y → x ≡ y) → From ↣ To
-injection to injective = record
-  { to        = P.→-to-⟶ to
-  ; injective = injective
-  }
-
-------------------------------------------------------------------------
--- Identity and composition.
-
-infixr 9 _∘_
-
-id : ∀ {s₁ s₂} {S : Setoid s₁ s₂} → Injection S S
-id = record
-  { to        = F.id
-  ; injective = Fun.id
-  }
-
-_∘_ : ∀ {f₁ f₂ m₁ m₂ t₁ t₂}
-        {F : Setoid f₁ f₂} {M : Setoid m₁ m₂} {T : Setoid t₁ t₂} →
-      Injection M T → Injection F M → Injection F T
-f ∘ g = record
-  { to        =          to        f  ⟪∘⟫ to        g
-  ; injective = (λ {_} → injective g) ⟨∘⟩ injective f
-  } where open Injection
-
\ No newline at end of file diff --git a/Function.Inverse.html b/Function.Inverse.html deleted file mode 100644 index 15f46831..00000000 --- a/Function.Inverse.html +++ /dev/null @@ -1,196 +0,0 @@ - -Function.Inverse
------------------------------------------------------------------------
--- The Agda standard library
---
--- Inverses
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
--- Note: use of the standard function hierarchy is encouraged. The
--- module `Function` re-exports `Inverseᵇ`, `IsInverse` and
--- `Inverse`. The alternative definitions found in this file will
--- eventually be deprecated.
-
-module Function.Inverse where
-
-open import Level
-open import Function.Base using (flip)
-open import Function.Bijection hiding (id; _∘_; bijection)
-open import Function.Equality as F
-  using (_⟶_) renaming (_∘_ to _⟪∘⟫_)
-open import Function.LeftInverse as Left hiding (id; _∘_)
-open import Relation.Binary
-open import Relation.Binary.PropositionalEquality as P using (_≗_; _≡_)
-open import Relation.Unary using (Pred)
-
-------------------------------------------------------------------------
--- Inverses
-
-record _InverseOf_ {f₁ f₂ t₁ t₂}
-                   {From : Setoid f₁ f₂} {To : Setoid t₁ t₂}
-                   (from : To ⟶ From) (to : From ⟶ To) :
-                   Set (f₁ ⊔ f₂ ⊔ t₁ ⊔ t₂) where
-  field
-    left-inverse-of  : from LeftInverseOf  to
-    right-inverse-of : from RightInverseOf to
-
-------------------------------------------------------------------------
--- The set of all inverses between two setoids
-
-record Inverse {f₁ f₂ t₁ t₂}
-               (From : Setoid f₁ f₂) (To : Setoid t₁ t₂) :
-               Set (f₁ ⊔ f₂ ⊔ t₁ ⊔ t₂) where
-  field
-    to         : From ⟶ To
-    from       : To ⟶ From
-    inverse-of : from InverseOf to
-
-  open _InverseOf_ inverse-of public
-
-  left-inverse : LeftInverse From To
-  left-inverse = record
-    { to              = to
-    ; from            = from
-    ; left-inverse-of = left-inverse-of
-    }
-
-  open LeftInverse left-inverse public
-    using (injective; injection)
-
-  bijection : Bijection From To
-  bijection = record
-    { to        = to
-    ; bijective = record
-      { injective  = injective
-      ; surjective = record
-        { from             = from
-        ; right-inverse-of = right-inverse-of
-        }
-      }
-    }
-
-  open Bijection bijection public
-    using (equivalence; surjective; surjection; right-inverse;
-           to-from; from-to)
-
-------------------------------------------------------------------------
--- The set of all inverses between two sets (i.e. inverses with
--- propositional equality)
-
-infix 3 _↔_ _↔̇_
-
-_↔_ : ∀ {f t} → Set f → Set t → Set _
-From ↔ To = Inverse (P.setoid From) (P.setoid To)
-
-_↔̇_ : ∀ {i f t} {I : Set i} → Pred I f → Pred I t → Set _
-From ↔̇ To = ∀ {i} → From i ↔ To i
-
-inverse : ∀ {f t} {From : Set f} {To : Set t} →
-          (to : From → To) (from : To → From) →
-          (∀ x → from (to x) ≡ x) →
-          (∀ x → to (from x) ≡ x) →
-          From ↔ To
-inverse to from from∘to to∘from = record
-  { to   = P.→-to-⟶ to
-  ; from = P.→-to-⟶ from
-  ; inverse-of = record
-    { left-inverse-of  = from∘to
-    ; right-inverse-of = to∘from
-    }
-  }
-
-------------------------------------------------------------------------
--- If two setoids are in bijective correspondence, then there is an
--- inverse between them
-
-fromBijection :
-  ∀ {f₁ f₂ t₁ t₂} {From : Setoid f₁ f₂} {To : Setoid t₁ t₂} →
-  Bijection From To → Inverse From To
-fromBijection b = record
-  { to         = Bijection.to b
-  ; from       = Bijection.from b
-  ; inverse-of = record
-    { left-inverse-of  = Bijection.left-inverse-of b
-    ; right-inverse-of = Bijection.right-inverse-of b
-    }
-  }
-
-------------------------------------------------------------------------
--- Inverse is an equivalence relation
-
--- Reflexivity
-
-id : ∀ {s₁ s₂} → Reflexive (Inverse {s₁} {s₂})
-id {x = S} = record
-  { to         = F.id
-  ; from       = F.id
-  ; inverse-of = record
-    { left-inverse-of  = LeftInverse.left-inverse-of id′
-    ; right-inverse-of = LeftInverse.left-inverse-of id′
-    }
-  } where id′ = Left.id {S = S}
-
--- Transitivity
-
-infixr 9 _∘_
-
-_∘_ : ∀ {f₁ f₂ m₁ m₂ t₁ t₂} →
-      TransFlip (Inverse {f₁} {f₂} {m₁} {m₂})
-                (Inverse {m₁} {m₂} {t₁} {t₂})
-                (Inverse {f₁} {f₂} {t₁} {t₂})
-f ∘ g = record
-  { to         = to   f ⟪∘⟫ to   g
-  ; from       = from g ⟪∘⟫ from f
-  ; inverse-of = record
-    { left-inverse-of  = LeftInverse.left-inverse-of (Left._∘_ (left-inverse  f) (left-inverse  g))
-    ; right-inverse-of = LeftInverse.left-inverse-of (Left._∘_ (right-inverse g) (right-inverse f))
-    }
-  } where open Inverse
-
--- Symmetry.
-
-sym : ∀ {f₁ f₂ t₁ t₂} →
-      Sym (Inverse {f₁} {f₂} {t₁} {t₂}) (Inverse {t₁} {t₂} {f₁} {f₂})
-sym inv = record
-  { from       = to
-  ; to         = from
-  ; inverse-of = record
-    { left-inverse-of  = right-inverse-of
-    ; right-inverse-of = left-inverse-of
-    }
-  } where open Inverse inv
-
-------------------------------------------------------------------------
--- Transformations
-
-map : ∀ {f₁ f₂ t₁ t₂} {From : Setoid f₁ f₂} {To : Setoid t₁ t₂}
-        {f₁′ f₂′ t₁′ t₂′}
-        {From′ : Setoid f₁′ f₂′} {To′ : Setoid t₁′ t₂′} →
-      (t : (From ⟶ To) → (From′ ⟶ To′)) →
-      (f : (To ⟶ From) → (To′ ⟶ From′)) →
-      (∀ {to from} → from InverseOf to → f from InverseOf t to) →
-      Inverse From To → Inverse From′ To′
-map t f pres eq = record
-  { to         = t to
-  ; from       = f from
-  ; inverse-of = pres inverse-of
-  } where open Inverse eq
-
-zip : ∀ {f₁₁ f₂₁ t₁₁ t₂₁}
-        {From₁ : Setoid f₁₁ f₂₁} {To₁ : Setoid t₁₁ t₂₁}
-        {f₁₂ f₂₂ t₁₂ t₂₂}
-        {From₂ : Setoid f₁₂ f₂₂} {To₂ : Setoid t₁₂ t₂₂}
-        {f₁ f₂ t₁ t₂} {From : Setoid f₁ f₂} {To : Setoid t₁ t₂} →
-      (t : (From₁ ⟶ To₁) → (From₂ ⟶ To₂) → (From ⟶ To)) →
-      (f : (To₁ ⟶ From₁) → (To₂ ⟶ From₂) → (To ⟶ From)) →
-      (∀ {to₁ from₁ to₂ from₂} →
-         from₁ InverseOf to₁ → from₂ InverseOf to₂ →
-         f from₁ from₂ InverseOf t to₁ to₂) →
-      Inverse From₁ To₁ → Inverse From₂ To₂ → Inverse From To
-zip t f pres eq₁ eq₂ = record
-  { to         = t (to   eq₁) (to   eq₂)
-  ; from       = f (from eq₁) (from eq₂)
-  ; inverse-of = pres (inverse-of eq₁) (inverse-of eq₂)
-  } where open Inverse
-
\ No newline at end of file diff --git a/Function.LeftInverse.html b/Function.LeftInverse.html deleted file mode 100644 index 59c08991..00000000 --- a/Function.LeftInverse.html +++ /dev/null @@ -1,132 +0,0 @@ - -Function.LeftInverse
------------------------------------------------------------------------
--- The Agda standard library
---
--- Left inverses
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
--- Note: use of the standard function hierarchy is encouraged. The
--- module `Function` re-exports `Inverseˡ`, `IsLeftInverse` and
--- `LeftInverse`. The alternative definitions found in this file will
--- eventually be deprecated.
-
-module Function.LeftInverse where
-
-open import Data.Product
-open import Level
-import Relation.Binary.Reasoning.Setoid as EqReasoning
-open import Relation.Binary
-open import Function.Equality as Eq
-  using (_⟶_; _⟨$⟩_) renaming (_∘_ to _⟪∘⟫_)
-open import Function.Equivalence using (Equivalence)
-open import Function.Injection using (Injective; Injection)
-open import Relation.Binary.PropositionalEquality as P using (_≡_)
-
-------------------------------------------------------------------------
--- Left and right inverses.
-
-_LeftInverseOf_ :
-  ∀ {f₁ f₂ t₁ t₂} {From : Setoid f₁ f₂} {To : Setoid t₁ t₂} →
-  To ⟶ From → From ⟶ To → Set _
-_LeftInverseOf_ {From = From} f g = ∀ x → f ⟨$⟩ (g ⟨$⟩ x) ≈ x
-  where open Setoid From
-
-_RightInverseOf_ :
-  ∀ {f₁ f₂ t₁ t₂} {From : Setoid f₁ f₂} {To : Setoid t₁ t₂} →
-  To ⟶ From → From ⟶ To → Set _
-f RightInverseOf g = g LeftInverseOf f
-
-------------------------------------------------------------------------
--- The set of all left inverses between two setoids.
-
-record LeftInverse {f₁ f₂ t₁ t₂}
-                   (From : Setoid f₁ f₂) (To : Setoid t₁ t₂) :
-                   Set (f₁ ⊔ f₂ ⊔ t₁ ⊔ t₂) where
-  field
-    to              : From ⟶ To
-    from            : To ⟶ From
-    left-inverse-of : from LeftInverseOf to
-
-  private
-    open module F = Setoid From
-    open module T = Setoid To
-  open EqReasoning From
-
-  injective : Injective to
-  injective {x} {y} eq = begin
-    x                    ≈⟨ F.sym (left-inverse-of x) ⟩
-    from ⟨$⟩ (to ⟨$⟩ x)  ≈⟨ Eq.cong from eq ⟩
-    from ⟨$⟩ (to ⟨$⟩ y)  ≈⟨ left-inverse-of y ⟩
-    y                    ∎
-
-  injection : Injection From To
-  injection = record { to = to; injective = injective }
-
-  equivalence : Equivalence From To
-  equivalence = record
-    { to   = to
-    ; from = from
-    }
-
-  to-from : ∀ {x y} → to ⟨$⟩ x T.≈ y → from ⟨$⟩ y F.≈ x
-  to-from {x} {y} to-x≈y = begin
-    from ⟨$⟩ y           ≈⟨ Eq.cong from (T.sym to-x≈y) ⟩
-    from ⟨$⟩ (to ⟨$⟩ x)  ≈⟨ left-inverse-of x ⟩
-    x                    ∎
-
--- The set of all right inverses between two setoids.
-
-RightInverse : ∀ {f₁ f₂ t₁ t₂}
-               (From : Setoid f₁ f₂) (To : Setoid t₁ t₂) → Set _
-RightInverse From To = LeftInverse To From
-
-------------------------------------------------------------------------
--- The set of all left inverses from one set to another (i.e. left
--- inverses with propositional equality).
---
--- Read A ↞ B as "surjection from B to A".
-
-infix 3 _↞_
-
-_↞_ : ∀ {f t} → Set f → Set t → Set _
-From ↞ To = LeftInverse (P.setoid From) (P.setoid To)
-
-leftInverse : ∀ {f t} {From : Set f} {To : Set t} →
-              (to : From → To) (from : To → From) →
-              (∀ x → from (to x) ≡ x) →
-              From ↞ To
-leftInverse to from invˡ = record
-  { to              = P.→-to-⟶ to
-  ; from            = P.→-to-⟶ from
-  ; left-inverse-of = invˡ
-  }
-
-------------------------------------------------------------------------
--- Identity and composition.
-
-id : ∀ {s₁ s₂} {S : Setoid s₁ s₂} → LeftInverse S S
-id {S = S} = record
-  { to              = Eq.id
-  ; from            = Eq.id
-  ; left-inverse-of = λ _ → Setoid.refl S
-  }
-
-infixr 9 _∘_
-
-_∘_ : ∀ {f₁ f₂ m₁ m₂ t₁ t₂}
-        {F : Setoid f₁ f₂} {M : Setoid m₁ m₂} {T : Setoid t₁ t₂} →
-      LeftInverse M T → LeftInverse F M → LeftInverse F T
-_∘_ {F = F} f g = record
-  { to              = to   f ⟪∘⟫ to   g
-  ; from            = from g ⟪∘⟫ from f
-  ; left-inverse-of = λ x → begin
-      from g ⟨$⟩ (from f ⟨$⟩ (to f ⟨$⟩ (to g ⟨$⟩ x)))  ≈⟨ Eq.cong (from g) (left-inverse-of f (to g ⟨$⟩ x)) ⟩
-      from g ⟨$⟩ (to g ⟨$⟩ x)                          ≈⟨ left-inverse-of g x ⟩
-      x                                                ∎
-  }
-  where
-  open LeftInverse
-  open EqReasoning F
-
\ No newline at end of file diff --git a/Function.Metric.Bundles.html b/Function.Metric.Bundles.html index b2fc4203..ff115b4a 100644 --- a/Function.Metric.Bundles.html +++ b/Function.Metric.Bundles.html @@ -13,7 +13,7 @@ open import Algebra.Core using (Op₂) open import Level using (Level; suc; _⊔_) -open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Core using (Rel) open import Function.Metric.Structures open import Function.Metric.Core @@ -23,122 +23,129 @@ record ProtoMetric (a i ℓ₁ ℓ₂ ℓ₃ : Level) : Set (suc (a ⊔ i ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃)) where - field - Carrier : Set a - Image : Set i - _≈_ : Rel Carrier ℓ₁ - _≈ᵢ_ : Rel Image ℓ₂ - _≤_ : Rel Image ℓ₃ - 0# : Image - d : DistanceFunction Carrier Image - isProtoMetric : IsProtoMetric _≈_ _≈ᵢ_ _≤_ 0# d - - open IsProtoMetric isProtoMetric public - ------------------------------------------------------------------------- --- PreMetric - -record PreMetric (a i ℓ₁ ℓ₂ ℓ₃ : Level) - : Set (suc (a ⊔ i ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃)) where - field - Carrier : Set a - Image : Set i - _≈_ : Rel Carrier ℓ₁ - _≈ᵢ_ : Rel Image ℓ₂ - _≤_ : Rel Image ℓ₃ - 0# : Image - d : DistanceFunction Carrier Image - isPreMetric : IsPreMetric _≈_ _≈ᵢ_ _≤_ 0# d - - open IsPreMetric isPreMetric public - - protoMetric : ProtoMetric a i ℓ₁ ℓ₂ ℓ₃ - protoMetric = record - { isProtoMetric = isProtoMetric - } - ------------------------------------------------------------------------- --- QuasiSemiMetric - -record QuasiSemiMetric (a i ℓ₁ ℓ₂ ℓ₃ : Level) - : Set (suc (a ⊔ i ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃)) where - field - Carrier : Set a - Image : Set i - _≈_ : Rel Carrier ℓ₁ - _≈ᵢ_ : Rel Image ℓ₂ - _≤_ : Rel Image ℓ₃ - 0# : Image - d : DistanceFunction Carrier Image - isQuasiSemiMetric : IsQuasiSemiMetric _≈_ _≈ᵢ_ _≤_ 0# d - - open IsQuasiSemiMetric isQuasiSemiMetric public - - preMetric : PreMetric a i ℓ₁ ℓ₂ ℓ₃ - preMetric = record - { isPreMetric = isPreMetric - } - - open PreMetric preMetric public - using (protoMetric) - ------------------------------------------------------------------------- --- SemiMetric - -record SemiMetric (a i ℓ₁ ℓ₂ ℓ₃ : Level) - : Set (suc (a ⊔ i ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃)) where - field - Carrier : Set a - Image : Set i - _≈_ : Rel Carrier ℓ₁ - _≈ᵢ_ : Rel Image ℓ₂ - _≤_ : Rel Image ℓ₃ - 0# : Image - d : DistanceFunction Carrier Image - isSemiMetric : IsSemiMetric _≈_ _≈ᵢ_ _≤_ 0# d - - open IsSemiMetric isSemiMetric public - - quasiSemiMetric : QuasiSemiMetric a i ℓ₁ ℓ₂ ℓ₃ - quasiSemiMetric = record - { isQuasiSemiMetric = isQuasiSemiMetric - } - - open QuasiSemiMetric quasiSemiMetric public - using (protoMetric; preMetric) - ------------------------------------------------------------------------- --- GeneralMetric - --- Note that this package is not necessarily a metric in the classical --- sense as there is no way to ensure that the _∙_ operator really --- represents addition. See `Function.Metric.Nat` and --- `Function.Metric.Rational` for more specialised `Metric` and --- `UltraMetric` packages. - --- See the discussion accompanying the `IsGeneralMetric` structure for --- more details. - -record GeneralMetric (a i ℓ₁ ℓ₂ ℓ₃ : Level) - : Set (suc (a ⊔ i ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃)) where - field - Carrier : Set a - Image : Set i - _≈_ : Rel Carrier ℓ₁ - _≈ᵢ_ : Rel Image ℓ₂ - _≤_ : Rel Image ℓ₃ - 0# : Image - _∙_ : Op₂ Image - d : DistanceFunction Carrier Image - isGeneralMetric : IsGeneralMetric _≈_ _≈ᵢ_ _≤_ 0# _∙_ d - - open IsGeneralMetric isGeneralMetric public - - semiMetric : SemiMetric a i ℓ₁ ℓ₂ ℓ₃ - semiMetric = record - { isSemiMetric = isSemiMetric - } - - open SemiMetric semiMetric public - using (protoMetric; preMetric; quasiSemiMetric) + infix 4 _≈_ _≈ᵢ_ _≤_ + field + Carrier : Set a + Image : Set i + _≈_ : Rel Carrier ℓ₁ + _≈ᵢ_ : Rel Image ℓ₂ + _≤_ : Rel Image ℓ₃ + 0# : Image + d : DistanceFunction Carrier Image + isProtoMetric : IsProtoMetric _≈_ _≈ᵢ_ _≤_ 0# d + + open IsProtoMetric isProtoMetric public + +------------------------------------------------------------------------ +-- PreMetric + +record PreMetric (a i ℓ₁ ℓ₂ ℓ₃ : Level) + : Set (suc (a ⊔ i ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃)) where + infix 4 _≈_ _≈ᵢ_ _≤_ + field + Carrier : Set a + Image : Set i + _≈_ : Rel Carrier ℓ₁ + _≈ᵢ_ : Rel Image ℓ₂ + _≤_ : Rel Image ℓ₃ + 0# : Image + d : DistanceFunction Carrier Image + isPreMetric : IsPreMetric _≈_ _≈ᵢ_ _≤_ 0# d + + open IsPreMetric isPreMetric public + + protoMetric : ProtoMetric a i ℓ₁ ℓ₂ ℓ₃ + protoMetric = record + { isProtoMetric = isProtoMetric + } + +------------------------------------------------------------------------ +-- QuasiSemiMetric + +record QuasiSemiMetric (a i ℓ₁ ℓ₂ ℓ₃ : Level) + : Set (suc (a ⊔ i ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃)) where + + infix 4 _≈_ _≈ᵢ_ _≤_ + field + Carrier : Set a + Image : Set i + _≈_ : Rel Carrier ℓ₁ + _≈ᵢ_ : Rel Image ℓ₂ + _≤_ : Rel Image ℓ₃ + 0# : Image + d : DistanceFunction Carrier Image + isQuasiSemiMetric : IsQuasiSemiMetric _≈_ _≈ᵢ_ _≤_ 0# d + + open IsQuasiSemiMetric isQuasiSemiMetric public + + preMetric : PreMetric a i ℓ₁ ℓ₂ ℓ₃ + preMetric = record + { isPreMetric = isPreMetric + } + + open PreMetric preMetric public + using (protoMetric) + +------------------------------------------------------------------------ +-- SemiMetric + +record SemiMetric (a i ℓ₁ ℓ₂ ℓ₃ : Level) + : Set (suc (a ⊔ i ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃)) where + infix 4 _≈_ _≈ᵢ_ _≤_ + field + Carrier : Set a + Image : Set i + _≈_ : Rel Carrier ℓ₁ + _≈ᵢ_ : Rel Image ℓ₂ + _≤_ : Rel Image ℓ₃ + 0# : Image + d : DistanceFunction Carrier Image + isSemiMetric : IsSemiMetric _≈_ _≈ᵢ_ _≤_ 0# d + + open IsSemiMetric isSemiMetric public + + quasiSemiMetric : QuasiSemiMetric a i ℓ₁ ℓ₂ ℓ₃ + quasiSemiMetric = record + { isQuasiSemiMetric = isQuasiSemiMetric + } + + open QuasiSemiMetric quasiSemiMetric public + using (protoMetric; preMetric) + +------------------------------------------------------------------------ +-- GeneralMetric + +-- Note that this package is not necessarily a metric in the classical +-- sense as there is no way to ensure that the _∙_ operator really +-- represents addition. See `Function.Metric.Nat` and +-- `Function.Metric.Rational` for more specialised `Metric` and +-- `UltraMetric` packages. + +-- See the discussion accompanying the `IsGeneralMetric` structure for +-- more details. + +record GeneralMetric (a i ℓ₁ ℓ₂ ℓ₃ : Level) + : Set (suc (a ⊔ i ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃)) where + infix 4 _≈_ _≈ᵢ_ _≤_ + infixl 6 _∙_ + field + Carrier : Set a + Image : Set i + _≈_ : Rel Carrier ℓ₁ + _≈ᵢ_ : Rel Image ℓ₂ + _≤_ : Rel Image ℓ₃ + 0# : Image + _∙_ : Op₂ Image + d : DistanceFunction Carrier Image + isGeneralMetric : IsGeneralMetric _≈_ _≈ᵢ_ _≤_ 0# _∙_ d + + open IsGeneralMetric isGeneralMetric public + + semiMetric : SemiMetric a i ℓ₁ ℓ₂ ℓ₃ + semiMetric = record + { isSemiMetric = isSemiMetric + } + + open SemiMetric semiMetric public + using (protoMetric; preMetric; quasiSemiMetric) \ No newline at end of file diff --git a/Function.Metric.Definitions.html b/Function.Metric.Definitions.html index 5e62421b..e953bed9 100644 --- a/Function.Metric.Definitions.html +++ b/Function.Metric.Definitions.html @@ -12,54 +12,54 @@ module Function.Metric.Definitions where open import Algebra.Core using (Op₂) -open import Data.Product using (∃) -open import Function.Metric.Core using (DistanceFunction) -open import Level using (Level) -open import Relation.Binary.Core using (Rel; _Preserves₂_⟶_⟶_) -open import Relation.Nullary.Negation using (¬_) +open import Data.Product.Base using (∃) +open import Function.Metric.Core using (DistanceFunction) +open import Level using (Level) +open import Relation.Binary.Core using (Rel; _Preserves₂_⟶_⟶_) +open import Relation.Nullary.Negation using (¬_) -private - variable - a i ℓ ℓ₁ ℓ₂ : Level - A : Set a - I : Set i +private + variable + a i ℓ ℓ₁ ℓ₂ : Level + A : Set a + I : Set i ------------------------------------------------------------------------ --- Properties +------------------------------------------------------------------------ +-- Properties -Congruent : Rel A ℓ₁ → Rel I ℓ₂ → DistanceFunction A I → Set _ -Congruent _≈ₐ_ _≈ᵢ_ d = d Preserves₂ _≈ₐ_ ⟶ _≈ₐ_ ⟶ _≈ᵢ_ +Congruent : Rel A ℓ₁ → Rel I ℓ₂ → DistanceFunction A I → Set _ +Congruent _≈ₐ_ _≈ᵢ_ d = d Preserves₂ _≈ₐ_ ⟶ _≈ₐ_ ⟶ _≈ᵢ_ -Indiscernable : Rel A ℓ₁ → Rel I ℓ₂ → DistanceFunction A I → I → Set _ -Indiscernable _≈ₐ_ _≈ᵢ_ d 0# = ∀ {x y} → d x y ≈ᵢ 0# → x ≈ₐ y +Indiscernable : Rel A ℓ₁ → Rel I ℓ₂ → DistanceFunction A I → I → Set _ +Indiscernable _≈ₐ_ _≈ᵢ_ d 0# = ∀ {x y} → d x y ≈ᵢ 0# → x ≈ₐ y -Definite : Rel A ℓ₁ → Rel I ℓ₂ → DistanceFunction A I → I → Set _ -Definite _≈ₐ_ _≈ᵢ_ d 0# = ∀ {x y} → x ≈ₐ y → d x y ≈ᵢ 0# +Definite : Rel A ℓ₁ → Rel I ℓ₂ → DistanceFunction A I → I → Set _ +Definite _≈ₐ_ _≈ᵢ_ d 0# = ∀ {x y} → x ≈ₐ y → d x y ≈ᵢ 0# -NonNegative : Rel I ℓ₂ → DistanceFunction A I → I → Set _ -NonNegative _≤_ d 0# = ∀ {x y} → 0# ≤ d x y +NonNegative : Rel I ℓ₂ → DistanceFunction A I → I → Set _ +NonNegative _≤_ d 0# = ∀ {x y} → 0# ≤ d x y -Symmetric : Rel I ℓ → DistanceFunction A I → Set _ -Symmetric _≈_ d = ∀ x y → d x y ≈ d y x +Symmetric : Rel I ℓ → DistanceFunction A I → Set _ +Symmetric _≈_ d = ∀ x y → d x y ≈ d y x -TriangleInequality : Rel I ℓ → Op₂ I → DistanceFunction A I → _ -TriangleInequality _≤_ _∙_ d = ∀ x y z → d x z ≤ (d x y ∙ d y z) +TriangleInequality : Rel I ℓ → Op₂ I → DistanceFunction A I → _ +TriangleInequality _≤_ _∙_ d = ∀ x y z → d x z ≤ (d x y ∙ d y z) -Bounded : Rel I ℓ → DistanceFunction A I → Set _ -Bounded _≤_ d = ∃ λ n → ∀ x y → d x y ≤ n +Bounded : Rel I ℓ → DistanceFunction A I → Set _ +Bounded _≤_ d = ∃ λ n → ∀ x y → d x y ≤ n -TranslationInvariant : Rel I ℓ₂ → Op₂ A → DistanceFunction A I → Set _ -TranslationInvariant _≈_ _∙_ d = ∀ {x y a} → d (x ∙ a) (y ∙ a) ≈ d x y +TranslationInvariant : Rel I ℓ₂ → Op₂ A → DistanceFunction A I → Set _ +TranslationInvariant _≈_ _∙_ d = ∀ {x y a} → d (x ∙ a) (y ∙ a) ≈ d x y -Contracting : Rel I ℓ → (A → A) → DistanceFunction A I → Set _ -Contracting _≤_ f d = ∀ x y → d (f x) (f y) ≤ d x y +Contracting : Rel I ℓ → (A → A) → DistanceFunction A I → Set _ +Contracting _≤_ f d = ∀ x y → d (f x) (f y) ≤ d x y -ContractingOnOrbits : Rel I ℓ → (A → A) → DistanceFunction A I → Set _ -ContractingOnOrbits _≤_ f d = ∀ x → d (f x) (f (f x)) ≤ d x (f x) +ContractingOnOrbits : Rel I ℓ → (A → A) → DistanceFunction A I → Set _ +ContractingOnOrbits _≤_ f d = ∀ x → d (f x) (f (f x)) ≤ d x (f x) -StrictlyContracting : Rel A ℓ₁ → Rel I ℓ₂ → (A → A) → DistanceFunction A I → Set _ -StrictlyContracting _≈_ _<_ f d = ∀ {x y} → ¬ (y ≈ x) → d (f x) (f y) < d x y +StrictlyContracting : Rel A ℓ₁ → Rel I ℓ₂ → (A → A) → DistanceFunction A I → Set _ +StrictlyContracting _≈_ _<_ f d = ∀ {x y} → ¬ (y ≈ x) → d (f x) (f y) < d x y -StrictlyContractingOnOrbits : Rel A ℓ₁ → Rel I ℓ₂ → (A → A) → DistanceFunction A I → Set _ -StrictlyContractingOnOrbits _≈_ _<_ f d = ∀ {x} → ¬ (f x ≈ x) → d (f x) (f (f x)) < d x (f x) +StrictlyContractingOnOrbits : Rel A ℓ₁ → Rel I ℓ₂ → (A → A) → DistanceFunction A I → Set _ +StrictlyContractingOnOrbits _≈_ _<_ f d = ∀ {x} → ¬ (f x ≈ x) → d (f x) (f (f x)) < d x (f x) \ No newline at end of file diff --git a/Function.Metric.Nat.Bundles.html b/Function.Metric.Nat.Bundles.html index d635d744..a9f9cc98 100644 --- a/Function.Metric.Nat.Bundles.html +++ b/Function.Metric.Nat.Bundles.html @@ -13,124 +13,130 @@ module Function.Metric.Nat.Bundles where -open import Data.Nat.Base hiding (suc; _⊔_) -open import Function using (const) -open import Level using (Level; suc; _⊔_) -open import Relation.Binary.Core -open import Relation.Binary.PropositionalEquality - using (_≡_; isEquivalence) - -open import Function.Metric.Nat.Core -open import Function.Metric.Nat.Structures -open import Function.Metric.Bundles as Base - using (GeneralMetric) - ------------------------------------------------------------------------- --- Proto-metric - -record ProtoMetric a ℓ : Set (suc (a ⊔ ℓ)) where - field - Carrier : Set a - _≈_ : Rel Carrier ℓ - d : DistanceFunction Carrier - isProtoMetric : IsProtoMetric _≈_ d - - open IsProtoMetric isProtoMetric public - ------------------------------------------------------------------------- --- PreMetric - -record PreMetric a ℓ : Set (suc (a ⊔ ℓ)) where - field - Carrier : Set a - _≈_ : Rel Carrier ℓ - d : DistanceFunction Carrier - isPreMetric : IsPreMetric _≈_ d - - open IsPreMetric isPreMetric public - - protoMetric : ProtoMetric a ℓ - protoMetric = record - { isProtoMetric = isProtoMetric - } - ------------------------------------------------------------------------- --- QuasiSemiMetric - -record QuasiSemiMetric a ℓ : Set (suc (a ⊔ ℓ)) where - field - Carrier : Set a - _≈_ : Rel Carrier ℓ - d : DistanceFunction Carrier - isQuasiSemiMetric : IsQuasiSemiMetric _≈_ d - - open IsQuasiSemiMetric isQuasiSemiMetric public - - preMetric : PreMetric a ℓ - preMetric = record - { isPreMetric = isPreMetric - } - - open PreMetric preMetric public - using (protoMetric) - ------------------------------------------------------------------------- --- SemiMetric - -record SemiMetric a ℓ : Set (suc (a ⊔ ℓ)) where - field - Carrier : Set a - _≈_ : Rel Carrier ℓ - d : DistanceFunction Carrier - isSemiMetric : IsSemiMetric _≈_ d - - open IsSemiMetric isSemiMetric public - - quasiSemiMetric : QuasiSemiMetric a ℓ - quasiSemiMetric = record - { isQuasiSemiMetric = isQuasiSemiMetric - } - - open QuasiSemiMetric quasiSemiMetric public - using (protoMetric; preMetric) - ------------------------------------------------------------------------- --- Metrics - -record Metric a ℓ : Set (suc (a ⊔ ℓ)) where - field - Carrier : Set a - _≈_ : Rel Carrier ℓ - d : DistanceFunction Carrier - isMetric : IsMetric _≈_ d - - open IsMetric isMetric public - - semiMetric : SemiMetric a ℓ - semiMetric = record - { isSemiMetric = isSemiMetric - } - - open SemiMetric semiMetric public - using (protoMetric; preMetric; quasiSemiMetric) - ------------------------------------------------------------------------- --- UltraMetrics - -record UltraMetric a ℓ : Set (suc (a ⊔ ℓ)) where - field - Carrier : Set a - _≈_ : Rel Carrier ℓ - d : DistanceFunction Carrier - isUltraMetric : IsUltraMetric _≈_ d - - open IsUltraMetric isUltraMetric public - - semiMetric : SemiMetric a ℓ - semiMetric = record - { isSemiMetric = isSemiMetric - } - - open SemiMetric semiMetric public - using (protoMetric; preMetric; quasiSemiMetric) +open import Data.Nat.Base hiding (suc; _⊔_) +open import Function.Base using (const) +open import Level using (Level; suc; _⊔_) +open import Relation.Binary.Core +open import Relation.Binary.PropositionalEquality + using (_≡_; isEquivalence) + +open import Function.Metric.Nat.Core +open import Function.Metric.Nat.Structures +open import Function.Metric.Bundles as Base + using (GeneralMetric) + +------------------------------------------------------------------------ +-- Proto-metric + +record ProtoMetric a ℓ : Set (suc (a ⊔ ℓ)) where + infix 4 _≈_ + field + Carrier : Set a + _≈_ : Rel Carrier ℓ + d : DistanceFunction Carrier + isProtoMetric : IsProtoMetric _≈_ d + + open IsProtoMetric isProtoMetric public + +------------------------------------------------------------------------ +-- PreMetric + +record PreMetric a ℓ : Set (suc (a ⊔ ℓ)) where + infix 4 _≈_ + field + Carrier : Set a + _≈_ : Rel Carrier ℓ + d : DistanceFunction Carrier + isPreMetric : IsPreMetric _≈_ d + + open IsPreMetric isPreMetric public + + protoMetric : ProtoMetric a ℓ + protoMetric = record + { isProtoMetric = isProtoMetric + } + +------------------------------------------------------------------------ +-- QuasiSemiMetric + +record QuasiSemiMetric a ℓ : Set (suc (a ⊔ ℓ)) where + infix 4 _≈_ + field + Carrier : Set a + _≈_ : Rel Carrier ℓ + d : DistanceFunction Carrier + isQuasiSemiMetric : IsQuasiSemiMetric _≈_ d + + open IsQuasiSemiMetric isQuasiSemiMetric public + + preMetric : PreMetric a ℓ + preMetric = record + { isPreMetric = isPreMetric + } + + open PreMetric preMetric public + using (protoMetric) + +------------------------------------------------------------------------ +-- SemiMetric + +record SemiMetric a ℓ : Set (suc (a ⊔ ℓ)) where + infix 4 _≈_ + field + Carrier : Set a + _≈_ : Rel Carrier ℓ + d : DistanceFunction Carrier + isSemiMetric : IsSemiMetric _≈_ d + + open IsSemiMetric isSemiMetric public + + quasiSemiMetric : QuasiSemiMetric a ℓ + quasiSemiMetric = record + { isQuasiSemiMetric = isQuasiSemiMetric + } + + open QuasiSemiMetric quasiSemiMetric public + using (protoMetric; preMetric) + +------------------------------------------------------------------------ +-- Metrics + +record Metric a ℓ : Set (suc (a ⊔ ℓ)) where + infix 4 _≈_ + field + Carrier : Set a + _≈_ : Rel Carrier ℓ + d : DistanceFunction Carrier + isMetric : IsMetric _≈_ d + + open IsMetric isMetric public + + semiMetric : SemiMetric a ℓ + semiMetric = record + { isSemiMetric = isSemiMetric + } + + open SemiMetric semiMetric public + using (protoMetric; preMetric; quasiSemiMetric) + +------------------------------------------------------------------------ +-- UltraMetrics + +record UltraMetric a ℓ : Set (suc (a ⊔ ℓ)) where + infix 4 _≈_ + field + Carrier : Set a + _≈_ : Rel Carrier ℓ + d : DistanceFunction Carrier + isUltraMetric : IsUltraMetric _≈_ d + + open IsUltraMetric isUltraMetric public + + semiMetric : SemiMetric a ℓ + semiMetric = record + { isSemiMetric = isSemiMetric + } + + open SemiMetric semiMetric public + using (protoMetric; preMetric; quasiSemiMetric) \ No newline at end of file diff --git a/Function.Metric.Nat.Definitions.html b/Function.Metric.Nat.Definitions.html index 7ddfd024..e668bb09 100644 --- a/Function.Metric.Nat.Definitions.html +++ b/Function.Metric.Nat.Definitions.html @@ -28,43 +28,43 @@ -- Basic -Congruent : Rel A ℓ → DistanceFunction A → Set _ -Congruent _≈ₐ_ d = Base.Congruent _≈ₐ_ _≡_ d +Congruent : Rel A ℓ → DistanceFunction A → Set _ +Congruent _≈ₐ_ d = Base.Congruent _≈ₐ_ _≡_ d -Indiscernable : Rel A ℓ → DistanceFunction A → Set _ -Indiscernable _≈ₐ_ d = Base.Indiscernable _≈ₐ_ _≡_ d 0 +Indiscernable : Rel A ℓ → DistanceFunction A → Set _ +Indiscernable _≈ₐ_ d = Base.Indiscernable _≈ₐ_ _≡_ d 0 -Definite : Rel A ℓ → DistanceFunction A → Set _ -Definite _≈ₐ_ d = Base.Definite _≈ₐ_ _≡_ d 0 +Definite : Rel A ℓ → DistanceFunction A → Set _ +Definite _≈ₐ_ d = Base.Definite _≈ₐ_ _≡_ d 0 Symmetric : DistanceFunction A → Set _ -Symmetric = Base.Symmetric _≡_ +Symmetric = Base.Symmetric _≡_ Bounded : DistanceFunction A → Set _ -Bounded = Base.Bounded _≤_ +Bounded = Base.Bounded _≤_ TranslationInvariant : Op₂ A → DistanceFunction A → Set _ -TranslationInvariant = Base.TranslationInvariant _≡_ +TranslationInvariant = Base.TranslationInvariant _≡_ -- Inequalities TriangleInequality : DistanceFunction A → Set _ -TriangleInequality = Base.TriangleInequality _≤_ _+_ +TriangleInequality = Base.TriangleInequality _≤_ _+_ MaxTriangleInequality : DistanceFunction A → Set _ -MaxTriangleInequality = Base.TriangleInequality _≤_ _⊔_ +MaxTriangleInequality = Base.TriangleInequality _≤_ _⊔_ -- Contractions Contracting : (A → A) → DistanceFunction A → Set _ -Contracting = Base.Contracting _≤_ +Contracting = Base.Contracting _≤_ ContractingOnOrbits : (A → A) → DistanceFunction A → Set _ -ContractingOnOrbits = Base.ContractingOnOrbits _≤_ +ContractingOnOrbits = Base.ContractingOnOrbits _≤_ -StrictlyContracting : Rel A ℓ → (A → A) → DistanceFunction A → Set _ -StrictlyContracting _≈_ = Base.StrictlyContracting _≈_ _<_ +StrictlyContracting : Rel A ℓ → (A → A) → DistanceFunction A → Set _ +StrictlyContracting _≈_ = Base.StrictlyContracting _≈_ _<_ -StrictlyContractingOnOrbits : Rel A ℓ → (A → A) → DistanceFunction A → Set _ -StrictlyContractingOnOrbits _≈_ = Base.StrictlyContractingOnOrbits _≈_ _<_ +StrictlyContractingOnOrbits : Rel A ℓ → (A → A) → DistanceFunction A → Set _ +StrictlyContractingOnOrbits _≈_ = Base.StrictlyContractingOnOrbits _≈_ _<_ \ No newline at end of file diff --git a/Function.Metric.Nat.Structures.html b/Function.Metric.Nat.Structures.html index 85a5ac6a..41b1cee6 100644 --- a/Function.Metric.Nat.Structures.html +++ b/Function.Metric.Nat.Structures.html @@ -10,69 +10,69 @@ module Function.Metric.Nat.Structures where open import Data.Nat.Base hiding (suc) -open import Function using (const) -open import Level using (Level; suc) -open import Relation.Binary hiding (Symmetric) -open import Relation.Binary.PropositionalEquality using (_≡_) +open import Function.Base using (const) +open import Level using (Level; suc) +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.PropositionalEquality.Core using (_≡_) -open import Function.Metric.Nat.Core -open import Function.Metric.Nat.Definitions -import Function.Metric.Structures as Base +open import Function.Metric.Nat.Core +open import Function.Metric.Nat.Definitions +import Function.Metric.Structures as Base -private - variable - a ℓ : Level - A : Set a +private + variable + a ℓ : Level + A : Set a ------------------------------------------------------------------------- --- Proto-metrics +------------------------------------------------------------------------ +-- Proto-metrics -IsProtoMetric : Rel A ℓ → DistanceFunction A → Set _ -IsProtoMetric _≈_ = Base.IsProtoMetric _≈_ _≡_ _≤_ 0 +IsProtoMetric : Rel A ℓ → DistanceFunction A → Set _ +IsProtoMetric _≈_ = Base.IsProtoMetric _≈_ _≡_ _≤_ 0 -open Base using (module IsProtoMetric) public +open Base using (module IsProtoMetric) public ------------------------------------------------------------------------- --- Pre-metrics +------------------------------------------------------------------------ +-- Pre-metrics -IsPreMetric : Rel A ℓ → DistanceFunction A → Set _ -IsPreMetric _≈_ = Base.IsPreMetric _≈_ _≡_ _≤_ 0 +IsPreMetric : Rel A ℓ → DistanceFunction A → Set _ +IsPreMetric _≈_ = Base.IsPreMetric _≈_ _≡_ _≤_ 0 -open Base using (module IsPreMetric) public +open Base using (module IsPreMetric) public ------------------------------------------------------------------------- --- Quasi-semi-metrics +------------------------------------------------------------------------ +-- Quasi-semi-metrics -IsQuasiSemiMetric : Rel A ℓ → DistanceFunction A → Set _ -IsQuasiSemiMetric _≈_ = Base.IsQuasiSemiMetric _≈_ _≡_ _≤_ 0 +IsQuasiSemiMetric : Rel A ℓ → DistanceFunction A → Set _ +IsQuasiSemiMetric _≈_ = Base.IsQuasiSemiMetric _≈_ _≡_ _≤_ 0 -open Base using (module IsQuasiSemiMetric) public +open Base using (module IsQuasiSemiMetric) public ------------------------------------------------------------------------- --- Semi-metrics +------------------------------------------------------------------------ +-- Semi-metrics -IsSemiMetric : Rel A ℓ → DistanceFunction A → Set _ -IsSemiMetric _≈_ = Base.IsSemiMetric _≈_ _≡_ _≤_ 0 +IsSemiMetric : Rel A ℓ → DistanceFunction A → Set _ +IsSemiMetric _≈_ = Base.IsSemiMetric _≈_ _≡_ _≤_ 0 -open Base using (module IsSemiMetric) public +open Base using (module IsSemiMetric) public ------------------------------------------------------------------------- --- Metrics +------------------------------------------------------------------------ +-- Metrics -IsMetric : Rel A ℓ → DistanceFunction A → Set _ -IsMetric _≈_ = Base.IsGeneralMetric _≈_ _≡_ _≤_ 0 _+_ +IsMetric : Rel A ℓ → DistanceFunction A → Set _ +IsMetric _≈_ = Base.IsGeneralMetric _≈_ _≡_ _≤_ 0 _+_ -module IsMetric {_≈_ : Rel A ℓ} {d : DistanceFunction A} - (M : IsMetric _≈_ d) where - open Base.IsGeneralMetric M public +module IsMetric {_≈_ : Rel A ℓ} {d : DistanceFunction A} + (M : IsMetric _≈_ d) where + open Base.IsGeneralMetric M public ------------------------------------------------------------------------- --- Ultra-metrics +------------------------------------------------------------------------ +-- Ultra-metrics -IsUltraMetric : Rel A ℓ → DistanceFunction A → Set _ -IsUltraMetric _≈_ = Base.IsGeneralMetric _≈_ _≡_ _≤_ 0 _⊔_ +IsUltraMetric : Rel A ℓ → DistanceFunction A → Set _ +IsUltraMetric _≈_ = Base.IsGeneralMetric _≈_ _≡_ _≤_ 0 _⊔_ -module IsUltraMetric {_≈_ : Rel A ℓ} {d : DistanceFunction A} - (UM : IsUltraMetric _≈_ d) where - open Base.IsGeneralMetric UM public +module IsUltraMetric {_≈_ : Rel A ℓ} {d : DistanceFunction A} + (UM : IsUltraMetric _≈_ d) where + open Base.IsGeneralMetric UM public \ No newline at end of file diff --git a/Function.Metric.Structures.html b/Function.Metric.Structures.html index 3122f873..0d55ef58 100644 --- a/Function.Metric.Structures.html +++ b/Function.Metric.Structures.html @@ -10,89 +10,90 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary hiding (Symmetric) - -module Function.Metric.Structures - {a i ℓ₁ ℓ₂ ℓ₃} {A : Set a} {I : Set i} - (_≈ₐ_ : Rel A ℓ₁) (_≈ᵢ_ : Rel I ℓ₂) (_≤_ : Rel I ℓ₃) (0# : I) where - -open import Algebra.Core using (Op₂) -open import Function.Metric.Core -open import Function.Metric.Definitions -open import Level using (_⊔_) - ------------------------------------------------------------------------- --- Proto-metrics - --- We do not insist that the ordering relation is total as otherwise --- we would exclude the real numbers. - -record IsProtoMetric (d : DistanceFunction A I) - : Set (a ⊔ i ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃) where - field - isPartialOrder : IsPartialOrder _≈ᵢ_ _≤_ - ≈-isEquivalence : IsEquivalence _≈ₐ_ - cong : Congruent _≈ₐ_ _≈ᵢ_ d - nonNegative : NonNegative _≤_ d 0# - - open IsPartialOrder isPartialOrder public - renaming (module Eq to EqI) - - module EqC = IsEquivalence ≈-isEquivalence - ------------------------------------------------------------------------- --- Pre-metrics - -record IsPreMetric (d : DistanceFunction A I) - : Set (a ⊔ i ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃) where - field - isProtoMetric : IsProtoMetric d - ≈⇒0 : Definite _≈ₐ_ _≈ᵢ_ d 0# - - open IsProtoMetric isProtoMetric public - ------------------------------------------------------------------------- --- Quasi-semi-metrics - -record IsQuasiSemiMetric (d : DistanceFunction A I) - : Set (a ⊔ i ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃) where - field - isPreMetric : IsPreMetric d - 0⇒≈ : Indiscernable _≈ₐ_ _≈ᵢ_ d 0# - - open IsPreMetric isPreMetric public - ------------------------------------------------------------------------- --- Semi-metrics - -record IsSemiMetric (d : DistanceFunction A I) - : Set (a ⊔ i ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃) where - field - isQuasiSemiMetric : IsQuasiSemiMetric d - sym : Symmetric _≈ᵢ_ d - - open IsQuasiSemiMetric isQuasiSemiMetric public - ------------------------------------------------------------------------- --- General metrics - --- A general metric obeys a generalised form of the triangle inequality. --- It can be specialised to a standard metric/ultrametric/inframetric --- etc. by providing the correct operator. --- --- Furthermore we do not assume that _∙_ & 0# form a monoid as --- associativity does not hold for p-relaxed metrics/p-inframetrics and --- the identity laws do not hold for ultrametrics over negative --- codomains. --- --- See "Properties of distance spaces with power triangle inequalities" --- by Daniel J. Greenhoe, 2016 (arXiv) - -record IsGeneralMetric (_∙_ : Op₂ I) (d : DistanceFunction A I) - : Set (a ⊔ i ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃) where - field - isSemiMetric : IsSemiMetric d - triangle : TriangleInequality _≤_ _∙_ d - - open IsSemiMetric isSemiMetric public +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Structures using (IsPartialOrder; IsEquivalence) + +module Function.Metric.Structures + {a i ℓ₁ ℓ₂ ℓ₃} {A : Set a} {I : Set i} + (_≈ₐ_ : Rel A ℓ₁) (_≈ᵢ_ : Rel I ℓ₂) (_≤_ : Rel I ℓ₃) (0# : I) where + +open import Algebra.Core using (Op₂) +open import Function.Metric.Core +open import Function.Metric.Definitions +open import Level using (_⊔_) + +------------------------------------------------------------------------ +-- Proto-metrics + +-- We do not insist that the ordering relation is total as otherwise +-- we would exclude the real numbers. + +record IsProtoMetric (d : DistanceFunction A I) + : Set (a ⊔ i ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃) where + field + isPartialOrder : IsPartialOrder _≈ᵢ_ _≤_ + ≈-isEquivalence : IsEquivalence _≈ₐ_ + cong : Congruent _≈ₐ_ _≈ᵢ_ d + nonNegative : NonNegative _≤_ d 0# + + open IsPartialOrder isPartialOrder public + renaming (module Eq to EqI) + + module EqC = IsEquivalence ≈-isEquivalence + +------------------------------------------------------------------------ +-- Pre-metrics + +record IsPreMetric (d : DistanceFunction A I) + : Set (a ⊔ i ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃) where + field + isProtoMetric : IsProtoMetric d + ≈⇒0 : Definite _≈ₐ_ _≈ᵢ_ d 0# + + open IsProtoMetric isProtoMetric public + +------------------------------------------------------------------------ +-- Quasi-semi-metrics + +record IsQuasiSemiMetric (d : DistanceFunction A I) + : Set (a ⊔ i ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃) where + field + isPreMetric : IsPreMetric d + 0⇒≈ : Indiscernable _≈ₐ_ _≈ᵢ_ d 0# + + open IsPreMetric isPreMetric public + +------------------------------------------------------------------------ +-- Semi-metrics + +record IsSemiMetric (d : DistanceFunction A I) + : Set (a ⊔ i ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃) where + field + isQuasiSemiMetric : IsQuasiSemiMetric d + sym : Symmetric _≈ᵢ_ d + + open IsQuasiSemiMetric isQuasiSemiMetric public + +------------------------------------------------------------------------ +-- General metrics + +-- A general metric obeys a generalised form of the triangle inequality. +-- It can be specialised to a standard metric/ultrametric/inframetric +-- etc. by providing the correct operator. +-- +-- Furthermore we do not assume that _∙_ & 0# form a monoid as +-- associativity does not hold for p-relaxed metrics/p-inframetrics and +-- the identity laws do not hold for ultrametrics over negative +-- codomains. +-- +-- See "Properties of distance spaces with power triangle inequalities" +-- by Daniel J. Greenhoe, 2016 (arXiv) + +record IsGeneralMetric (_∙_ : Op₂ I) (d : DistanceFunction A I) + : Set (a ⊔ i ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃) where + field + isSemiMetric : IsSemiMetric d + triangle : TriangleInequality _≤_ _∙_ d + + open IsSemiMetric isSemiMetric public \ No newline at end of file diff --git a/Function.Properties.Bijection.html b/Function.Properties.Bijection.html index c4f732ae..63d77533 100644 --- a/Function.Properties.Bijection.html +++ b/Function.Properties.Bijection.html @@ -11,70 +11,69 @@ open import Function.Bundles open import Level using (Level) -open import Relation.Binary hiding (_⇔_) -open import Relation.Binary.PropositionalEquality as P using (setoid) -import Relation.Binary.Reasoning.Setoid as SetoidReasoning -open import Data.Product using (_,_; proj₁; proj₂) -open import Function.Base using (_∘_) -open import Function.Properties.Inverse using (Inverse⇒Equivalence) - -import Function.Construct.Identity as Identity -import Function.Construct.Symmetry as Symmetry -import Function.Construct.Composition as Composition - -private - variable - a b c ℓ ℓ₁ ℓ₂ ℓ₃ : Level - A B : Set a - T S : Setoid a ℓ - ------------------------------------------------------------------------- --- Setoid properties - -refl : Reflexive (Bijection {a} {ℓ}) -refl = Identity.bijection _ - --- Can't prove full symmetry as we have no proof that the witness --- produced by the surjection proof preserves equality -sym-≡ : Bijection S (P.setoid B) → Bijection (P.setoid B) S -sym-≡ = Symmetry.bijection-≡ - -trans : Trans (Bijection {a} {ℓ₁} {b} {ℓ₂}) (Bijection {b} {ℓ₂} {c} {ℓ₃}) Bijection -trans = Composition.bijection - ------------------------------------------------------------------------- --- Propositional properties - -⤖-isEquivalence : IsEquivalence {ℓ = ℓ} _⤖_ -⤖-isEquivalence = record - { refl = refl - ; sym = sym-≡ - ; trans = trans - } - ------------------------------------------------------------------------- --- Conversion functions - -Bijection⇒Inverse : Bijection S T → Inverse S T -Bijection⇒Inverse {S = S} {T = T} b = record - { to = to - ; from = to⁻ - ; to-cong = cong - ; from-cong = λ {x} {y} x≈y → injective (begin - to (to⁻ x) ≈⟨ to∘to⁻ x ⟩ - x ≈⟨ x≈y ⟩ - y ≈˘⟨ to∘to⁻ y ⟩ - to (to⁻ y) ∎) - ; inverse = to∘to⁻ , injective ∘ to∘to⁻ ∘ to - } - where open SetoidReasoning T; open Bijection b; to∘to⁻ = proj₂ ∘ surjective - -Bijection⇒Equivalence : Bijection T S → Equivalence T S -Bijection⇒Equivalence = Inverse⇒Equivalence ∘ Bijection⇒Inverse - -⤖⇒↔ : A ⤖ B → A ↔ B -⤖⇒↔ = Bijection⇒Inverse - -⤖⇒⇔ : A ⤖ B → A ⇔ B -⤖⇒⇔ = Bijection⇒Equivalence +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Binary.Structures using (IsEquivalence) +open import Relation.Binary.Definitions using (Reflexive; Trans) +open import Relation.Binary.PropositionalEquality as P using (setoid) +open import Data.Product.Base using (_,_; proj₁; proj₂) +open import Function.Base using (_∘_) +open import Function.Properties.Surjection using (injective⇒to⁻-cong) +open import Function.Properties.Inverse using (Inverse⇒Equivalence) + +import Function.Construct.Identity as Identity +import Function.Construct.Symmetry as Symmetry +import Function.Construct.Composition as Composition + +private + variable + a b c ℓ ℓ₁ ℓ₂ ℓ₃ : Level + A B : Set a + T S : Setoid a ℓ + +------------------------------------------------------------------------ +-- Setoid properties + +refl : Reflexive (Bijection {a} {ℓ}) +refl = Identity.bijection _ + +-- Can't prove full symmetry as we have no proof that the witness +-- produced by the surjection proof preserves equality +sym-≡ : Bijection S (P.setoid B) → Bijection (P.setoid B) S +sym-≡ = Symmetry.bijection-≡ + +trans : Trans (Bijection {a} {ℓ₁} {b} {ℓ₂}) (Bijection {b} {ℓ₂} {c} {ℓ₃}) Bijection +trans = Composition.bijection + +------------------------------------------------------------------------ +-- Propositional properties + +⤖-isEquivalence : IsEquivalence {ℓ = ℓ} _⤖_ +⤖-isEquivalence = record + { refl = refl + ; sym = sym-≡ + ; trans = trans + } + +------------------------------------------------------------------------ +-- Conversion functions + +Bijection⇒Inverse : Bijection S T → Inverse S T +Bijection⇒Inverse bij = record + { to = to + ; from = to⁻ + ; to-cong = cong + ; from-cong = injective⇒to⁻-cong surjection injective + ; inverse = (λ y≈to⁻[x] → Eq₂.trans (cong y≈to⁻[x]) (to∘to⁻ _)) , + (λ y≈to[x] → injective (Eq₂.trans (to∘to⁻ _) y≈to[x])) + } + where open Bijection bij; to∘to⁻ = proj₂ ∘ strictlySurjective + +Bijection⇒Equivalence : Bijection T S → Equivalence T S +Bijection⇒Equivalence = Inverse⇒Equivalence ∘ Bijection⇒Inverse + +⤖⇒↔ : A ⤖ B → A ↔ B +⤖⇒↔ = Bijection⇒Inverse + +⤖⇒⇔ : A ⤖ B → A ⇔ B +⤖⇒⇔ = Bijection⇒Equivalence \ No newline at end of file diff --git a/Function.Properties.Inverse.HalfAdjointEquivalence.html b/Function.Properties.Inverse.HalfAdjointEquivalence.html new file mode 100644 index 00000000..1f49311c --- /dev/null +++ b/Function.Properties.Inverse.HalfAdjointEquivalence.html @@ -0,0 +1,123 @@ + +Function.Properties.Inverse.HalfAdjointEquivalence
------------------------------------------------------------------------
+-- The Agda standard library
+--
+-- Half adjoint equivalences
+------------------------------------------------------------------------
+
+{-# OPTIONS --cubical-compatible --safe #-}
+
+module Function.Properties.Inverse.HalfAdjointEquivalence where
+
+open import Function.Base
+open import Function
+open import Level
+open import Relation.Binary.PropositionalEquality
+
+private
+  variable
+    a b : Level
+    A B : Set a
+
+-- Half adjoint equivalences (see the HoTT book).
+--
+-- They are inverses with an extra coherence condition that the left
+-- and right inversion proofs interact the right way with `cong`.
+
+infix 4 _≃_
+
+record _≃_ (A : Set a) (B : Set b) : Set (a ⊔ b) where
+  field
+    to               : A → B
+    from             : B → A
+    left-inverse-of  : ∀ x → from (to x) ≡ x
+    right-inverse-of : ∀ x → to (from x) ≡ x
+    left-right       : ∀ x → cong to (left-inverse-of x) ≡ right-inverse-of (to x)
+
+  -- The forward direction of a half adjoint equivalence is injective.
+
+  injective : ∀ {x y} → to x ≡ to y → x ≡ y
+  injective {x} {y} to-x≡to-y =
+    x            ≡⟨ sym (left-inverse-of _) ⟩
+    from (to x)  ≡⟨ cong from to-x≡to-y ⟩
+    from (to y)  ≡⟨ left-inverse-of _ ⟩
+    y            ∎
+    where open ≡-Reasoning
+
+-- Half adjoint equivalences can be turned into inverses.
+
+≃⇒↔ : A ≃ B → A ↔ B
+≃⇒↔ A≃B = mk↔ₛ′ to from right-inverse-of left-inverse-of
+  where open _≃_ A≃B
+
+-- Inverses can be turned into half adjoint equivalences.
+--
+-- (This proof is based on one in the HoTT book.)
+
+↔⇒≃ : A ↔ B → A ≃ B
+↔⇒≃ A↔B = record
+  { to               = to
+  ; from             = from
+  ; left-inverse-of  = strictlyInverseʳ
+  ; right-inverse-of = right-inverse-of
+  ; left-right       = left-right
+  }
+  where
+  open ≡-Reasoning
+  open module A↔B = Inverse A↔B
+
+  right-inverse-of : ∀ x → to (from x) ≡ x
+  right-inverse-of x =
+    to (from x)               ≡⟨ sym (A↔B.strictlyInverseˡ _) ⟩
+    to (from (to (from x)))   ≡⟨ cong to (strictlyInverseʳ  _) ⟩
+    to (from x)               ≡⟨ A↔B.strictlyInverseˡ _ ⟩
+    x                         ∎
+
+  left-right :
+    ∀ x →
+    cong to (strictlyInverseʳ x) ≡ right-inverse-of (to x)
+  left-right x =
+    cong to (strictlyInverseʳ x)               ≡⟨⟩
+
+    trans refl (cong to (strictlyInverseʳ _))  ≡⟨ cong (λ p → trans p (cong to (strictlyInverseʳ _)))
+                                                          (sym (trans-symˡ (A↔B.strictlyInverseˡ _))) ⟩
+    trans (trans (sym (A↔B.strictlyInverseˡ _))
+               (A↔B.strictlyInverseˡ _))
+      (cong to (strictlyInverseʳ _))           ≡⟨ trans-assoc (sym (A↔B.strictlyInverseˡ _)) ⟩
+
+    trans (sym (A↔B.strictlyInverseˡ _))
+      (trans (A↔B.strictlyInverseˡ _)
+         (cong to (strictlyInverseʳ _)))       ≡⟨ cong (trans (sym (A↔B.strictlyInverseˡ _))) lemma ⟩
+
+    trans (sym (A↔B.strictlyInverseˡ _))
+      (trans (cong to (strictlyInverseʳ _))
+         (trans (A↔B.strictlyInverseˡ _) refl))      ≡⟨⟩
+
+    right-inverse-of (to x)                      ∎
+    where
+    lemma =
+      trans (A↔B.strictlyInverseˡ _)
+        (cong to (strictlyInverseʳ _))             ≡⟨ cong (trans (A↔B.strictlyInverseˡ _)) (sym (cong-id _)) ⟩
+
+      trans (A↔B.strictlyInverseˡ _)
+        (cong id (cong to (strictlyInverseʳ _)))   ≡⟨ sym (naturality A↔B.strictlyInverseˡ) ⟩
+
+      trans (cong (to ∘ from)
+                 (cong to (strictlyInverseʳ _)))
+        (A↔B.strictlyInverseˡ _)                         ≡⟨ cong (λ p → trans p (A↔B.strictlyInverseˡ _))
+                                                              (sym (cong-∘ _)) ⟩
+      trans (cong (to ∘ from ∘ to)
+                      (strictlyInverseʳ _))
+        (A↔B.strictlyInverseˡ _)                         ≡⟨ cong (λ p → trans p (A↔B.strictlyInverseˡ _))
+                                                              (cong-∘ _) ⟩
+      trans (cong to
+                 (cong (from ∘ to)
+                    (strictlyInverseʳ _)))
+        (A↔B.strictlyInverseˡ _)                         ≡⟨ cong (λ p → trans (cong to p) (strictlyInverseˡ (to x)))
+                                                              (cong-≡id strictlyInverseʳ) ⟩
+      trans (cong to (strictlyInverseʳ _))
+        (A↔B.strictlyInverseˡ _)                         ≡⟨ cong (trans (cong to (strictlyInverseʳ _)))
+                                                              (sym (trans-reflʳ _)) ⟩
+      trans (cong to (strictlyInverseʳ _))
+        (trans (A↔B.strictlyInverseˡ _) refl)            ∎
+
\ No newline at end of file diff --git a/Function.Properties.Inverse.html b/Function.Properties.Inverse.html index f4bbb9e8..ef70cb5c 100644 --- a/Function.Properties.Inverse.html +++ b/Function.Properties.Inverse.html @@ -2,98 +2,160 @@ Function.Properties.Inverse
------------------------------------------------------------------------
 -- The Agda standard library
 --
--- Some functional properties are Equivalence Relations
---   This file is meant to be imported qualified.
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-module Function.Properties.Inverse where
-
-open import Axiom.Extensionality.Propositional using (Extensionality)
-open import Data.Product using (_,_; proj₁; proj₂)
-open import Function.Bundles
-open import Level using (Level)
-open import Relation.Binary using (Setoid; IsEquivalence)
-open import Relation.Binary.PropositionalEquality as P using (setoid)
-import Relation.Binary.Reasoning.Setoid as SetoidReasoning
-open import Function.Consequences
-
-import Function.Construct.Identity as Identity
-import Function.Construct.Symmetry as Symmetry
-import Function.Construct.Composition as Composition
-
-private
-  variable
-    a b ℓ ℓ₁ ℓ₂ : Level
-    A B C D : Set a
-    S T : Setoid a ℓ
-
-------------------------------------------------------------------------
--- Setoid bundles
-
-isEquivalence : IsEquivalence (Inverse {a} {b})
-isEquivalence = record
-  { refl  = λ {x} → Identity.inverse x
-  ; sym   = Symmetry.inverse
-  ; trans = Composition.inverse
-  }
-
-------------------------------------------------------------------------
--- Propositional bundles
-
--- need to η-expand for everything to line up properly
-↔-isEquivalence : IsEquivalence {ℓ = ℓ} _↔_
-↔-isEquivalence = record
-  { refl  = λ {x} → Identity.inverse (P.setoid x)
-  ; sym   = Symmetry.inverse
-  ; trans = Composition.inverse
-  }
-
-open module ↔ {ℓ} = IsEquivalence (↔-isEquivalence {ℓ}) using ()
-  renaming (refl to ↔-refl; sym to ↔-sym; trans to ↔-trans) public
-
-------------------------------------------------------------------------
--- Conversion functions
-
-Inverse⇒Injection : Inverse S T → Injection S T
-Inverse⇒Injection {S = S} I = record
-  { to = to
-  ; cong = to-cong
-  ; injective = inverseʳ⇒injective S {f⁻¹ = from} from-cong inverseʳ
-  } where open Inverse I
-
-Inverse⇒Bijection : Inverse S T → Bijection S T
-Inverse⇒Bijection {S = S} I = record
-  { to        = to
-  ; cong      = to-cong
-  ; bijective = inverseᵇ⇒bijective S from-cong inverse
-  } where open Inverse I
-
-Inverse⇒Equivalence : Inverse S T → Equivalence S T
-Inverse⇒Equivalence I = record
-  { to        = to
-  ; from      = from
-  ; to-cong   = to-cong
-  ; from-cong = from-cong
-  } where open Inverse I
-
-↔⇒↣ : A ↔ B → A ↣ B
-↔⇒↣ = Inverse⇒Injection
-
-↔⇒⤖ : A ↔ B → A ⤖ B
-↔⇒⤖ = Inverse⇒Bijection
-
-↔⇒⇔ : A ↔ B → A ⇔ B
-↔⇒⇔ = Inverse⇒Equivalence
-
-module _ (ext : ∀ {a b} → Extensionality a b) where
-
-  ↔-fun : A ↔ B → C ↔ D → (A → C) ↔ (B → D)
-  ↔-fun A↔B C↔D = mk↔′
-    (λ a→c b → to C↔D (a→c (from A↔B b)))
-    (λ b→d a → from C↔D (b→d (to A↔B a)))
-    (λ b→d → ext λ _ → P.trans (inverseˡ C↔D _ ) (P.cong b→d (inverseˡ A↔B _)))
-    (λ a→c → ext λ _ → P.trans (inverseʳ C↔D _ ) (P.cong a→c (inverseʳ A↔B _)))
-    where open Inverse
+-- Properties of inverses.
+------------------------------------------------------------------------
+
+{-# OPTIONS --cubical-compatible --safe #-}
+
+module Function.Properties.Inverse where
+
+open import Axiom.Extensionality.Propositional using (Extensionality)
+open import Data.Product.Base using (_,_; proj₁; proj₂)
+open import Function.Bundles
+import Function.Properties.RightInverse as RightInverse
+open import Level using (Level; _⊔_)
+open import Relation.Binary.Core using (REL)
+open import Relation.Binary.Bundles using (Setoid)
+open import Relation.Binary.Structures using (IsEquivalence)
+open import Relation.Binary.PropositionalEquality.Core as P using (_≡_)
+import Relation.Binary.PropositionalEquality.Properties as P
+import Relation.Binary.Reasoning.Setoid as SetoidReasoning
+import Function.Consequences.Setoid as Consequences
+
+import Function.Construct.Identity as Identity
+import Function.Construct.Symmetry as Symmetry
+import Function.Construct.Composition as Composition
+
+private
+  variable
+    a b ℓ ℓ₁ ℓ₂ : Level
+    A B C D : Set a
+    S T U V : Setoid a ℓ
+
+------------------------------------------------------------------------
+-- Setoid bundles
+
+open Identity    public using () renaming (inverse to refl)
+open Symmetry    public using () renaming (inverse to sym)
+open Composition public using () renaming (inverse to trans)
+
+isEquivalence : IsEquivalence (Inverse {a} {b})
+isEquivalence = record
+  { refl  = λ {x} → Identity.inverse x
+  ; sym   = sym
+  ; trans = trans
+  }
+
+------------------------------------------------------------------------
+-- Propositional bundles
+
+↔-refl : A ↔ A
+↔-refl = Identity.↔-id _
+
+↔-sym : A ↔ B → B ↔ A
+↔-sym = Symmetry.↔-sym
+
+↔-trans : A ↔ B → B ↔ C → A ↔ C
+↔-trans = Composition.inverse
+
+-- need to η-expand for everything to line up properly
+↔-isEquivalence : IsEquivalence {ℓ = ℓ} _↔_
+↔-isEquivalence = record
+  { refl  = ↔-refl
+  ; sym   = ↔-sym
+  ; trans = ↔-trans
+  }
+
+------------------------------------------------------------------------
+-- Conversion functions
+
+toFunction : Inverse S T → Func S T
+toFunction I = record { to = to ; cong = to-cong }
+  where open Inverse I
+
+fromFunction : Inverse S T → Func T S
+fromFunction I = record { to = from ; cong = from-cong }
+  where open Inverse I
+
+Inverse⇒Injection : Inverse S T → Injection S T
+Inverse⇒Injection {S = S} {T = T} I = record
+  { to = to
+  ; cong = to-cong
+  ; injective = inverseʳ⇒injective to inverseʳ
+  } where open Inverse I; open Consequences S T
+
+Inverse⇒Surjection : Inverse S T → Surjection S T
+Inverse⇒Surjection {S = S} {T = T} I = record
+  { to = to
+  ; cong = to-cong
+  ; surjective = inverseˡ⇒surjective inverseˡ
+  } where open Inverse I; open Consequences S T
+
+Inverse⇒Bijection : Inverse S T → Bijection S T
+Inverse⇒Bijection {S = S} {T = T} I = record
+  { to        = to
+  ; cong      = to-cong
+  ; bijective = inverseᵇ⇒bijective inverse
+  } where open Inverse I; open Consequences S T
+
+Inverse⇒Equivalence : Inverse S T → Equivalence S T
+Inverse⇒Equivalence I = record
+  { to        = to
+  ; from      = from
+  ; to-cong   = to-cong
+  ; from-cong = from-cong
+  } where open Inverse I
+
+↔⇒⟶ : A ↔ B → A ⟶ B
+↔⇒⟶ = toFunction
+
+↔⇒⟵ : A ↔ B → B ⟶ A
+↔⇒⟵ = fromFunction
+
+↔⇒↣ : A ↔ B → A ↣ B
+↔⇒↣ = Inverse⇒Injection
+
+↔⇒↠ : A ↔ B → A ↠ B
+↔⇒↠ = Inverse⇒Surjection
+
+↔⇒⤖ : A ↔ B → A ⤖ B
+↔⇒⤖ = Inverse⇒Bijection
+
+↔⇒⇔ : A ↔ B → A ⇔ B
+↔⇒⇔ = Inverse⇒Equivalence
+
+↔⇒↩ : A ↔ B → A ↩ B
+↔⇒↩ = Inverse.leftInverse
+
+↔⇒↪ : A ↔ B → A ↪ B
+↔⇒↪ = Inverse.rightInverse
+
+-- The functions above can be combined with the following lemma to
+-- transport an arbitrary relation R (e.g. Injection) across
+-- inverses.
+transportVia : {R : ∀ {a b ℓ₁ ℓ₂} → REL (Setoid a ℓ₁) (Setoid b ℓ₂) (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂)} →
+               (∀ {a b c ℓ₁ ℓ₂ ℓ₃} {S : Setoid a ℓ₁} {T : Setoid b ℓ₂} {U : Setoid c ℓ₃} → R S T → R T U → R S U) →
+               (∀ {a b ℓ₁ ℓ₂} {S : Setoid a ℓ₁} {T : Setoid b ℓ₂} → Inverse S T → R S T) →
+               Inverse S T → R T U → Inverse U V → R S V
+transportVia R-trans inv⇒R IBA RBC ICD =
+  R-trans (inv⇒R IBA) (R-trans RBC (inv⇒R ICD))
+
+------------------------------------------------------------------------
+-- Other
+
+module _ (ext : ∀ {a b} → Extensionality a b) where
+
+  ↔-fun : A ↔ B → C ↔ D → (A → C) ↔ (B → D)
+  ↔-fun A↔B C↔D = mk↔ₛ′
+    (λ a→c b → to C↔D (a→c (from A↔B b)))
+    (λ b→d a → from C↔D (b→d (to A↔B a)))
+    (λ b→d → ext λ _ → P.trans (strictlyInverseˡ C↔D _ ) (P.cong b→d (strictlyInverseˡ A↔B _)))
+    (λ a→c → ext λ _ → P.trans (strictlyInverseʳ C↔D _ ) (P.cong a→c (strictlyInverseʳ A↔B _)))
+    where open Inverse
+
+module _ (I : Inverse S T) where
+  open Inverse I
+
+  to-from : ∀ {x y} → to x Eq₂.≈ y → from y Eq₁.≈ x
+  to-from = RightInverse.to-from rightInverse
\ No newline at end of file diff --git a/Function.Properties.RightInverse.html b/Function.Properties.RightInverse.html index d0230a07..8636402c 100644 --- a/Function.Properties.RightInverse.html +++ b/Function.Properties.RightInverse.html @@ -2,35 +2,82 @@ Function.Properties.RightInverse
------------------------------------------------------------------------
 -- The Agda standard library
 --
--- Conversions for right inverses
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-module Function.Properties.RightInverse where
-
-open import Function.Base
-open import Function.Bundles
-open import Function.Consequences using (inverseʳ⇒surjective)
-open import Level using (Level)
-open import Data.Product
-open import Relation.Binary using (Setoid; IsEquivalence)
-
-private
-  variable
-    ℓ₁ ℓ₂ a b : Level
-    A : Set a
-    B : Set b
-    S : Setoid a ℓ₁
-    T : Setoid b ℓ₂
-
-RightInverse⇒Surjection : RightInverse S T → Surjection T S
-RightInverse⇒Surjection I = record
-  { to         = from
-  ; cong       = from-cong
-  ; surjective = λ a → to a , inverseʳ a
-  } where open RightInverse I
-
-↪⇒↠ : B ↪ A → A ↠ B
-↪⇒↠ = RightInverse⇒Surjection
+-- Properties of right inverses
+------------------------------------------------------------------------
+
+{-# OPTIONS --cubical-compatible --safe #-}
+
+module Function.Properties.RightInverse where
+
+open import Function.Base
+open import Function.Definitions
+open import Function.Bundles
+open import Function.Consequences using (inverseˡ⇒surjective)
+open import Level using (Level)
+open import Data.Product.Base using (_,_)
+open import Relation.Binary.Bundles using (Setoid)
+open import Relation.Binary.Structures using (IsEquivalence)
+
+private
+  variable
+    ℓ₁ ℓ₂ a b : Level
+    A B : Set a
+    S T : Setoid a ℓ₁
+
+------------------------------------------------------------------------
+-- Constructors
+
+mkRightInverse : (e : Equivalence S T) (open Equivalence e) →
+                 Inverseʳ Eq₁._≈_ Eq₂._≈_ to from →
+                 RightInverse S T
+mkRightInverse eq invʳ = record
+  { Equivalence eq
+  ; inverseʳ = invʳ
+  }
+
+------------------------------------------------------------------------
+-- Conversion
+
+RightInverse⇒LeftInverse : RightInverse S T → LeftInverse T S
+RightInverse⇒LeftInverse I = record
+  { to         = from
+  ; from       = to
+  ; to-cong    = from-cong
+  ; from-cong  = to-cong
+  ; inverseˡ   = inverseʳ
+  } where open RightInverse I
+
+LeftInverse⇒RightInverse : LeftInverse S T → RightInverse T S
+LeftInverse⇒RightInverse I = record
+  { to         = from
+  ; from       = to
+  ; to-cong    = from-cong
+  ; from-cong  = to-cong
+  ; inverseʳ    = inverseˡ
+  } where open LeftInverse I
+
+RightInverse⇒Surjection : RightInverse S T → Surjection T S
+RightInverse⇒Surjection I = record
+  { to         = from
+  ; cong       = from-cong
+  ; surjective = inverseˡ⇒surjective Eq₁._≈_ inverseʳ
+  } where open RightInverse I
+
+↪⇒↠ : B ↪ A → A ↠ B
+↪⇒↠ = RightInverse⇒Surjection
+
+↪⇒↩ : B ↪ A → A ↩ B
+↪⇒↩ = RightInverse⇒LeftInverse
+
+↩⇒↪ : B ↩ A → A ↪ B
+↩⇒↪ = LeftInverse⇒RightInverse
+
+------------------------------------------------------------------------
+-- Other
+
+module _ (R : RightInverse S T) where
+  open RightInverse R
+
+  to-from : ∀ {x y} → to x Eq₂.≈ y → from y Eq₁.≈ x
+  to-from eq = Eq₁.trans (from-cong (Eq₂.sym eq)) (strictlyInverseʳ _)
\ No newline at end of file diff --git a/Function.Properties.Surjection.html b/Function.Properties.Surjection.html index 0c2ec84c..54b0ca6e 100644 --- a/Function.Properties.Surjection.html +++ b/Function.Properties.Surjection.html @@ -2,31 +2,81 @@ Function.Properties.Surjection
------------------------------------------------------------------------
 -- The Agda standard library
 --
--- Conversions for surjections
-------------------------------------------------------------------------
+-- Properties of surjections
+------------------------------------------------------------------------
 
-{-# OPTIONS --cubical-compatible --safe #-}
+{-# OPTIONS --cubical-compatible --safe #-}
 
-module Function.Properties.Surjection where
+module Function.Properties.Surjection where
 
-open import Function.Base
-open import Function.Bundles
-open import Level using (Level)
-open import Data.Product
+open import Function.Base
+open import Function.Definitions
+open import Function.Bundles
+import Function.Construct.Identity as Identity
+import Function.Construct.Composition as Compose
+open import Level using (Level)
+open import Data.Product.Base using (proj₁; proj₂)
+import Relation.Binary.PropositionalEquality as P
+open import Relation.Binary.Definitions
+open import Relation.Binary.Bundles using (Setoid)
+import Relation.Binary.Reasoning.Setoid as SetoidReasoning
 
-private
-  variable
-    a b : Level
-    A B : Set a
+private
+  variable
+    a b c ℓ ℓ₁ ℓ₂ ℓ₃ : Level
+    A B : Set a
+    T S : Setoid a ℓ
 
-------------------------------------------------------------------------
--- Conversion functions
+------------------------------------------------------------------------
+-- Constructors
 
-↠⇒↪ : A ↠ B → B ↪ A
-↠⇒↪ s = mk↪ {to = proj₁ ∘ surjective} {from = to} (proj₂ ∘ surjective)
-  where open Surjection s
+mkSurjection : (f : Func S T) (open Func f) →
+              Surjective Eq₁._≈_ Eq₂._≈_ to  →
+              Surjection S T
+mkSurjection f surjective = record
+  { Func f
+  ; surjective = surjective
+  }
+
+------------------------------------------------------------------------
+-- Conversion functions
+
+↠⇒⟶ : A ↠ B → A ⟶ B
+↠⇒⟶ = Surjection.function
+
+↠⇒↪ : A ↠ B → B ↪ A
+↠⇒↪ s = mk↪ {from = to} λ { P.refl → proj₂ (strictlySurjective _)}
+  where open Surjection s
+
+↠⇒⇔ : A ↠ B → A ⇔ B
+↠⇒⇔ s = mk⇔ to (proj₁ ∘ surjective)
+  where open Surjection s
+
+------------------------------------------------------------------------
+-- Setoid properties
+
+refl : Reflexive (Surjection {a} {ℓ})
+refl {x = x} = Identity.surjection x
+
+trans : Trans (Surjection {a} {ℓ₁} {b} {ℓ₂})
+              (Surjection {b} {ℓ₂} {c} {ℓ₃})
+              (Surjection {a} {ℓ₁} {c} {ℓ₃})
+trans = Compose.surjection
+
+------------------------------------------------------------------------
+-- Other
+
+injective⇒to⁻-cong : (surj : Surjection S T) →
+                      (open Surjection surj) →
+                      Injective Eq₁._≈_ Eq₂._≈_ to →
+                      Congruent Eq₂._≈_ Eq₁._≈_ to⁻
+injective⇒to⁻-cong {T = T} surj injective {x} {y} x≈y = injective $ begin
+  to (to⁻ x) ≈⟨ to∘to⁻ x ⟩
+  x          ≈⟨ x≈y ⟩
+  y          ≈⟨ to∘to⁻ y ⟨
+  to (to⁻ y) ∎
+  where
+  open SetoidReasoning T
+  open Surjection surj
 
-↠⇒⇔ : A ↠ B → A ⇔ B
-↠⇒⇔ s = mk⇔ to (proj₁ ∘ surjective)
-  where open Surjection s
\ No newline at end of file diff --git a/Function.Related.Propositional.html b/Function.Related.Propositional.html index c7ce98f5..41fb89eb 100644 --- a/Function.Related.Propositional.html +++ b/Function.Related.Propositional.html @@ -11,377 +11,383 @@ open import Level open import Relation.Binary - using (Sym; Reflexive; Trans; IsEquivalence; Setoid; IsPreorder; Preorder) -open import Function.Bundles -open import Function.Base -open import Relation.Binary.PropositionalEquality as P using (_≡_) - -open import Function.Properties.Surjection using (↠⇒↪; ↠⇒⇔) -open import Function.Properties.RightInverse using (↪⇒↠) -open import Function.Properties.Bijection using (⤖⇒↔; ⤖⇒⇔) -open import Function.Properties.Inverse using (↔⇒⤖) - -import Function.Construct.Symmetry as Symmetry -import Function.Construct.Identity as Identity -import Function.Construct.Composition as Composition - ------------------------------------------------------------------------- --- Relatedness - --- There are several kinds of "relatedness". - --- The idea to include kinds other than equivalence and bijection came --- from Simon Thompson and Bengt Nordström. /NAD - -data Kind : Set where - implication : Kind - reverseImplication : Kind - equivalence : Kind - injection : Kind - reverseInjection : Kind - leftInverse : Kind - surjection : Kind - bijection : Kind - -private - variable - a b c p : Level - A : Set a - B : Set b - C : Set c - k : Kind - --- Interpretation of the codes above. The code "bijection" is --- interpreted as Inverse rather than Bijection; the two types are --- equivalent. - -infix 4 _∼[_]_ - -_∼[_]_ : Set a → Kind → Set b → Set _ -A ∼[ implication ] B = A ⟶ B -A ∼[ reverseImplication ] B = B ⟶ A -A ∼[ equivalence ] B = A ⇔ B -A ∼[ injection ] B = A ↣ B -A ∼[ reverseInjection ] B = B ↣ A -A ∼[ leftInverse ] B = A ↪ B -A ∼[ surjection ] B = A ↠ B -A ∼[ bijection ] B = A ⤖ B - --- A non-infix synonym. - -Related : Kind → Set a → Set b → Set _ -Related k A B = A ∼[ k ] B - --- The bijective equality implies any kind of relatedness. - -⤖⇒ : A ∼[ bijection ] B → A ∼[ k ] B -⤖⇒ {k = implication} = mk⟶ ∘ Bijection.to -⤖⇒ {k = reverseImplication} = mk⟶ ∘ Inverse.from ∘ ⤖⇒↔ -⤖⇒ {k = equivalence} = ⤖⇒⇔ -⤖⇒ {k = injection} = Bijection.injection -⤖⇒ {k = reverseInjection} = Bijection.injection ∘ ↔⇒⤖ ∘ Symmetry.inverse ∘ ⤖⇒↔ -⤖⇒ {k = leftInverse} = Inverse.rightInverse ∘ ⤖⇒↔ -⤖⇒ {k = surjection} = Bijection.surjection -⤖⇒ {k = bijection} = id - --- Propositional equality also implies any kind of relatedness. - -≡⇒ : A ≡ B → A ∼[ k ] B -≡⇒ P.refl = ⤖⇒ (Identity.⤖-id _) - ------------------------------------------------------------------------- --- Special kinds of kinds - --- Kinds whose interpretation is symmetric. - -data SymmetricKind : Set where - equivalence : SymmetricKind - bijection : SymmetricKind - --- Forgetful map. - -⌊_⌋ : SymmetricKind → Kind -⌊ equivalence ⌋ = equivalence -⌊ bijection ⌋ = bijection - --- The proof of symmetry can be found below. - --- Kinds whose interpretation include a function which "goes in the --- forward direction". - -data ForwardKind : Set where - implication : ForwardKind - equivalence : ForwardKind - injection : ForwardKind - leftInverse : ForwardKind - surjection : ForwardKind - bijection : ForwardKind - --- Forgetful map. - -⌊_⌋→ : ForwardKind → Kind -⌊ implication ⌋→ = implication -⌊ equivalence ⌋→ = equivalence -⌊ injection ⌋→ = injection -⌊ leftInverse ⌋→ = leftInverse -⌊ surjection ⌋→ = surjection -⌊ bijection ⌋→ = bijection - --- The function. - -⇒→ : ∀ {k} → A ∼[ ⌊ k ⌋→ ] B → A → B -⇒→ {k = implication} = Func.to -⇒→ {k = equivalence} = Equivalence.to -⇒→ {k = injection} = Injection.to -⇒→ {k = leftInverse} = RightInverse.to -⇒→ {k = surjection} = Surjection.to -⇒→ {k = bijection} = Bijection.to - --- Kinds whose interpretation include a function which "goes backwards". - -data BackwardKind : Set where - reverseImplication : BackwardKind - equivalence : BackwardKind - reverseInjection : BackwardKind - leftInverse : BackwardKind - surjection : BackwardKind - bijection : BackwardKind - --- Forgetful map. - -⌊_⌋← : BackwardKind → Kind -⌊ reverseImplication ⌋← = reverseImplication -⌊ equivalence ⌋← = equivalence -⌊ reverseInjection ⌋← = reverseInjection -⌊ leftInverse ⌋← = leftInverse -⌊ surjection ⌋← = surjection -⌊ bijection ⌋← = bijection - --- The function. - -⇒← : ∀ {k} → A ∼[ ⌊ k ⌋← ] B → B → A -⇒← {k = reverseImplication} = Func.to -⇒← {k = equivalence} = Equivalence.from -⇒← {k = reverseInjection} = Injection.to -⇒← {k = leftInverse} = RightInverse.from -⇒← {k = surjection} = RightInverse.to ∘ ↠⇒↪ -⇒← {k = bijection} = Inverse.from ∘ ⤖⇒↔ - --- Kinds whose interpretation include functions going in both --- directions. - -data EquivalenceKind : Set where - equivalence : EquivalenceKind - leftInverse : EquivalenceKind - surjection : EquivalenceKind - bijection : EquivalenceKind - --- Forgetful map. - -⌊_⌋⇔ : EquivalenceKind → Kind -⌊ equivalence ⌋⇔ = equivalence -⌊ leftInverse ⌋⇔ = leftInverse -⌊ surjection ⌋⇔ = surjection -⌊ bijection ⌋⇔ = bijection - --- The functions. - -⇒⇔ : ∀ {k} → A ∼[ ⌊ k ⌋⇔ ] B → A ∼[ equivalence ] B -⇒⇔ {k = equivalence} = id -⇒⇔ {k = leftInverse} = RightInverse.equivalence -⇒⇔ {k = surjection} = ↠⇒⇔ -⇒⇔ {k = bijection} = ⤖⇒⇔ - --- Conversions between special kinds. - -⇔⌊_⌋ : SymmetricKind → EquivalenceKind -⇔⌊ equivalence ⌋ = equivalence -⇔⌊ bijection ⌋ = bijection - -→⌊_⌋ : EquivalenceKind → ForwardKind -→⌊ equivalence ⌋ = equivalence -→⌊ leftInverse ⌋ = leftInverse -→⌊ surjection ⌋ = surjection -→⌊ bijection ⌋ = bijection - -←⌊_⌋ : EquivalenceKind → BackwardKind -←⌊ equivalence ⌋ = equivalence -←⌊ leftInverse ⌋ = leftInverse -←⌊ surjection ⌋ = surjection -←⌊ bijection ⌋ = bijection - ------------------------------------------------------------------------- --- Opposites - --- For every kind there is an opposite kind. - -_op : Kind → Kind -implication op = reverseImplication -reverseImplication op = implication -equivalence op = equivalence -injection op = reverseInjection -reverseInjection op = injection -leftInverse op = surjection -surjection op = leftInverse -bijection op = bijection - --- For every morphism there is a corresponding reverse morphism of the --- opposite kind. - -reverse : A ∼[ k ] B → B ∼[ k op ] A -reverse {k = implication} = id -reverse {k = reverseImplication} = id -reverse {k = equivalence} = Symmetry.⇔-sym -reverse {k = injection} = id -reverse {k = reverseInjection} = id -reverse {k = leftInverse} = ↪⇒↠ -reverse {k = surjection} = ↠⇒↪ -reverse {k = bijection} = ↔⇒⤖ ∘ Symmetry.↔-sym ∘ ⤖⇒↔ - ------------------------------------------------------------------------- --- For a fixed universe level every kind is a preorder and each --- symmetric kind is an equivalence - -K-refl : Reflexive (Related {a} k) -K-refl {k = implication} = Identity.⟶-id _ -K-refl {k = reverseImplication} = Identity.⟶-id _ -K-refl {k = equivalence} = Identity.⇔-id _ -K-refl {k = injection} = Identity.↣-id _ -K-refl {k = reverseInjection} = Identity.↣-id _ -K-refl {k = leftInverse} = Identity.↪-id _ -K-refl {k = surjection} = Identity.↠-id _ -K-refl {k = bijection} = Identity.⤖-id _ - -K-reflexive : _≡_ Relation.Binary.⇒ Related {a} k -K-reflexive P.refl = K-refl - -K-trans : Trans (Related {a} {b} k) - (Related {b} {c} k) - (Related {a} {c} k) -K-trans {k = implication} = Composition._⟶-∘_ -K-trans {k = reverseImplication} = flip Composition._⟶-∘_ -K-trans {k = equivalence} = Composition._⇔-∘_ -K-trans {k = injection} = Composition._↣-∘_ -K-trans {k = reverseInjection} = flip Composition._↣-∘_ -K-trans {k = leftInverse} = Composition._↪-∘_ -K-trans {k = surjection} = Composition._↠-∘_ -K-trans {k = bijection} = Composition._⤖-∘_ - -SK-sym : ∀ {k} → Sym (Related {a} {b} ⌊ k ⌋) - (Related {b} {a} ⌊ k ⌋) -SK-sym {k = equivalence} = reverse -SK-sym {k = bijection} = reverse - -SK-isEquivalence : ∀ k → IsEquivalence {ℓ = a} (Related ⌊ k ⌋) -SK-isEquivalence k = record - { refl = K-refl - ; sym = SK-sym - ; trans = K-trans - } - -SK-setoid : SymmetricKind → (ℓ : Level) → Setoid _ _ -SK-setoid k ℓ = record { isEquivalence = SK-isEquivalence {ℓ} k } - -K-isPreorder : ∀ k → IsPreorder {ℓ = a} _⤖_ (Related k) -K-isPreorder k = record - { isEquivalence = SK-isEquivalence bijection - ; reflexive = ⤖⇒ - ; trans = K-trans - } - -K-preorder : Kind → (ℓ : Level) → Preorder _ ℓ _ -K-preorder k ℓ = record { isPreorder = K-isPreorder k } - ------------------------------------------------------------------------- --- Equational reasoning - --- Equational reasoning for related things. - -module EquationalReasoning where - - infix 3 _∎ - infixr 2 _∼⟨_⟩_ _⤖⟨_⟩_ _↔⟨_⟩_ _↔⟨⟩_ _≡⟨_⟩_ - - _∼⟨_⟩_ : (A : Set a) → A ∼[ k ] B → B ∼[ k ] C → A ∼[ k ] C - _ ∼⟨ A↝B ⟩ B↝C = K-trans A↝B B↝C - - -- Isomorphisms and bijections can be combined with any other kind of relatedness. - - _⤖⟨_⟩_ : (A : Set a) → A ⤖ B → B ∼[ k ] C → A ∼[ k ] C - A ⤖⟨ A⤖B ⟩ B⇔C = A ∼⟨ ⤖⇒ A⤖B ⟩ B⇔C - - _↔⟨_⟩_ : (A : Set a) → A ↔ B → B ∼[ k ] C → A ∼[ k ] C - A ↔⟨ A↔B ⟩ B⇔C = A ∼⟨ ⤖⇒ (↔⇒⤖ A↔B) ⟩ B⇔C - - _↔⟨⟩_ : (A : Set a) → A ∼[ k ] B → A ∼[ k ] B - A ↔⟨⟩ A⇔B = A⇔B - - _≡⟨_⟩_ : (A : Set a) → A ≡ B → B ∼[ k ] C → A ∼[ k ] C - A ≡⟨ A≡B ⟩ B⇔C = A ∼⟨ ≡⇒ A≡B ⟩ B⇔C - - _∎ : (A : Set a) → A ∼[ k ] A - A ∎ = K-refl - - ------------------------------------------------------------------------- --- Every unary relation induces a preorder and, for symmetric kinds, --- an equivalence. (No claim is made that these relations are unique.) - -InducedRelation₁ : Kind → (P : A → Set p) → A → A → Set _ -InducedRelation₁ k P = λ x y → P x ∼[ k ] P y - -InducedPreorder₁ : Kind → (P : A → Set p) → Preorder _ _ _ -InducedPreorder₁ k P = record - { _≈_ = _≡_ - ; _∼_ = InducedRelation₁ k P - ; isPreorder = record - { isEquivalence = P.isEquivalence - ; reflexive = reflexive ∘ - K-reflexive ∘ - P.cong P - ; trans = K-trans - } - } where open Preorder (K-preorder _ _) - -InducedEquivalence₁ : SymmetricKind → (P : A → Set p) → Setoid _ _ -InducedEquivalence₁ k P = record - { _≈_ = InducedRelation₁ ⌊ k ⌋ P - ; isEquivalence = record - { refl = K-refl - ; sym = SK-sym - ; trans = K-trans - } - } - ------------------------------------------------------------------------- --- Every binary relation induces a preorder and, for symmetric kinds, --- an equivalence. (No claim is made that these relations are unique.) - -InducedRelation₂ : Kind → ∀ {s} → (A → B → Set s) → B → B → Set _ -InducedRelation₂ k _S_ = λ x y → ∀ {z} → (z S x) ∼[ k ] (z S y) - -InducedPreorder₂ : Kind → ∀ {s} → (A → B → Set s) → Preorder _ _ _ -InducedPreorder₂ k _S_ = record - { _≈_ = _≡_ - ; _∼_ = InducedRelation₂ k _S_ - ; isPreorder = record - { isEquivalence = P.isEquivalence - ; reflexive = λ x≡y {z} → - reflexive $ - K-reflexive $ - P.cong (_S_ z) x≡y - - ; trans = λ i↝j j↝k → K-trans i↝j j↝k - } - } where open Preorder (K-preorder _ _) - -InducedEquivalence₂ : SymmetricKind → ∀ {s} → (A → B → Set s) → Setoid _ _ -InducedEquivalence₂ k _S_ = record - { _≈_ = InducedRelation₂ ⌊ k ⌋ _S_ - ; isEquivalence = record - { refl = refl - ; sym = λ i↝j → sym i↝j - ; trans = λ i↝j j↝k → trans i↝j j↝k - } - } where open Setoid (SK-setoid _ _) + using (Rel; REL; Sym; Reflexive; Trans; IsEquivalence; Setoid; IsPreorder; Preorder) +open import Function.Bundles +open import Function.Base +open import Relation.Binary.PropositionalEquality.Core as P using (_≡_) +import Relation.Binary.PropositionalEquality.Properties as P +open import Relation.Binary.Reasoning.Syntax + +open import Function.Properties.Surjection using (↠⇒↪; ↠⇒⇔) +open import Function.Properties.RightInverse using (↪⇒↠) +open import Function.Properties.Bijection using (⤖⇒↔; ⤖⇒⇔) +open import Function.Properties.Inverse using (↔⇒⤖; ↔⇒⇔; ↔⇒↣; ↔⇒↠) + +import Function.Construct.Symmetry as Symmetry +import Function.Construct.Identity as Identity +import Function.Construct.Composition as Composition + +------------------------------------------------------------------------ +-- Relatedness + +-- There are several kinds of "relatedness". + +-- The idea to include kinds other than equivalence and bijection came +-- from Simon Thompson and Bengt Nordström. /NAD + +data Kind : Set where + implication : Kind + reverseImplication : Kind + equivalence : Kind + injection : Kind + reverseInjection : Kind + leftInverse : Kind + surjection : Kind + bijection : Kind + +private + variable + a b c p : Level + A B C : Set a + k : Kind + +-- Interpretation of the codes above. The code "bijection" is +-- interpreted as Inverse rather than Bijection; the two types are +-- equivalent. + +infix 4 _∼[_]_ + +_∼[_]_ : Set a → Kind → Set b → Set _ +A ∼[ implication ] B = A ⟶ B +A ∼[ reverseImplication ] B = B ⟶ A +A ∼[ equivalence ] B = A ⇔ B +A ∼[ injection ] B = A ↣ B +A ∼[ reverseInjection ] B = B ↣ A +A ∼[ leftInverse ] B = A ↪ B +A ∼[ surjection ] B = A ↠ B +A ∼[ bijection ] B = A ↔ B + +-- A non-infix synonym. + +Related : Kind → Set a → Set b → Set _ +Related k A B = A ∼[ k ] B + +-- The bijective equality implies any kind of relatedness. + +↔⇒ : A ∼[ bijection ] B → A ∼[ k ] B +↔⇒ {k = implication} = mk⟶ ∘ Inverse.to +↔⇒ {k = reverseImplication} = mk⟶ ∘ Inverse.from +↔⇒ {k = equivalence} = ↔⇒⇔ +↔⇒ {k = injection} = ↔⇒↣ +↔⇒ {k = reverseInjection} = ↔⇒↣ ∘ Symmetry.inverse +↔⇒ {k = leftInverse} = Inverse.rightInverse +↔⇒ {k = surjection} = ↔⇒↠ +↔⇒ {k = bijection} = id + +-- Propositional equality also implies any kind of relatedness. + +≡⇒ : A ≡ B → A ∼[ k ] B +≡⇒ P.refl = ↔⇒ (Identity.↔-id _) + +------------------------------------------------------------------------ +-- Special kinds of kinds + +-- Kinds whose interpretation is symmetric. + +data SymmetricKind : Set where + equivalence : SymmetricKind + bijection : SymmetricKind + +-- Forgetful map. + +⌊_⌋ : SymmetricKind → Kind +⌊ equivalence ⌋ = equivalence +⌊ bijection ⌋ = bijection + +-- The proof of symmetry can be found below. + +-- Kinds whose interpretation include a function which "goes in the +-- forward direction". + +data ForwardKind : Set where + implication : ForwardKind + equivalence : ForwardKind + injection : ForwardKind + leftInverse : ForwardKind + surjection : ForwardKind + bijection : ForwardKind + +-- Forgetful map. + +⌊_⌋→ : ForwardKind → Kind +⌊ implication ⌋→ = implication +⌊ equivalence ⌋→ = equivalence +⌊ injection ⌋→ = injection +⌊ leftInverse ⌋→ = leftInverse +⌊ surjection ⌋→ = surjection +⌊ bijection ⌋→ = bijection + +-- The function. + +⇒→ : ∀ {k} → A ∼[ ⌊ k ⌋→ ] B → A → B +⇒→ {k = implication} = Func.to +⇒→ {k = equivalence} = Equivalence.to +⇒→ {k = injection} = Injection.to +⇒→ {k = leftInverse} = RightInverse.to +⇒→ {k = surjection} = Surjection.to +⇒→ {k = bijection} = Inverse.to + +-- Kinds whose interpretation include a function which "goes backwards". + +data BackwardKind : Set where + reverseImplication : BackwardKind + equivalence : BackwardKind + reverseInjection : BackwardKind + leftInverse : BackwardKind + surjection : BackwardKind + bijection : BackwardKind + +-- Forgetful map. + +⌊_⌋← : BackwardKind → Kind +⌊ reverseImplication ⌋← = reverseImplication +⌊ equivalence ⌋← = equivalence +⌊ reverseInjection ⌋← = reverseInjection +⌊ leftInverse ⌋← = leftInverse +⌊ surjection ⌋← = surjection +⌊ bijection ⌋← = bijection + +-- The function. + +⇒← : ∀ {k} → A ∼[ ⌊ k ⌋← ] B → B → A +⇒← {k = reverseImplication} = Func.to +⇒← {k = equivalence} = Equivalence.from +⇒← {k = reverseInjection} = Injection.to +⇒← {k = leftInverse} = RightInverse.from +⇒← {k = surjection} = RightInverse.to ∘ ↠⇒↪ +⇒← {k = bijection} = Inverse.from + +-- Kinds whose interpretation include functions going in both +-- directions. + +data EquivalenceKind : Set where + equivalence : EquivalenceKind + leftInverse : EquivalenceKind + surjection : EquivalenceKind + bijection : EquivalenceKind + +-- Forgetful map. + +⌊_⌋⇔ : EquivalenceKind → Kind +⌊ equivalence ⌋⇔ = equivalence +⌊ leftInverse ⌋⇔ = leftInverse +⌊ surjection ⌋⇔ = surjection +⌊ bijection ⌋⇔ = bijection + +-- The functions. + +⇒⇔ : ∀ {k} → A ∼[ ⌊ k ⌋⇔ ] B → A ∼[ equivalence ] B +⇒⇔ {k = equivalence} = id +⇒⇔ {k = leftInverse} = RightInverse.equivalence +⇒⇔ {k = surjection} = ↠⇒⇔ +⇒⇔ {k = bijection} = ↔⇒⇔ + +-- Conversions between special kinds. + +⇔⌊_⌋ : SymmetricKind → EquivalenceKind +⇔⌊ equivalence ⌋ = equivalence +⇔⌊ bijection ⌋ = bijection + +→⌊_⌋ : EquivalenceKind → ForwardKind +→⌊ equivalence ⌋ = equivalence +→⌊ leftInverse ⌋ = leftInverse +→⌊ surjection ⌋ = surjection +→⌊ bijection ⌋ = bijection + +←⌊_⌋ : EquivalenceKind → BackwardKind +←⌊ equivalence ⌋ = equivalence +←⌊ leftInverse ⌋ = leftInverse +←⌊ surjection ⌋ = surjection +←⌊ bijection ⌋ = bijection + +------------------------------------------------------------------------ +-- Opposites + +-- For every kind there is an opposite kind. + +_op : Kind → Kind +implication op = reverseImplication +reverseImplication op = implication +equivalence op = equivalence +injection op = reverseInjection +reverseInjection op = injection +leftInverse op = surjection +surjection op = leftInverse +bijection op = bijection + +-- For every morphism there is a corresponding reverse morphism of the +-- opposite kind. + +reverse : A ∼[ k ] B → B ∼[ k op ] A +reverse {k = implication} = id +reverse {k = reverseImplication} = id +reverse {k = equivalence} = Symmetry.⇔-sym +reverse {k = injection} = id +reverse {k = reverseInjection} = id +reverse {k = leftInverse} = ↪⇒↠ +reverse {k = surjection} = ↠⇒↪ +reverse {k = bijection} = Symmetry.↔-sym + +------------------------------------------------------------------------ +-- For a fixed universe level every kind is a preorder and each +-- symmetric kind is an equivalence + +K-refl : Reflexive (Related {a} k) +K-refl {k = implication} = Identity.⟶-id _ +K-refl {k = reverseImplication} = Identity.⟶-id _ +K-refl {k = equivalence} = Identity.⇔-id _ +K-refl {k = injection} = Identity.↣-id _ +K-refl {k = reverseInjection} = Identity.↣-id _ +K-refl {k = leftInverse} = Identity.↪-id _ +K-refl {k = surjection} = Identity.↠-id _ +K-refl {k = bijection} = Identity.↔-id _ + +K-reflexive : _≡_ Relation.Binary.⇒ Related {a} k +K-reflexive P.refl = K-refl + +K-trans : Trans (Related {a} {b} k) + (Related {b} {c} k) + (Related {a} {c} k) +K-trans {k = implication} = flip Composition._⟶-∘_ +K-trans {k = reverseImplication} = Composition._⟶-∘_ +K-trans {k = equivalence} = flip Composition._⇔-∘_ +K-trans {k = injection} = flip Composition._↣-∘_ +K-trans {k = reverseInjection} = Composition._↣-∘_ +K-trans {k = leftInverse} = flip Composition._↪-∘_ +K-trans {k = surjection} = flip Composition._↠-∘_ +K-trans {k = bijection} = flip Composition._↔-∘_ + +SK-sym : ∀ {k} → Sym (Related {a} {b} ⌊ k ⌋) + (Related {b} {a} ⌊ k ⌋) +SK-sym {k = equivalence} = reverse +SK-sym {k = bijection} = reverse + +SK-isEquivalence : ∀ k → IsEquivalence {ℓ = a} (Related ⌊ k ⌋) +SK-isEquivalence k = record + { refl = K-refl + ; sym = SK-sym + ; trans = K-trans + } + +SK-setoid : SymmetricKind → (ℓ : Level) → Setoid _ _ +SK-setoid k ℓ = record { isEquivalence = SK-isEquivalence {ℓ} k } + +K-isPreorder : ∀ k → IsPreorder {ℓ = a} _↔_ (Related k) +K-isPreorder k = record + { isEquivalence = SK-isEquivalence bijection + ; reflexive = ↔⇒ + ; trans = K-trans + } + +K-preorder : Kind → (ℓ : Level) → Preorder _ ℓ _ +K-preorder k ℓ = record { isPreorder = K-isPreorder k } + +------------------------------------------------------------------------ +-- Equational reasoning + +-- Equational reasoning for related things. Note that we don't use +-- the `Relation.Binary.Reasoning.Syntax` for this as this relation +-- is heterogeneous. + +module EquationalReasoning {k : Kind} where + + -- Combinators with one heterogeneous relation + module _ {a b : Level} where + open begin-syntax (Related {a} {b} k) id public + open ≡-noncomputing-syntax (Related {a} {b} k) public + + -- Combinators with two heterogeneous relations + module _ {a b c : Level} where + private + rel1 = Related {b} {c} k + rel2 = Related {a} {c} k + + open ∼-syntax rel1 rel2 K-trans public + open ⤖-syntax rel1 rel2 (K-trans ∘′ ↔⇒ ∘′ ⤖⇒↔) Symmetry.⤖-sym public + open ↔-syntax rel1 rel2 (K-trans ∘′ ↔⇒) Symmetry.↔-sym public + + -- Combinators with homogeneous relations + module _ {a : Level} where + open end-syntax (Related {a} k) K-refl public + + + infixr 2 _↔⟨⟩_ + _↔⟨⟩_ : (A : Set a) → A ∼[ k ] B → A ∼[ k ] B + A ↔⟨⟩ A⇔B = A⇔B + {-# WARNING_ON_USAGE _↔⟨⟩_ + "Warning: _↔⟨⟩_ was deprecated in v2.0. + Please use _≡⟨⟩_ instead. " + #-} + +------------------------------------------------------------------------ +-- Every unary relation induces a preorder and, for symmetric kinds, +-- an equivalence. (No claim is made that these relations are unique.) + +InducedRelation₁ : Kind → (P : A → Set p) → A → A → Set _ +InducedRelation₁ k P = λ x y → P x ∼[ k ] P y + +InducedPreorder₁ : Kind → (P : A → Set p) → Preorder _ _ _ +InducedPreorder₁ k P = record + { _≈_ = _≡_ + ; _≲_ = InducedRelation₁ k P + ; isPreorder = record + { isEquivalence = P.isEquivalence + ; reflexive = reflexive ∘ + K-reflexive ∘ + P.cong P + ; trans = K-trans + } + } where open Preorder (K-preorder _ _) + +InducedEquivalence₁ : SymmetricKind → (P : A → Set p) → Setoid _ _ +InducedEquivalence₁ k P = record + { _≈_ = InducedRelation₁ ⌊ k ⌋ P + ; isEquivalence = record + { refl = K-refl + ; sym = SK-sym + ; trans = K-trans + } + } + +------------------------------------------------------------------------ +-- Every binary relation induces a preorder and, for symmetric kinds, +-- an equivalence. (No claim is made that these relations are unique.) + +InducedRelation₂ : Kind → ∀ {s} → (A → B → Set s) → B → B → Set _ +InducedRelation₂ k _S_ = λ x y → ∀ {z} → (z S x) ∼[ k ] (z S y) + +InducedPreorder₂ : Kind → ∀ {s} → (A → B → Set s) → Preorder _ _ _ +InducedPreorder₂ k _S_ = record + { _≈_ = _≡_ + ; _≲_ = InducedRelation₂ k _S_ + ; isPreorder = record + { isEquivalence = P.isEquivalence + ; reflexive = λ x≡y {z} → + reflexive $ + K-reflexive $ + P.cong (_S_ z) x≡y + + ; trans = λ i↝j j↝k → K-trans i↝j j↝k + } + } where open Preorder (K-preorder _ _) + +InducedEquivalence₂ : SymmetricKind → ∀ {s} → (A → B → Set s) → Setoid _ _ +InducedEquivalence₂ k _S_ = record + { _≈_ = InducedRelation₂ ⌊ k ⌋ _S_ + ; isEquivalence = record + { refl = refl + ; sym = λ i↝j → sym i↝j + ; trans = λ i↝j j↝k → trans i↝j j↝k + } + } where open Setoid (SK-setoid _ _) \ No newline at end of file diff --git a/Function.Related.TypeIsomorphisms.html b/Function.Related.TypeIsomorphisms.html index 8ef5ad85..72bfa67b 100644 --- a/Function.Related.TypeIsomorphisms.html +++ b/Function.Related.TypeIsomorphisms.html @@ -11,381 +11,327 @@ module Function.Related.TypeIsomorphisms where open import Algebra -open import Algebra.Structures.Biased using (isCommutativeSemiringˡ) +open import Algebra.Structures.Biased using (isCommutativeSemiringˡ) open import Axiom.Extensionality.Propositional using (Extensionality) open import Data.Bool.Base using (true; false) open import Data.Empty using (⊥-elim) open import Data.Empty.Polymorphic using (⊥) renaming (⊥-elim to ⊥ₚ-elim) -open import Data.Product as Prod hiding (swap) -open import Data.Product.Function.NonDependent.Propositional -open import Data.Sum.Base as Sum -open import Data.Sum.Properties using (swap-involutive) -open import Data.Sum.Function.Propositional using (_⊎-cong_) -open import Data.Unit.Polymorphic using (⊤) -open import Level using (Level; Lift; 0ℓ; suc) -open import Function.Base -open import Function.Equality using (_⟨$⟩_) -open import Function.Equivalence as Eq using (_⇔_; Equivalence) -open import Function.Inverse as Inv using (_↔_; Inverse; inverse) -open import Function.Related -open import Relation.Binary hiding (_⇔_) -open import Relation.Binary.PropositionalEquality as P using (_≡_; _≗_) -open import Relation.Nullary.Reflects using (invert) -open import Relation.Nullary using (Dec; ¬_; _because_; ofⁿ) -import Relation.Nullary.Indexed as I -open import Relation.Nullary.Decidable using (True) +open import Data.Product.Base as Prod + using (_×_; Σ; curry; uncurry; _,_; -,_; <_,_>; proj₁; proj₂; ∃₂; ∃) +open import Data.Product.Function.NonDependent.Propositional +open import Data.Sum.Base as Sum +open import Data.Sum.Properties using (swap-involutive) +open import Data.Sum.Function.Propositional using (_⊎-cong_) +open import Data.Unit.Polymorphic using (⊤) +open import Level using (Level; Lift; 0ℓ; suc) +open import Function.Base +open import Function.Bundles +open import Function.Related.Propositional +import Function.Construct.Identity as Identity +open import Relation.Binary hiding (_⇔_) +open import Relation.Binary.PropositionalEquality.Core as P using (_≡_) +open import Relation.Binary.PropositionalEquality.Properties + using (module ≡-Reasoning) +open import Relation.Nullary.Reflects using (invert) +open import Relation.Nullary using (Dec; ¬_; _because_; ofⁿ) +import Relation.Nullary.Indexed as I +open import Relation.Nullary.Decidable using (True) ------------------------------------------------------------------------- --- Properties of Σ and _×_ +private + variable + a b c d : Level + A B C D : Set a --- Σ is associative -Σ-assoc : ∀ {a b c} - {A : Set a} {B : A → Set b} {C : (a : A) → B a → Set c} → - Σ (Σ A B) (uncurry C) ↔ Σ A (λ a → Σ (B a) (C a)) -Σ-assoc = inverse (λ where ((a , b) , c) → (a , b , c)) - (λ where (a , b , c) → ((a , b) , c)) - (λ _ → P.refl) (λ _ → P.refl) +------------------------------------------------------------------------ +-- Properties of Σ and _×_ --- × is commutative +-- Σ is associative +Σ-assoc : ∀ {A : Set a} {B : A → Set b} {C : (a : A) → B a → Set c} → + Σ (Σ A B) (uncurry C) ↔ Σ A (λ a → Σ (B a) (C a)) +Σ-assoc = mk↔ₛ′ Prod.assocʳ Prod.assocˡ (λ _ → P.refl) (λ _ → P.refl) -×-comm : ∀ {a b} (A : Set a) (B : Set b) → (A × B) ↔ (B × A) -×-comm _ _ = inverse Prod.swap Prod.swap (λ _ → P.refl) λ _ → P.refl +-- × is commutative --- × has ⊤ as its identity +×-comm : ∀ (A : Set a) (B : Set b) → (A × B) ↔ (B × A) +×-comm _ _ = mk↔ₛ′ Prod.swap Prod.swap (λ _ → P.refl) λ _ → P.refl -×-identityˡ : ∀ ℓ → LeftIdentity _↔_ (⊤ {ℓ}) _×_ -×-identityˡ _ _ = inverse proj₂ -,_ (λ _ → P.refl) (λ _ → P.refl) +-- × has ⊤ as its identity -×-identityʳ : ∀ ℓ → RightIdentity _↔_ (⊤ {ℓ}) _×_ -×-identityʳ _ _ = inverse proj₁ (_, _) (λ _ → P.refl) (λ _ → P.refl) +×-identityˡ : ∀ ℓ → LeftIdentity {ℓ = ℓ} _↔_ ⊤ _×_ +×-identityˡ _ _ = mk↔ₛ′ proj₂ -,_ (λ _ → P.refl) (λ _ → P.refl) -×-identity : ∀ ℓ → Identity _↔_ ⊤ _×_ -×-identity ℓ = ×-identityˡ ℓ , ×-identityʳ ℓ +×-identityʳ : ∀ ℓ → RightIdentity {ℓ = ℓ} _↔_ ⊤ _×_ +×-identityʳ _ _ = mk↔ₛ′ proj₁ (_, _) (λ _ → P.refl) (λ _ → P.refl) --- × has ⊥ has its zero +×-identity : ∀ ℓ → Identity _↔_ ⊤ _×_ +×-identity ℓ = ×-identityˡ ℓ , ×-identityʳ ℓ -×-zeroˡ : ∀ ℓ → LeftZero _↔_ (⊥ {ℓ}) _×_ -×-zeroˡ ℓ A = inverse proj₁ < id , ⊥ₚ-elim > (λ { () }) (λ _ → P.refl) +-- × has ⊥ has its zero -×-zeroʳ : ∀ ℓ → RightZero _↔_ (⊥ {ℓ}) _×_ -×-zeroʳ ℓ A = inverse proj₂ < ⊥ₚ-elim , id > (λ { () }) λ _ → P.refl +×-zeroˡ : ∀ ℓ → LeftZero {ℓ = ℓ} _↔_ ⊥ _×_ +×-zeroˡ ℓ A = mk↔ₛ′ proj₁ < id , ⊥ₚ-elim > (λ _ → P.refl) (λ { () }) -×-zero : ∀ ℓ → Zero _↔_ ⊥ _×_ -×-zero ℓ = ×-zeroˡ ℓ , ×-zeroʳ ℓ +×-zeroʳ : ∀ ℓ → RightZero {ℓ = ℓ} _↔_ ⊥ _×_ +×-zeroʳ ℓ A = mk↔ₛ′ proj₂ < ⊥ₚ-elim , id > (λ _ → P.refl) (λ { () }) ------------------------------------------------------------------------- --- Properties of ⊎ +×-zero : ∀ ℓ → Zero _↔_ ⊥ _×_ +×-zero ℓ = ×-zeroˡ ℓ , ×-zeroʳ ℓ --- ⊎ is associative +------------------------------------------------------------------------ +-- Properties of ⊎ -⊎-assoc : ∀ ℓ → Associative {ℓ = ℓ} _↔_ _⊎_ -⊎-assoc ℓ _ _ _ = inverse - [ [ inj₁ , inj₂ ∘′ inj₁ ]′ , inj₂ ∘′ inj₂ ]′ - [ inj₁ ∘′ inj₁ , [ inj₁ ∘′ inj₂ , inj₂ ]′ ]′ - [ [ (λ _ → P.refl) , (λ _ → P.refl) ] , (λ _ → P.refl) ] - [ (λ _ → P.refl) , [ (λ _ → P.refl) , (λ _ → P.refl) ] ] +-- ⊎ is associative --- ⊎ is commutative +⊎-assoc : ∀ ℓ → Associative {ℓ = ℓ} _↔_ _⊎_ +⊎-assoc ℓ _ _ _ = mk↔ₛ′ + [ [ inj₁ , inj₂ ∘′ inj₁ ]′ , inj₂ ∘′ inj₂ ]′ + [ inj₁ ∘′ inj₁ , [ inj₁ ∘′ inj₂ , inj₂ ]′ ]′ + [ (λ _ → P.refl) , [ (λ _ → P.refl) , (λ _ → P.refl) ] ] + [ [ (λ _ → P.refl) , (λ _ → P.refl) ] , (λ _ → P.refl) ] -⊎-comm : ∀ {a b} (A : Set a) (B : Set b) → (A ⊎ B) ↔ (B ⊎ A) -⊎-comm _ _ = inverse swap swap swap-involutive swap-involutive +-- ⊎ is commutative --- ⊎ has ⊥ as its identity +⊎-comm : ∀ (A : Set a) (B : Set b) → (A ⊎ B) ↔ (B ⊎ A) +⊎-comm _ _ = mk↔ₛ′ swap swap swap-involutive swap-involutive -⊎-identityˡ : ∀ ℓ → LeftIdentity _↔_ (⊥ {ℓ}) _⊎_ -⊎-identityˡ _ _ = inverse [ (λ ()) , id ]′ inj₂ - [ (λ ()) , (λ _ → P.refl) ] (λ _ → P.refl) +-- ⊎ has ⊥ as its identity -⊎-identityʳ : ∀ ℓ → RightIdentity _↔_ (⊥ {ℓ}) _⊎_ -⊎-identityʳ _ _ = inverse [ id , (λ ()) ]′ inj₁ - [ (λ _ → P.refl) , (λ ()) ] (λ _ → P.refl) +⊎-identityˡ : ∀ ℓ → LeftIdentity _↔_ (⊥ {ℓ}) _⊎_ +⊎-identityˡ _ _ = mk↔ₛ′ [ (λ ()) , id ]′ inj₂ (λ _ → P.refl) + [ (λ ()) , (λ _ → P.refl) ] -⊎-identity : ∀ ℓ → Identity _↔_ ⊥ _⊎_ -⊎-identity ℓ = ⊎-identityˡ ℓ , ⊎-identityʳ ℓ +⊎-identityʳ : ∀ ℓ → RightIdentity _↔_ (⊥ {ℓ}) _⊎_ +⊎-identityʳ _ _ = mk↔ₛ′ [ id , (λ ()) ]′ inj₁ (λ _ → P.refl) + [ (λ _ → P.refl) , (λ ()) ] + +⊎-identity : ∀ ℓ → Identity _↔_ ⊥ _⊎_ +⊎-identity ℓ = ⊎-identityˡ ℓ , ⊎-identityʳ ℓ ------------------------------------------------------------------------ -- Properties of × and ⊎ -- × distributes over ⊎ -×-distribˡ-⊎ : ∀ ℓ → _DistributesOverˡ_ {ℓ = ℓ} _↔_ _×_ _⊎_ -×-distribˡ-⊎ ℓ _ _ _ = inverse - (uncurry λ x → [ inj₁ ∘′ (x ,_) , inj₂ ∘′ (x ,_) ]′) - [ Prod.map₂ inj₁ , Prod.map₂ inj₂ ]′ - (uncurry λ _ → [ (λ _ → P.refl) , (λ _ → P.refl) ]) - [ (λ _ → P.refl) , (λ _ → P.refl) ] - -×-distribʳ-⊎ : ∀ ℓ → _DistributesOverʳ_ {ℓ = ℓ} _↔_ _×_ _⊎_ -×-distribʳ-⊎ ℓ _ _ _ = inverse - (uncurry [ curry inj₁ , curry inj₂ ]′) - [ Prod.map₁ inj₁ , Prod.map₁ inj₂ ]′ - (uncurry [ (λ _ _ → P.refl) , (λ _ _ → P.refl) ]) - [ (λ _ → P.refl) , (λ _ → P.refl) ] - -×-distrib-⊎ : ∀ ℓ → _DistributesOver_ {ℓ = ℓ} _↔_ _×_ _⊎_ -×-distrib-⊎ ℓ = ×-distribˡ-⊎ ℓ , ×-distribʳ-⊎ ℓ - ------------------------------------------------------------------------- --- ⊥, ⊤, _×_ and _⊎_ form a commutative semiring - --- ⊤, _×_ form a commutative monoid - -×-isMagma : ∀ k ℓ → IsMagma {Level.suc ℓ} (Related ⌊ k ⌋) _×_ -×-isMagma k ℓ = record - { isEquivalence = SK-isEquivalence k ℓ - ; ∙-cong = _×-cong_ - } - -×-magma : Symmetric-kind → (ℓ : Level) → Magma _ _ -×-magma k ℓ = record - { isMagma = ×-isMagma k ℓ - } - -×-isSemigroup : ∀ k ℓ → IsSemigroup {Level.suc ℓ} (Related ⌊ k ⌋) _×_ -×-isSemigroup k ℓ = record - { isMagma = ×-isMagma k ℓ - ; assoc = λ _ _ _ → ↔⇒ Σ-assoc - } - -×-semigroup : Symmetric-kind → (ℓ : Level) → Semigroup _ _ -×-semigroup k ℓ = record - { isSemigroup = ×-isSemigroup k ℓ - } - -×-isMonoid : ∀ k ℓ → IsMonoid (Related ⌊ k ⌋) _×_ ⊤ -×-isMonoid k ℓ = record - { isSemigroup = ×-isSemigroup k ℓ - ; identity = (↔⇒ ∘ ×-identityˡ ℓ) , (↔⇒ ∘ ×-identityʳ ℓ) - } - -×-monoid : Symmetric-kind → (ℓ : Level) → Monoid _ _ -×-monoid k ℓ = record - { isMonoid = ×-isMonoid k ℓ - } - -×-isCommutativeMonoid : ∀ k ℓ → IsCommutativeMonoid (Related ⌊ k ⌋) _×_ ⊤ -×-isCommutativeMonoid k ℓ = record - { isMonoid = ×-isMonoid k ℓ - ; comm = λ _ _ → ↔⇒ (×-comm _ _) - } - -×-commutativeMonoid : Symmetric-kind → (ℓ : Level) → CommutativeMonoid _ _ -×-commutativeMonoid k ℓ = record - { isCommutativeMonoid = ×-isCommutativeMonoid k ℓ - } - --- ⊥, _⊎_ form a commutative monoid - -⊎-isMagma : ∀ k ℓ → IsMagma {Level.suc ℓ} (Related ⌊ k ⌋) _⊎_ -⊎-isMagma k ℓ = record - { isEquivalence = SK-isEquivalence k ℓ - ; ∙-cong = _⊎-cong_ - } - -⊎-magma : Symmetric-kind → (ℓ : Level) → Magma _ _ -⊎-magma k ℓ = record - { isMagma = ⊎-isMagma k ℓ - } - -⊎-isSemigroup : ∀ k ℓ → IsSemigroup {Level.suc ℓ} (Related ⌊ k ⌋) _⊎_ -⊎-isSemigroup k ℓ = record - { isMagma = ⊎-isMagma k ℓ - ; assoc = λ A B C → ↔⇒ (⊎-assoc ℓ A B C) - } - -⊎-semigroup : Symmetric-kind → (ℓ : Level) → Semigroup _ _ -⊎-semigroup k ℓ = record - { isSemigroup = ⊎-isSemigroup k ℓ - } - -⊎-isMonoid : ∀ k ℓ → IsMonoid (Related ⌊ k ⌋) _⊎_ ⊥ -⊎-isMonoid k ℓ = record - { isSemigroup = ⊎-isSemigroup k ℓ - ; identity = (↔⇒ ∘ ⊎-identityˡ ℓ) , (↔⇒ ∘ ⊎-identityʳ ℓ) - } - -⊎-monoid : Symmetric-kind → (ℓ : Level) → Monoid _ _ -⊎-monoid k ℓ = record - { isMonoid = ⊎-isMonoid k ℓ - } - -⊎-isCommutativeMonoid : ∀ k ℓ → IsCommutativeMonoid (Related ⌊ k ⌋) _⊎_ ⊥ -⊎-isCommutativeMonoid k ℓ = record - { isMonoid = ⊎-isMonoid k ℓ - ; comm = λ _ _ → ↔⇒ (⊎-comm _ _) - } - -⊎-commutativeMonoid : Symmetric-kind → (ℓ : Level) → - CommutativeMonoid _ _ -⊎-commutativeMonoid k ℓ = record - { isCommutativeMonoid = ⊎-isCommutativeMonoid k ℓ - } - -×-⊎-isCommutativeSemiring : ∀ k ℓ → - IsCommutativeSemiring (Related ⌊ k ⌋) _⊎_ _×_ ⊥ ⊤ -×-⊎-isCommutativeSemiring k ℓ = isCommutativeSemiringˡ record - { +-isCommutativeMonoid = ⊎-isCommutativeMonoid k ℓ - ; *-isCommutativeMonoid = ×-isCommutativeMonoid k ℓ - ; distribʳ = λ A B C → ↔⇒ (×-distribʳ-⊎ ℓ A B C) - ; zeroˡ = ↔⇒ ∘ ×-zeroˡ ℓ - } - -×-⊎-commutativeSemiring : Symmetric-kind → (ℓ : Level) → - CommutativeSemiring (Level.suc ℓ) ℓ -×-⊎-commutativeSemiring k ℓ = record - { isCommutativeSemiring = ×-⊎-isCommutativeSemiring k ℓ - } - ------------------------------------------------------------------------- --- Some reordering lemmas - -ΠΠ↔ΠΠ : ∀ {a b p} {A : Set a} {B : Set b} (P : A → B → Set p) → - ((x : A) (y : B) → P x y) ↔ ((y : B) (x : A) → P x y) -ΠΠ↔ΠΠ _ = inverse flip flip (λ _ → P.refl) (λ _ → P.refl) - -∃∃↔∃∃ : ∀ {a b p} {A : Set a} {B : Set b} (P : A → B → Set p) → - (∃₂ λ x y → P x y) ↔ (∃₂ λ y x → P x y) -∃∃↔∃∃ P = inverse to from (λ _ → P.refl) (λ _ → P.refl) - where - to : (∃₂ λ x y → P x y) → (∃₂ λ y x → P x y) - to (x , y , Pxy) = (y , x , Pxy) - - from : (∃₂ λ y x → P x y) → (∃₂ λ x y → P x y) - from (y , x , Pxy) = (x , y , Pxy) - ------------------------------------------------------------------------- --- Implicit and explicit function spaces are isomorphic - -Π↔Π : ∀ {a b} {A : Set a} {B : A → Set b} → - ((x : A) → B x) ↔ ({x : A} → B x) -Π↔Π = inverse (λ f {x} → f x) (λ f x → f) (λ _ → P.refl) (λ _ → P.refl) - ------------------------------------------------------------------------- --- _→_ preserves the symmetric relations - -_→-cong-⇔_ : - ∀ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d} → - A ⇔ B → C ⇔ D → (A → C) ⇔ (B → D) -A⇔B →-cong-⇔ C⇔D = Eq.equivalence - (λ f x → Equivalence.to C⇔D ⟨$⟩ f (Equivalence.from A⇔B ⟨$⟩ x)) - (λ f x → Equivalence.from C⇔D ⟨$⟩ f (Equivalence.to A⇔B ⟨$⟩ x)) - -→-cong : - ∀ {a b c d} → - Extensionality a c → Extensionality b d → - ∀ {k} {A : Set a} {B : Set b} {C : Set c} {D : Set d} → - A ∼[ ⌊ k ⌋ ] B → C ∼[ ⌊ k ⌋ ] D → (A → C) ∼[ ⌊ k ⌋ ] (B → D) -→-cong extAC extBD {equivalence} A⇔B C⇔D = A⇔B →-cong-⇔ C⇔D -→-cong extAC extBD {bijection} A↔B C↔D = record - { to = Equivalence.to A→C⇔B→D - ; from = Equivalence.from A→C⇔B→D - ; inverse-of = record - { left-inverse-of = λ f → extAC λ x → begin - Inverse.from C↔D ⟨$⟩ (Inverse.to C↔D ⟨$⟩ - f (Inverse.from A↔B ⟨$⟩ (Inverse.to A↔B ⟨$⟩ x))) ≡⟨ Inverse.left-inverse-of C↔D _ ⟩ - f (Inverse.from A↔B ⟨$⟩ (Inverse.to A↔B ⟨$⟩ x)) ≡⟨ P.cong f $ Inverse.left-inverse-of A↔B x ⟩ - f x ∎ - ; right-inverse-of = λ f → extBD λ x → begin - Inverse.to C↔D ⟨$⟩ (Inverse.from C↔D ⟨$⟩ - f (Inverse.to A↔B ⟨$⟩ (Inverse.from A↔B ⟨$⟩ x))) ≡⟨ Inverse.right-inverse-of C↔D _ ⟩ - f (Inverse.to A↔B ⟨$⟩ (Inverse.from A↔B ⟨$⟩ x)) ≡⟨ P.cong f $ Inverse.right-inverse-of A↔B x ⟩ - f x ∎ - } - } - where - open P.≡-Reasoning - A→C⇔B→D = ↔⇒ A↔B →-cong-⇔ ↔⇒ C↔D - ------------------------------------------------------------------------- --- ¬_ (at Level 0) preserves the symmetric relations - -¬-cong-⇔ : ∀ {a b} {A : Set a} {B : Set b} → - A ⇔ B → (¬ A) ⇔ (¬ B) -¬-cong-⇔ A⇔B = A⇔B →-cong-⇔ Eq.id - -¬-cong : ∀ {a b} → Extensionality a 0ℓ → Extensionality b 0ℓ → - ∀ {k} {A : Set a} {B : Set b} → - A ∼[ ⌊ k ⌋ ] B → (¬ A) ∼[ ⌊ k ⌋ ] (¬ B) -¬-cong extA extB A≈B = →-cong extA extB A≈B (K-reflexive P.refl) - ------------------------------------------------------------------------- --- _⇔_ preserves _⇔_ - --- The type of the following proof is a bit more general. - -Related-cong : - ∀ {k a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d} → - A ∼[ ⌊ k ⌋ ] B → C ∼[ ⌊ k ⌋ ] D → (A ∼[ ⌊ k ⌋ ] C) ⇔ (B ∼[ ⌊ k ⌋ ] D) -Related-cong {A = A} {B} {C} {D} A≈B C≈D = - Eq.equivalence (λ A≈C → B ∼⟨ SK-sym A≈B ⟩ - A ∼⟨ A≈C ⟩ - C ∼⟨ C≈D ⟩ - D ∎) - (λ B≈D → A ∼⟨ A≈B ⟩ - B ∼⟨ B≈D ⟩ - D ∼⟨ SK-sym C≈D ⟩ - C ∎) - where open EquationalReasoning - ------------------------------------------------------------------------- --- A lemma relating True dec and P, where dec : Dec P - -True↔ : ∀ {p} {P : Set p} - (dec : Dec P) → ((p₁ p₂ : P) → p₁ ≡ p₂) → True dec ↔ P -True↔ ( true because [p]) irr = - inverse (λ _ → invert [p]) (λ _ → _) (λ _ → P.refl) (irr _) -True↔ (false because ofⁿ ¬p) _ = - inverse (λ()) (invert (ofⁿ ¬p)) (λ ()) (⊥-elim ∘ ¬p) - ------------------------------------------------------------------------- --- Equality between pairs can be expressed as a pair of equalities - -module _ {a b} {A : Set a} {B : A → Set b} {p₁ p₂ : Σ A B} where - Σ-≡,≡→≡ : Σ (proj₁ p₁ ≡ proj₁ p₂) - (λ p → P.subst B p (proj₂ p₁) ≡ proj₂ p₂) → - p₁ ≡ p₂ - Σ-≡,≡→≡ (P.refl , P.refl) = P.refl - - Σ-≡,≡←≡ : p₁ ≡ p₂ → - Σ (proj₁ p₁ ≡ proj₁ p₂) - (λ p → P.subst B p (proj₂ p₁) ≡ proj₂ p₂) - Σ-≡,≡←≡ P.refl = P.refl , P.refl - - private - - left-inverse-of : (p : Σ (proj₁ p₁ ≡ proj₁ p₂) - (λ x → P.subst B x (proj₂ p₁) ≡ proj₂ p₂)) → - Σ-≡,≡←≡ (Σ-≡,≡→≡ p) ≡ p - left-inverse-of (P.refl , P.refl) = P.refl - - right-inverse-of : (p : p₁ ≡ p₂) → Σ-≡,≡→≡ (Σ-≡,≡←≡ p) ≡ p - right-inverse-of P.refl = P.refl - - Σ-≡,≡↔≡ : (∃ λ (p : proj₁ p₁ ≡ proj₁ p₂) → - P.subst B p (proj₂ p₁) ≡ proj₂ p₂) ↔ - p₁ ≡ p₂ - Σ-≡,≡↔≡ = inverse Σ-≡,≡→≡ Σ-≡,≡←≡ left-inverse-of right-inverse-of - -module _ {a b} {A : Set a} {B : Set b} {p₁ p₂ : A × B} where - ×-≡,≡→≡ : (proj₁ p₁ ≡ proj₁ p₂) × (proj₂ p₁ ≡ proj₂ p₂) → p₁ ≡ p₂ - ×-≡,≡→≡ (P.refl , P.refl) = P.refl - - ×-≡,≡←≡ : p₁ ≡ p₂ → - (proj₁ p₁ ≡ proj₁ p₂) × (proj₂ p₁ ≡ proj₂ p₂) - ×-≡,≡←≡ P.refl = P.refl , P.refl - - private - left-inverse-of : (p : (proj₁ p₁ ≡ proj₁ p₂) × (proj₂ p₁ ≡ proj₂ p₂)) → - ×-≡,≡←≡ (×-≡,≡→≡ p) ≡ p - left-inverse-of (P.refl , P.refl) = P.refl - - right-inverse-of : (p : p₁ ≡ p₂) → ×-≡,≡→≡ (×-≡,≡←≡ p) ≡ p - right-inverse-of P.refl = P.refl - - ×-≡,≡↔≡ : (proj₁ p₁ ≡ proj₁ p₂ × proj₂ p₁ ≡ proj₂ p₂) ↔ p₁ ≡ p₂ - ×-≡,≡↔≡ = inverse ×-≡,≡→≡ ×-≡,≡←≡ left-inverse-of right-inverse-of - -×-≡×≡↔≡,≡ : ∀ {a b} {A : Set a} {B : Set b} {x y} (p : A × B) → - (x ≡ proj₁ p × y ≡ proj₂ p) ↔ (x , y) ≡ p -×-≡×≡↔≡,≡ _ = ×-≡,≡↔≡ +×-distribˡ-⊎ : ∀ ℓ → _DistributesOverˡ_ {ℓ = ℓ} _↔_ _×_ _⊎_ +×-distribˡ-⊎ ℓ _ _ _ = mk↔ₛ′ + (uncurry λ x → [ inj₁ ∘′ (x ,_) , inj₂ ∘′ (x ,_) ]′) + [ Prod.map₂ inj₁ , Prod.map₂ inj₂ ]′ + [ (λ _ → P.refl) , (λ _ → P.refl) ] + (uncurry λ _ → [ (λ _ → P.refl) , (λ _ → P.refl) ]) + +×-distribʳ-⊎ : ∀ ℓ → _DistributesOverʳ_ {ℓ = ℓ} _↔_ _×_ _⊎_ +×-distribʳ-⊎ ℓ _ _ _ = mk↔ₛ′ + (uncurry [ curry inj₁ , curry inj₂ ]′) + [ Prod.map₁ inj₁ , Prod.map₁ inj₂ ]′ + [ (λ _ → P.refl) , (λ _ → P.refl) ] + (uncurry [ (λ _ _ → P.refl) , (λ _ _ → P.refl) ]) + +×-distrib-⊎ : ∀ ℓ → _DistributesOver_ {ℓ = ℓ} _↔_ _×_ _⊎_ +×-distrib-⊎ ℓ = ×-distribˡ-⊎ ℓ , ×-distribʳ-⊎ ℓ + +------------------------------------------------------------------------ +-- ⊥, ⊤, _×_ and _⊎_ form a commutative semiring + +-- ⊤, _×_ form a commutative monoid + +×-isMagma : ∀ k ℓ → IsMagma {Level.suc ℓ} (Related ⌊ k ⌋) _×_ +×-isMagma k ℓ = record + { isEquivalence = SK-isEquivalence k + ; ∙-cong = _×-cong_ + } + +×-magma : SymmetricKind → (ℓ : Level) → Magma _ _ +×-magma k ℓ = record + { isMagma = ×-isMagma k ℓ + } + +×-isSemigroup : ∀ k ℓ → IsSemigroup {Level.suc ℓ} (Related ⌊ k ⌋) _×_ +×-isSemigroup k ℓ = record + { isMagma = ×-isMagma k ℓ + ; assoc = λ _ _ _ → ↔⇒ Σ-assoc + } + +×-semigroup : SymmetricKind → (ℓ : Level) → Semigroup _ _ +×-semigroup k ℓ = record + { isSemigroup = ×-isSemigroup k ℓ + } + +×-isMonoid : ∀ k ℓ → IsMonoid (Related ⌊ k ⌋) _×_ ⊤ +×-isMonoid k ℓ = record + { isSemigroup = ×-isSemigroup k ℓ + ; identity = (↔⇒ ∘ ×-identityˡ ℓ) , (↔⇒ ∘ ×-identityʳ ℓ) + } + +×-monoid : SymmetricKind → (ℓ : Level) → Monoid _ _ +×-monoid k ℓ = record + { isMonoid = ×-isMonoid k ℓ + } + +×-isCommutativeMonoid : ∀ k ℓ → IsCommutativeMonoid (Related ⌊ k ⌋) _×_ ⊤ +×-isCommutativeMonoid k ℓ = record + { isMonoid = ×-isMonoid k ℓ + ; comm = λ _ _ → ↔⇒ (×-comm _ _) + } + +×-commutativeMonoid : SymmetricKind → (ℓ : Level) → CommutativeMonoid _ _ +×-commutativeMonoid k ℓ = record + { isCommutativeMonoid = ×-isCommutativeMonoid k ℓ + } + +-- ⊥, _⊎_ form a commutative monoid + +⊎-isMagma : ∀ k ℓ → IsMagma {Level.suc ℓ} (Related ⌊ k ⌋) _⊎_ +⊎-isMagma k ℓ = record + { isEquivalence = SK-isEquivalence k + ; ∙-cong = _⊎-cong_ + } + +⊎-magma : SymmetricKind → (ℓ : Level) → Magma _ _ +⊎-magma k ℓ = record + { isMagma = ⊎-isMagma k ℓ + } + +⊎-isSemigroup : ∀ k ℓ → IsSemigroup {Level.suc ℓ} (Related ⌊ k ⌋) _⊎_ +⊎-isSemigroup k ℓ = record + { isMagma = ⊎-isMagma k ℓ + ; assoc = λ A B C → ↔⇒ (⊎-assoc ℓ A B C) + } + +⊎-semigroup : SymmetricKind → (ℓ : Level) → Semigroup _ _ +⊎-semigroup k ℓ = record + { isSemigroup = ⊎-isSemigroup k ℓ + } + +⊎-isMonoid : ∀ k ℓ → IsMonoid (Related ⌊ k ⌋) _⊎_ ⊥ +⊎-isMonoid k ℓ = record + { isSemigroup = ⊎-isSemigroup k ℓ + ; identity = (↔⇒ ∘ ⊎-identityˡ ℓ) , (↔⇒ ∘ ⊎-identityʳ ℓ) + } + +⊎-monoid : SymmetricKind → (ℓ : Level) → Monoid _ _ +⊎-monoid k ℓ = record + { isMonoid = ⊎-isMonoid k ℓ + } + +⊎-isCommutativeMonoid : ∀ k ℓ → IsCommutativeMonoid (Related ⌊ k ⌋) _⊎_ ⊥ +⊎-isCommutativeMonoid k ℓ = record + { isMonoid = ⊎-isMonoid k ℓ + ; comm = λ _ _ → ↔⇒ (⊎-comm _ _) + } + +⊎-commutativeMonoid : SymmetricKind → (ℓ : Level) → + CommutativeMonoid _ _ +⊎-commutativeMonoid k ℓ = record + { isCommutativeMonoid = ⊎-isCommutativeMonoid k ℓ + } + +×-⊎-isCommutativeSemiring : ∀ k ℓ → + IsCommutativeSemiring (Related ⌊ k ⌋) _⊎_ _×_ ⊥ ⊤ +×-⊎-isCommutativeSemiring k ℓ = isCommutativeSemiringˡ record + { +-isCommutativeMonoid = ⊎-isCommutativeMonoid k ℓ + ; *-isCommutativeMonoid = ×-isCommutativeMonoid k ℓ + ; distribʳ = λ A B C → ↔⇒ (×-distribʳ-⊎ ℓ A B C) + ; zeroˡ = ↔⇒ ∘ ×-zeroˡ ℓ + } + +×-⊎-commutativeSemiring : SymmetricKind → (ℓ : Level) → + CommutativeSemiring (Level.suc ℓ) ℓ +×-⊎-commutativeSemiring k ℓ = record + { isCommutativeSemiring = ×-⊎-isCommutativeSemiring k ℓ + } + +------------------------------------------------------------------------ +-- Some reordering lemmas + +ΠΠ↔ΠΠ : ∀ {a b p} {A : Set a} {B : Set b} (P : A → B → Set p) → + ((x : A) (y : B) → P x y) ↔ ((y : B) (x : A) → P x y) +ΠΠ↔ΠΠ _ = mk↔ₛ′ flip flip (λ _ → P.refl) (λ _ → P.refl) + +∃∃↔∃∃ : ∀ {a b p} {A : Set a} {B : Set b} (P : A → B → Set p) → + (∃₂ λ x y → P x y) ↔ (∃₂ λ y x → P x y) +∃∃↔∃∃ P = mk↔ₛ′ to from (λ _ → P.refl) (λ _ → P.refl) + where + to : (∃₂ λ x y → P x y) → (∃₂ λ y x → P x y) + to (x , y , Pxy) = (y , x , Pxy) + + from : (∃₂ λ y x → P x y) → (∃₂ λ x y → P x y) + from (y , x , Pxy) = (x , y , Pxy) + +------------------------------------------------------------------------ +-- Implicit and explicit function spaces are isomorphic + +Π↔Π : ∀ {A : Set a} {B : A → Set b} → + ((x : A) → B x) ↔ ({x : A} → B x) +Π↔Π = mk↔ₛ′ _$- λ- (λ _ → P.refl) (λ _ → P.refl) + +------------------------------------------------------------------------ +-- _→_ preserves the symmetric relations + +→-cong-⇔ : A ⇔ B → C ⇔ D → (A → C) ⇔ (B → D) +→-cong-⇔ A⇔B C⇔D = mk⇔ + (λ f → to C⇔D ∘ f ∘ from A⇔B) + (λ f → from C⇔D ∘ f ∘ to A⇔B) + where open Equivalence + +→-cong-↔ : Extensionality a c → Extensionality b d → + {A : Set a} {B : Set b} {C : Set c} {D : Set d} → + A ↔ B → C ↔ D → (A → C) ↔ (B → D) +→-cong-↔ ext₁ ext₂ A↔B C↔D = mk↔ₛ′ + (λ f → to C↔D ∘ f ∘ from A↔B) + (λ f → from C↔D ∘ f ∘ to A↔B) + (λ f → ext₂ λ x → begin + to C↔D (from C↔D (f (to A↔B (from A↔B x)))) ≡⟨ strictlyInverseˡ C↔D _ ⟩ + f (to A↔B (from A↔B x)) ≡⟨ P.cong f $ strictlyInverseˡ A↔B x ⟩ + f x ∎) + (λ f → ext₁ λ x → begin + from C↔D (to C↔D (f (from A↔B (to A↔B x)))) ≡⟨ strictlyInverseʳ C↔D _ ⟩ + f (from A↔B (to A↔B x)) ≡⟨ P.cong f $ strictlyInverseʳ A↔B x ⟩ + f x ∎) + where open Inverse; open ≡-Reasoning + +→-cong : Extensionality a c → Extensionality b d → + ∀ {k} {A : Set a} {B : Set b} {C : Set c} {D : Set d} → + A ∼[ ⌊ k ⌋ ] B → C ∼[ ⌊ k ⌋ ] D → (A → C) ∼[ ⌊ k ⌋ ] (B → D) +→-cong extAC extBD {equivalence} = →-cong-⇔ +→-cong extAC extBD {bijection} = →-cong-↔ extAC extBD + +------------------------------------------------------------------------ +-- ¬_ (at Level 0) preserves the symmetric relations + +¬-cong-⇔ : A ⇔ B → (¬ A) ⇔ (¬ B) +¬-cong-⇔ A⇔B = →-cong-⇔ A⇔B (Identity.⇔-id _) + +¬-cong : Extensionality a 0ℓ → Extensionality b 0ℓ → + ∀ {k} {A : Set a} {B : Set b} → + A ∼[ ⌊ k ⌋ ] B → (¬ A) ∼[ ⌊ k ⌋ ] (¬ B) +¬-cong extA extB A≈B = →-cong extA extB A≈B (K-reflexive P.refl) + +------------------------------------------------------------------------ +-- _⇔_ preserves _⇔_ + +-- The type of the following proof is a bit more general. + +Related-cong : + ∀ {k} → + A ∼[ ⌊ k ⌋ ] B → C ∼[ ⌊ k ⌋ ] D → (A ∼[ ⌊ k ⌋ ] C) ⇔ (B ∼[ ⌊ k ⌋ ] D) +Related-cong {A = A} {B = B} {C = C} {D = D} A≈B C≈D = mk⇔ + (λ A≈C → B ∼⟨ SK-sym A≈B ⟩ + A ∼⟨ A≈C ⟩ + C ∼⟨ C≈D ⟩ + D ∎) + (λ B≈D → A ∼⟨ A≈B ⟩ + B ∼⟨ B≈D ⟩ + D ∼⟨ SK-sym C≈D ⟩ + C ∎) + where open EquationalReasoning + +------------------------------------------------------------------------ +-- A lemma relating True dec and P, where dec : Dec P + +True↔ : ∀ {p} {P : Set p} + (dec : Dec P) → ((p₁ p₂ : P) → p₁ ≡ p₂) → True dec ↔ P +True↔ ( true because [p]) irr = + mk↔ₛ′ (λ _ → invert [p]) (λ _ → _) (irr _) (λ _ → P.refl) +True↔ (false because ofⁿ ¬p) _ = + mk↔ₛ′ (λ()) (invert (ofⁿ ¬p)) (⊥-elim ∘ ¬p) (λ ()) \ No newline at end of file diff --git a/Function.Related.html b/Function.Related.html deleted file mode 100644 index c786a832..00000000 --- a/Function.Related.html +++ /dev/null @@ -1,453 +0,0 @@ - -Function.Related
------------------------------------------------------------------------
--- The Agda standard library
---
--- A universe which includes several kinds of "relatedness" for sets,
--- such as equivalences, surjections and bijections
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-module Function.Related where
-
-open import Level
-open import Function.Base
-open import Function.Equality using (_⟨$⟩_)
-open import Function.Equivalence as Eq      using (Equivalence)
-open import Function.Injection   as Inj     using (Injection; _↣_)
-open import Function.Inverse     as Inv     using (Inverse; _↔_)
-open import Function.LeftInverse as LeftInv using (LeftInverse)
-open import Function.Surjection  as Surj    using (Surjection)
-open import Relation.Binary
-open import Relation.Binary.PropositionalEquality as P using (_≡_)
-open import Data.Product using (_,_; proj₁; proj₂; <_,_>)
-
-import Function.Related.Propositional as R
-import Function.Bundles as B
-
-private
-  variable
-    ℓ₁ ℓ₂ : Level
-    A : Set ℓ₁
-    B : Set ℓ₂
-
-------------------------------------------------------------------------
--- Re-export core concepts from non-deprecated Related code
-
-open R public using
-  ( Kind
-  ; implication
-  ; equivalence
-  ; injection
-  ; surjection
-  ; bijection
-  ) renaming
-  ( reverseImplication to reverse-implication
-  ; reverseInjection   to reverse-injection
-  ; leftInverse        to left-inverse
-  )
-
-------------------------------------------------------------------------
--- Wrapper types
-
--- Synonyms which are used to make _∼[_]_ below "constructor-headed"
--- (which implies that Agda can deduce the universe code from an
--- expression matching any of the right-hand sides).
-
-record _←_ {a b} (A : Set a) (B : Set b) : Set (a ⊔ b) where
-  constructor lam
-  field app-← : B → A
-
-open _←_ public
-
-record _↢_ {a b} (A : Set a) (B : Set b) : Set (a ⊔ b) where
-  constructor lam
-  field app-↢ : B ↣ A
-
-open _↢_ public
-
-------------------------------------------------------------------------
--- Relatedness
-
--- There are several kinds of "relatedness".
-
--- The idea to include kinds other than equivalence and bijection came
--- from Simon Thompson and Bengt Nordström. /NAD
-
-infix 4 _∼[_]_
-
-_∼[_]_ : ∀ {ℓ₁ ℓ₂} → Set ℓ₁ → Kind → Set ℓ₂ → Set _
-A ∼[ implication         ] B = A → B
-A ∼[ reverse-implication ] B = A ← B
-A ∼[ equivalence         ] B = Equivalence (P.setoid A) (P.setoid B)
-A ∼[ injection           ] B = Injection   (P.setoid A) (P.setoid B)
-A ∼[ reverse-injection   ] B = A ↢ B
-A ∼[ left-inverse        ] B = LeftInverse (P.setoid A) (P.setoid B)
-A ∼[ surjection          ] B = Surjection  (P.setoid A) (P.setoid B)
-A ∼[ bijection           ] B = Inverse     (P.setoid A) (P.setoid B)
-
-toRelated : {K : Kind} → A R.∼[ K ] B → A ∼[ K ] B
-toRelated {K = implication}         rel = B.Func.to rel
-toRelated {K = reverse-implication} rel = lam (B.Func.to rel)
-toRelated {K = equivalence}         rel = Eq.equivalence (B.Equivalence.to rel) (B.Equivalence.from rel)
-toRelated {K = injection}           rel = Inj.injection (B.Injection.to rel) (B.Injection.injective rel)
-toRelated {K = reverse-injection}   rel = lam (Inj.injection (B.Injection.to rel) (B.Injection.injective rel))
-toRelated {K = left-inverse}        rel =
-  LeftInv.leftInverse (B.RightInverse.to rel) (B.RightInverse.from rel) (B.RightInverse.inverseʳ rel)
-toRelated {K = surjection}          rel with B.Surjection.surjective rel
-... | surj = Surj.surjection (B.Surjection.to rel) (proj₁ ∘ surj) (proj₂ ∘ surj)
-toRelated {K = bijection}           rel with B.Bijection.bijective rel
-... | (inj , surj) = Inv.inverse (B.Bijection.to rel) (proj₁ ∘ surj) (inj ∘ proj₂ ∘ surj ∘ (B.Bijection.to rel)) (proj₂ ∘ surj)
-
-fromRelated : {K : Kind} → A ∼[ K ] B → A R.∼[ K ] B
-fromRelated {K = implication}         rel = B.mk⟶ rel
-fromRelated {K = reverse-implication} rel = B.mk⟶ (app-← rel)
-fromRelated {K = equivalence}         record { to = to ; from = from } = B.mk⇔ (to ⟨$⟩_) (from ⟨$⟩_)
-fromRelated {K = injection}           rel = B.mk↣ (Inj.Injection.injective rel)
-fromRelated {K = reverse-injection}   (lam app-↢) = B.mk↣ (Inj.Injection.injective app-↢)
-fromRelated {K = left-inverse}        record { to = to ; from = from ; left-inverse-of = left-inverse-of } =
-  B.mk↪ {to = to ⟨$⟩_} {from = from ⟨$⟩_} left-inverse-of
-fromRelated {K = surjection}          record { to = to ; surjective = surjective } with surjective
-... | record { from = from ; right-inverse-of = right-inverse-of } = B.mk↠ {to = to ⟨$⟩_} < from ⟨$⟩_ , right-inverse-of >
-fromRelated {K = bijection}           record { to = to ; from = from ; inverse-of = inverse-of } with inverse-of
-... | record { left-inverse-of = left-inverse-of ; right-inverse-of = right-inverse-of } = B.mk⤖
-  ((λ {x y} h → P.subst₂ P._≡_ (left-inverse-of x) (left-inverse-of y) (P.cong (from ⟨$⟩_) h)) ,
-  < from ⟨$⟩_ , right-inverse-of >)
-
--- A non-infix synonym.
-
-Related : Kind → ∀ {ℓ₁ ℓ₂} → Set ℓ₁ → Set ℓ₂ → Set _
-Related k A B = A ∼[ k ] B
-
--- The bijective equality implies any kind of relatedness.
-
-↔⇒ : ∀ {k x y} {X : Set x} {Y : Set y} →
-     X ∼[ bijection ] Y → X ∼[ k ] Y
-↔⇒ {implication}         = _⟨$⟩_ ∘ Inverse.to
-↔⇒ {reverse-implication} = lam ∘′ _⟨$⟩_ ∘ Inverse.from
-↔⇒ {equivalence}         = Inverse.equivalence
-↔⇒ {injection}           = Inverse.injection
-↔⇒ {reverse-injection}   = lam ∘′ Inverse.injection ∘ Inv.sym
-↔⇒ {left-inverse}        = Inverse.left-inverse
-↔⇒ {surjection}          = Inverse.surjection
-↔⇒ {bijection}           = id
-
--- Actual equality also implies any kind of relatedness.
-
-≡⇒ : ∀ {k ℓ} {X Y : Set ℓ} → X ≡ Y → X ∼[ k ] Y
-≡⇒ P.refl = ↔⇒ Inv.id
-
-------------------------------------------------------------------------
--- Special kinds of kinds
-
--- Kinds whose interpretation is symmetric.
-
-data Symmetric-kind : Set where
-  equivalence : Symmetric-kind
-  bijection   : Symmetric-kind
-
--- Forgetful map.
-
-⌊_⌋ : Symmetric-kind → Kind
-⌊ equivalence ⌋ = equivalence
-⌊ bijection   ⌋ = bijection
-
--- The proof of symmetry can be found below.
-
--- Kinds whose interpretation include a function which "goes in the
--- forward direction".
-
-data Forward-kind : Set where
-  implication  : Forward-kind
-  equivalence  : Forward-kind
-  injection    : Forward-kind
-  left-inverse : Forward-kind
-  surjection   : Forward-kind
-  bijection    : Forward-kind
-
--- Forgetful map.
-
-⌊_⌋→ : Forward-kind → Kind
-⌊ implication  ⌋→ = implication
-⌊ equivalence  ⌋→ = equivalence
-⌊ injection    ⌋→ = injection
-⌊ left-inverse ⌋→ = left-inverse
-⌊ surjection   ⌋→ = surjection
-⌊ bijection    ⌋→ = bijection
-
--- The function.
-
-⇒→ : ∀ {k x y} {X : Set x} {Y : Set y} → X ∼[ ⌊ k ⌋→ ] Y → X → Y
-⇒→ {implication}  = id
-⇒→ {equivalence}  = _⟨$⟩_ ∘ Equivalence.to
-⇒→ {injection}    = _⟨$⟩_ ∘ Injection.to
-⇒→ {left-inverse} = _⟨$⟩_ ∘ LeftInverse.to
-⇒→ {surjection}   = _⟨$⟩_ ∘ Surjection.to
-⇒→ {bijection}    = _⟨$⟩_ ∘ Inverse.to
-
--- Kinds whose interpretation include a function which "goes backwards".
-
-data Backward-kind : Set where
-  reverse-implication : Backward-kind
-  equivalence         : Backward-kind
-  reverse-injection   : Backward-kind
-  left-inverse        : Backward-kind
-  surjection          : Backward-kind
-  bijection           : Backward-kind
-
--- Forgetful map.
-
-⌊_⌋← : Backward-kind → Kind
-⌊ reverse-implication ⌋← = reverse-implication
-⌊ equivalence         ⌋← = equivalence
-⌊ reverse-injection   ⌋← = reverse-injection
-⌊ left-inverse        ⌋← = left-inverse
-⌊ surjection          ⌋← = surjection
-⌊ bijection           ⌋← = bijection
-
--- The function.
-
-⇒← : ∀ {k x y} {X : Set x} {Y : Set y} → X ∼[ ⌊ k ⌋← ] Y → Y → X
-⇒← {reverse-implication} = app-←
-⇒← {equivalence}         = _⟨$⟩_ ∘ Equivalence.from
-⇒← {reverse-injection}   = _⟨$⟩_ ∘ Injection.to ∘ app-↢
-⇒← {left-inverse}        = _⟨$⟩_ ∘ LeftInverse.from
-⇒← {surjection}          = _⟨$⟩_ ∘ Surjection.from
-⇒← {bijection}           = _⟨$⟩_ ∘ Inverse.from
-
--- Kinds whose interpretation include functions going in both
--- directions.
-
-data Equivalence-kind : Set where
-    equivalence  : Equivalence-kind
-    left-inverse : Equivalence-kind
-    surjection   : Equivalence-kind
-    bijection    : Equivalence-kind
-
--- Forgetful map.
-
-⌊_⌋⇔ : Equivalence-kind → Kind
-⌊ equivalence  ⌋⇔ = equivalence
-⌊ left-inverse ⌋⇔ = left-inverse
-⌊ surjection   ⌋⇔ = surjection
-⌊ bijection    ⌋⇔ = bijection
-
--- The functions.
-
-⇒⇔ : ∀ {k x y} {X : Set x} {Y : Set y} →
-     X ∼[ ⌊ k ⌋⇔ ] Y → X ∼[ equivalence ] Y
-⇒⇔ {equivalence}  = id
-⇒⇔ {left-inverse} = LeftInverse.equivalence
-⇒⇔ {surjection}   = Surjection.equivalence
-⇒⇔ {bijection}    = Inverse.equivalence
-
--- Conversions between special kinds.
-
-⇔⌊_⌋ : Symmetric-kind → Equivalence-kind
-⇔⌊ equivalence ⌋ = equivalence
-⇔⌊ bijection   ⌋ = bijection
-
-→⌊_⌋ : Equivalence-kind → Forward-kind
-→⌊ equivalence  ⌋ = equivalence
-→⌊ left-inverse ⌋ = left-inverse
-→⌊ surjection   ⌋ = surjection
-→⌊ bijection    ⌋ = bijection
-
-←⌊_⌋ : Equivalence-kind → Backward-kind
-←⌊ equivalence  ⌋ = equivalence
-←⌊ left-inverse ⌋ = left-inverse
-←⌊ surjection   ⌋ = surjection
-←⌊ bijection    ⌋ = bijection
-
-------------------------------------------------------------------------
--- Opposites
-
--- For every kind there is an opposite kind.
-
-_op : Kind → Kind
-implication         op = reverse-implication
-reverse-implication op = implication
-equivalence         op = equivalence
-injection           op = reverse-injection
-reverse-injection   op = injection
-left-inverse        op = surjection
-surjection          op = left-inverse
-bijection           op = bijection
-
--- For every morphism there is a corresponding reverse morphism of the
--- opposite kind.
-
-reverse : ∀ {k a b} {A : Set a} {B : Set b} →
-          A ∼[ k ] B → B ∼[ k op ] A
-reverse {implication}         = lam
-reverse {reverse-implication} = app-←
-reverse {equivalence}         = Eq.sym
-reverse {injection}           = lam
-reverse {reverse-injection}   = app-↢
-reverse {left-inverse}        = Surj.fromRightInverse
-reverse {surjection}          = Surjection.right-inverse
-reverse {bijection}           = Inv.sym
-
-------------------------------------------------------------------------
--- For a fixed universe level every kind is a preorder and each
--- symmetric kind is an equivalence
-
-K-refl : ∀ {k ℓ} → Reflexive (Related k {ℓ})
-K-refl {implication}         = id
-K-refl {reverse-implication} = lam id
-K-refl {equivalence}         = Eq.id
-K-refl {injection}           = Inj.id
-K-refl {reverse-injection}   = lam Inj.id
-K-refl {left-inverse}        = LeftInv.id
-K-refl {surjection}          = Surj.id
-K-refl {bijection}           = Inv.id
-
-K-reflexive : ∀ {k ℓ} → _≡_ ⇒ Related k {ℓ}
-K-reflexive P.refl = K-refl
-
-K-trans : ∀ {k ℓ₁ ℓ₂ ℓ₃} → Trans (Related k {ℓ₁} {ℓ₂})
-                                (Related k {ℓ₂} {ℓ₃})
-                                (Related k {ℓ₁} {ℓ₃})
-K-trans {implication}         = flip _∘′_
-K-trans {reverse-implication} = λ f g → lam (app-← f ∘ app-← g)
-K-trans {equivalence}         = flip Eq._∘_
-K-trans {injection}           = flip Inj._∘_
-K-trans {reverse-injection}   = λ f g → lam (Inj._∘_ (app-↢ f) (app-↢ g))
-K-trans {left-inverse}        = flip LeftInv._∘_
-K-trans {surjection}          = flip Surj._∘_
-K-trans {bijection}           = flip Inv._∘_
-
-SK-sym : ∀ {k ℓ₁ ℓ₂} → Sym (Related ⌊ k ⌋ {ℓ₁} {ℓ₂})
-                          (Related ⌊ k ⌋ {ℓ₂} {ℓ₁})
-SK-sym {equivalence} = Eq.sym
-SK-sym {bijection}   = Inv.sym
-
-SK-isEquivalence : ∀ k ℓ → IsEquivalence {ℓ = ℓ} (Related ⌊ k ⌋)
-SK-isEquivalence k ℓ = record
-  { refl  = K-refl
-  ; sym   = SK-sym
-  ; trans = K-trans
-  }
-
-SK-setoid : Symmetric-kind → (ℓ : Level) → Setoid _ _
-SK-setoid k ℓ = record { isEquivalence = SK-isEquivalence k ℓ }
-
-K-isPreorder : ∀ k ℓ → IsPreorder _↔_ (Related k)
-K-isPreorder k ℓ = record
-    { isEquivalence = SK-isEquivalence bijection ℓ
-    ; reflexive     = ↔⇒
-    ; trans         = K-trans
-    }
-
-K-preorder : Kind → (ℓ : Level) → Preorder _ _ _
-K-preorder k ℓ = record { isPreorder = K-isPreorder k ℓ }
-
-------------------------------------------------------------------------
--- Equational reasoning
-
--- Equational reasoning for related things.
-
-module EquationalReasoning where
-
-  infix  3 _∎
-  infixr 2 _∼⟨_⟩_ _↔⟨_⟩_ _↔⟨⟩_ _≡⟨_⟩_ _≡˘⟨_⟩_
-  infix  1 begin_
-
-  begin_ : ∀ {k x y} {X : Set x} {Y : Set y} →
-           X ∼[ k ] Y → X ∼[ k ] Y
-  begin_ x∼y = x∼y
-
-  _∼⟨_⟩_ : ∀ {k x y z} (X : Set x) {Y : Set y} {Z : Set z} →
-           X ∼[ k ] Y → Y ∼[ k ] Z → X ∼[ k ] Z
-  _ ∼⟨ X↝Y ⟩ Y↝Z = K-trans X↝Y Y↝Z
-
-  -- Isomorphisms can be combined with any other kind of relatedness.
-
-  _↔⟨_⟩_ : ∀ {k x y z} (X : Set x) {Y : Set y} {Z : Set z} →
-           X ↔ Y → Y ∼[ k ] Z → X ∼[ k ] Z
-  X ↔⟨ X↔Y ⟩ Y⇔Z = X ∼⟨ ↔⇒ X↔Y ⟩ Y⇔Z
-
-  _↔⟨⟩_ : ∀ {k x y} (X : Set x) {Y : Set y} →
-          X ∼[ k ] Y → X ∼[ k ] Y
-  X ↔⟨⟩ X⇔Y = X⇔Y
-
-  _≡˘⟨_⟩_ : ∀ {k ℓ z} (X : Set ℓ) {Y : Set ℓ} {Z : Set z} →
-            Y ≡ X → Y ∼[ k ] Z → X ∼[ k ] Z
-  X ≡˘⟨ Y≡X ⟩ Y⇔Z = X ∼⟨ ≡⇒ (P.sym Y≡X) ⟩ Y⇔Z
-
-  _≡⟨_⟩_ : ∀ {k ℓ z} (X : Set ℓ) {Y : Set ℓ} {Z : Set z} →
-           X ≡ Y → Y ∼[ k ] Z → X ∼[ k ] Z
-  X ≡⟨ X≡Y ⟩ Y⇔Z = X ∼⟨ ≡⇒ X≡Y ⟩ Y⇔Z
-
-  _∎ : ∀ {k x} (X : Set x) → X ∼[ k ] X
-  X ∎ = K-refl
-
-------------------------------------------------------------------------
--- Every unary relation induces a preorder and, for symmetric kinds,
--- an equivalence. (No claim is made that these relations are unique.)
-
-InducedRelation₁ : Kind → ∀ {a s} {A : Set a} →
-                   (A → Set s) → A → A → Set _
-InducedRelation₁ k S = λ x y → S x ∼[ k ] S y
-
-InducedPreorder₁ : Kind → ∀ {a s} {A : Set a} →
-                   (A → Set s) → Preorder _ _ _
-InducedPreorder₁ k S = record
-  { _≈_        = _≡_
-  ; _∼_        = InducedRelation₁ k S
-  ; isPreorder = record
-    { isEquivalence = P.isEquivalence
-    ; reflexive     = reflexive ∘
-                      K-reflexive ∘
-                      P.cong S
-    ; trans         = K-trans
-    }
-  } where open Preorder (K-preorder _ _)
-
-InducedEquivalence₁ : Symmetric-kind → ∀ {a s} {A : Set a} →
-                      (A → Set s) → Setoid _ _
-InducedEquivalence₁ k S = record
-  { _≈_           = InducedRelation₁ ⌊ k ⌋ S
-  ; isEquivalence = record
-    { refl  = K-refl
-    ; sym   = SK-sym
-    ; trans = K-trans
-    }
-  }
-
-------------------------------------------------------------------------
--- Every binary relation induces a preorder and, for symmetric kinds,
--- an equivalence. (No claim is made that these relations are unique.)
-
-InducedRelation₂ : Kind → ∀ {a b s} {A : Set a} {B : Set b} →
-                   (A → B → Set s) → B → B → Set _
-InducedRelation₂ k _S_ = λ x y → ∀ {z} → (z S x) ∼[ k ] (z S y)
-
-InducedPreorder₂ : Kind → ∀ {a b s} {A : Set a} {B : Set b} →
-                   (A → B → Set s) → Preorder _ _ _
-InducedPreorder₂ k _S_ = record
-  { _≈_        = _≡_
-  ; _∼_        = InducedRelation₂ k _S_
-  ; isPreorder = record
-    { isEquivalence = P.isEquivalence
-    ; reflexive     = λ x≡y {z} →
-                        reflexive $
-                        K-reflexive $
-                        P.cong (_S_ z) x≡y
-
-    ; trans         = λ i↝j j↝k → K-trans i↝j j↝k
-    }
-  } where open Preorder (K-preorder _ _)
-
-InducedEquivalence₂ : Symmetric-kind →
-                      ∀ {a b s} {A : Set a} {B : Set b} →
-                      (A → B → Set s) → Setoid _ _
-InducedEquivalence₂ k _S_ = record
-  { _≈_           = InducedRelation₂ ⌊ k ⌋ _S_
-  ; isEquivalence = record
-    { refl  = refl
-    ; sym   = λ i↝j → sym i↝j
-    ; trans = λ i↝j j↝k → trans i↝j j↝k
-    }
-  } where open Setoid (SK-setoid _ _)
-
\ No newline at end of file diff --git a/Function.Structures.Biased.html b/Function.Structures.Biased.html new file mode 100644 index 00000000..5bcb15bf --- /dev/null +++ b/Function.Structures.Biased.html @@ -0,0 +1,129 @@ + +Function.Structures.Biased
------------------------------------------------------------------------
+-- The Agda standard library
+--
+-- Ways to give instances of certain structures where some fields can
+-- be given in terms of others.
+-- The contents of this file should usually be accessed from `Function`.
+------------------------------------------------------------------------
+
+
+{-# OPTIONS --cubical-compatible --safe #-}
+
+open import Relation.Binary.Core using (Rel)
+open import Relation.Binary.Bundles using (Setoid)
+open import Relation.Binary.Structures using (IsEquivalence)
+
+module Function.Structures.Biased {a b ℓ₁ ℓ₂}
+  {A : Set a} (_≈₁_ : Rel A ℓ₁) -- Equality over the domain
+  {B : Set b} (_≈₂_ : Rel B ℓ₂) -- Equality over the codomain
+  where
+
+open import Data.Product.Base as Product using (∃; _×_; _,_)
+open import Function.Base
+open import Function.Definitions
+open import Function.Structures _≈₁_ _≈₂_
+open import Function.Consequences.Setoid
+open import Level using (_⊔_)
+
+------------------------------------------------------------------------
+-- Surjection
+------------------------------------------------------------------------
+
+record IsStrictSurjection (f : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
+  field
+    isCongruent : IsCongruent f
+    strictlySurjective : StrictlySurjective _≈₂_ f
+
+  open IsCongruent isCongruent public
+
+  isSurjection : IsSurjection f
+  isSurjection = record
+    { isCongruent = isCongruent
+    ; surjective = strictlySurjective⇒surjective
+        Eq₁.setoid Eq₂.setoid cong strictlySurjective
+    }
+
+open IsStrictSurjection public
+  using () renaming (isSurjection to isStrictSurjection)
+
+------------------------------------------------------------------------
+-- Bijection
+------------------------------------------------------------------------
+
+record IsStrictBijection (f : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
+  field
+    isInjection : IsInjection f
+    strictlySurjective  : StrictlySurjective _≈₂_ f
+
+  isBijection : IsBijection f
+  isBijection = record
+    { isInjection = isInjection
+    ; surjective = strictlySurjective⇒surjective
+        Eq₁.setoid Eq₂.setoid cong strictlySurjective
+    } where open IsInjection isInjection
+
+open IsStrictBijection public
+  using () renaming (isBijection to isStrictBijection)
+
+------------------------------------------------------------------------
+-- Left inverse
+------------------------------------------------------------------------
+
+record IsStrictLeftInverse (to : A → B) (from : B → A) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
+  field
+    isCongruent  : IsCongruent to
+    from-cong    : Congruent _≈₂_ _≈₁_ from
+    strictlyInverseˡ : StrictlyInverseˡ _≈₂_ to from
+
+  isLeftInverse : IsLeftInverse to from
+  isLeftInverse = record
+    { isCongruent = isCongruent
+    ; from-cong = from-cong
+    ; inverseˡ = strictlyInverseˡ⇒inverseˡ
+        Eq₁.setoid Eq₂.setoid cong strictlyInverseˡ
+    } where open IsCongruent isCongruent
+
+open IsStrictLeftInverse public
+  using () renaming (isLeftInverse to isStrictLeftInverse)
+
+------------------------------------------------------------------------
+-- Right inverse
+------------------------------------------------------------------------
+
+record IsStrictRightInverse (to : A → B) (from : B → A) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
+  field
+    isCongruent : IsCongruent to
+    from-cong   : Congruent _≈₂_ _≈₁_ from
+    strictlyInverseʳ : StrictlyInverseʳ _≈₁_ to from
+
+  isRightInverse : IsRightInverse to from
+  isRightInverse = record
+    { isCongruent = isCongruent
+    ; from-cong = from-cong
+    ; inverseʳ = strictlyInverseʳ⇒inverseʳ
+        Eq₁.setoid Eq₂.setoid from-cong strictlyInverseʳ
+    } where open IsCongruent isCongruent
+
+open IsStrictRightInverse public
+  using () renaming (isRightInverse to isStrictRightInverse)
+
+------------------------------------------------------------------------
+-- Inverse
+------------------------------------------------------------------------
+
+record IsStrictInverse (to : A → B) (from : B → A) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
+  field
+    isLeftInverse : IsLeftInverse to from
+    strictlyInverseʳ : StrictlyInverseʳ _≈₁_ to from
+
+  isInverse : IsInverse to from
+  isInverse = record
+    { isLeftInverse = isLeftInverse
+    ; inverseʳ      = strictlyInverseʳ⇒inverseʳ
+        Eq₁.setoid Eq₂.setoid from-cong strictlyInverseʳ
+    } where open IsLeftInverse isLeftInverse
+
+open IsStrictInverse public
+  using () renaming (isInverse to isStrictInverse)
+
\ No newline at end of file diff --git a/Function.Structures.html b/Function.Structures.html index 36ed2d00..328f91ef 100644 --- a/Function.Structures.html +++ b/Function.Structures.html @@ -9,146 +9,183 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Binary.Structures using (IsEquivalence) -module Function.Structures {a b ℓ₁ ℓ₂} - {A : Set a} (_≈₁_ : Rel A ℓ₁) -- Equality over the domain - {B : Set b} (_≈₂_ : Rel B ℓ₂) -- Equality over the codomain - where +module Function.Structures {a b ℓ₁ ℓ₂} + {A : Set a} (_≈₁_ : Rel A ℓ₁) -- Equality over the domain + {B : Set b} (_≈₂_ : Rel B ℓ₂) -- Equality over the codomain + where -open import Data.Product using (∃; _×_; _,_) -open import Function.Base -open import Function.Definitions -open import Level using (_⊔_) +open import Data.Product.Base as Product using (∃; _×_; _,_) +open import Function.Base +open import Function.Definitions +open import Level using (_⊔_) ------------------------------------------------------------------------- --- One element structures ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- One element structures +------------------------------------------------------------------------ -record IsCongruent (to : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - cong : Congruent _≈₁_ _≈₂_ to - isEquivalence₁ : IsEquivalence _≈₁_ - isEquivalence₂ : IsEquivalence _≈₂_ +record IsCongruent (to : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + cong : Congruent _≈₁_ _≈₂_ to + isEquivalence₁ : IsEquivalence _≈₁_ + isEquivalence₂ : IsEquivalence _≈₂_ - module Eq₁ where + module Eq₁ where - setoid : Setoid a ℓ₁ - setoid = record - { isEquivalence = isEquivalence₁ - } + setoid : Setoid a ℓ₁ + setoid = record + { isEquivalence = isEquivalence₁ + } - open Setoid setoid public + open Setoid setoid public - module Eq₂ where + module Eq₂ where - setoid : Setoid b ℓ₂ - setoid = record - { isEquivalence = isEquivalence₂ - } + setoid : Setoid b ℓ₂ + setoid = record + { isEquivalence = isEquivalence₂ + } - open Setoid setoid public + open Setoid setoid public -record IsInjection (to : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - isCongruent : IsCongruent to - injective : Injective _≈₁_ _≈₂_ to +record IsInjection (to : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + isCongruent : IsCongruent to + injective : Injective _≈₁_ _≈₂_ to - open IsCongruent isCongruent public + open IsCongruent isCongruent public -record IsSurjection (f : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - isCongruent : IsCongruent f - surjective : Surjective _≈₁_ _≈₂_ f +record IsSurjection (f : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + isCongruent : IsCongruent f + surjective : Surjective _≈₁_ _≈₂_ f - open IsCongruent isCongruent public + open IsCongruent isCongruent public + strictlySurjective : StrictlySurjective _≈₂_ f + strictlySurjective x = Product.map₂ (λ v → v Eq₁.refl) (surjective x) -record IsBijection (f : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - isInjection : IsInjection f - surjective : Surjective _≈₁_ _≈₂_ f - open IsInjection isInjection public +record IsBijection (f : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + isInjection : IsInjection f + surjective : Surjective _≈₁_ _≈₂_ f - bijective : Bijective _≈₁_ _≈₂_ f - bijective = injective , surjective + open IsInjection isInjection public - isSurjection : IsSurjection f - isSurjection = record - { isCongruent = isCongruent - ; surjective = surjective - } + bijective : Bijective _≈₁_ _≈₂_ f + bijective = injective , surjective + isSurjection : IsSurjection f + isSurjection = record + { isCongruent = isCongruent + ; surjective = surjective + } ------------------------------------------------------------------------- --- Two element structures ------------------------------------------------------------------------- + open IsSurjection isSurjection public + using (strictlySurjective) -record IsLeftInverse (to : A → B) (from : B → A) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - isCongruent : IsCongruent to - from-cong : Congruent _≈₂_ _≈₁_ from - inverseˡ : Inverseˡ _≈₁_ _≈₂_ to from - open IsCongruent isCongruent public - renaming (cong to to-cong) +------------------------------------------------------------------------ +-- Two element structures +------------------------------------------------------------------------ +record IsLeftInverse (to : A → B) (from : B → A) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + isCongruent : IsCongruent to + from-cong : Congruent _≈₂_ _≈₁_ from + inverseˡ : Inverseˡ _≈₁_ _≈₂_ to from -record IsRightInverse (to : A → B) (from : B → A) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - isCongruent : IsCongruent to - from-cong : Congruent _≈₂_ _≈₁_ from - inverseʳ : Inverseʳ _≈₁_ _≈₂_ to from + open IsCongruent isCongruent public + renaming (cong to to-cong) - open IsCongruent isCongruent public - renaming (cong to cong₁) + strictlyInverseˡ : StrictlyInverseˡ _≈₂_ to from + strictlyInverseˡ x = inverseˡ Eq₁.refl + isSurjection : IsSurjection to + isSurjection = record + { isCongruent = isCongruent + ; surjective = λ y → from y , inverseˡ + } -record IsInverse (to : A → B) (from : B → A) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - isLeftInverse : IsLeftInverse to from - inverseʳ : Inverseʳ _≈₁_ _≈₂_ to from - open IsLeftInverse isLeftInverse public +record IsRightInverse (to : A → B) (from : B → A) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + isCongruent : IsCongruent to + from-cong : Congruent _≈₂_ _≈₁_ from + inverseʳ : Inverseʳ _≈₁_ _≈₂_ to from - isRightInverse : IsRightInverse to from - isRightInverse = record - { isCongruent = isCongruent - ; from-cong = from-cong - ; inverseʳ = inverseʳ - } + open IsCongruent isCongruent public + renaming (cong to to-cong) - inverse : Inverseᵇ _≈₁_ _≈₂_ to from - inverse = inverseˡ , inverseʳ + strictlyInverseʳ : StrictlyInverseʳ _≈₁_ to from + strictlyInverseʳ x = inverseʳ Eq₂.refl ------------------------------------------------------------------------- --- Three element structures ------------------------------------------------------------------------- +record IsInverse (to : A → B) (from : B → A) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + isLeftInverse : IsLeftInverse to from + inverseʳ : Inverseʳ _≈₁_ _≈₂_ to from -record IsBiEquivalence - (to : A → B) (from₁ : B → A) (from₂ : B → A) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - to-isCongruent : IsCongruent to - from₁-cong : Congruent _≈₂_ _≈₁_ from₁ - from₂-cong : Congruent _≈₂_ _≈₁_ from₂ + open IsLeftInverse isLeftInverse public - open IsCongruent to-isCongruent public - renaming (cong to to-cong₁) + isRightInverse : IsRightInverse to from + isRightInverse = record + { isCongruent = isCongruent + ; from-cong = from-cong + ; inverseʳ = inverseʳ + } + open IsRightInverse isRightInverse public + using (strictlyInverseʳ) -record IsBiInverse - (to : A → B) (from₁ : B → A) (from₂ : B → A) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - to-isCongruent : IsCongruent to - from₁-cong : Congruent _≈₂_ _≈₁_ from₁ - from₂-cong : Congruent _≈₂_ _≈₁_ from₂ - inverseˡ : Inverseˡ _≈₁_ _≈₂_ to from₁ - inverseʳ : Inverseʳ _≈₁_ _≈₂_ to from₂ + inverse : Inverseᵇ _≈₁_ _≈₂_ to from + inverse = inverseˡ , inverseʳ - open IsCongruent to-isCongruent public - renaming (cong to to-cong) + +------------------------------------------------------------------------ +-- Three element structures +------------------------------------------------------------------------ + +record IsBiEquivalence + (to : A → B) (from₁ : B → A) (from₂ : B → A) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + to-isCongruent : IsCongruent to + from₁-cong : Congruent _≈₂_ _≈₁_ from₁ + from₂-cong : Congruent _≈₂_ _≈₁_ from₂ + + open IsCongruent to-isCongruent public + renaming (cong to to-cong₁) + + +record IsBiInverse + (to : A → B) (from₁ : B → A) (from₂ : B → A) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + to-isCongruent : IsCongruent to + from₁-cong : Congruent _≈₂_ _≈₁_ from₁ + from₂-cong : Congruent _≈₂_ _≈₁_ from₂ + inverseˡ : Inverseˡ _≈₁_ _≈₂_ to from₁ + inverseʳ : Inverseʳ _≈₁_ _≈₂_ to from₂ + + open IsCongruent to-isCongruent public + renaming (cong to to-cong) + + +------------------------------------------------------------------------ +-- Other +------------------------------------------------------------------------ + +-- See the comment on `SplitSurjection` in `Function.Bundles` for an +-- explanation of (split) surjections. +record IsSplitSurjection (f : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + from : B → A + isLeftInverse : IsLeftInverse f from + + open IsLeftInverse isLeftInverse public \ No newline at end of file diff --git a/Function.Surjection.html b/Function.Surjection.html deleted file mode 100644 index 4906b45a..00000000 --- a/Function.Surjection.html +++ /dev/null @@ -1,133 +0,0 @@ - -Function.Surjection
------------------------------------------------------------------------
--- The Agda standard library
---
--- Surjections
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
--- Note: use of the standard function hierarchy is encouraged. The
--- module `Function` re-exports `Surjective`, `IsSurjection` and
--- `Surjection`. The alternative definitions found in this file will
--- eventually be deprecated.
-
-module Function.Surjection where
-
-open import Level
-open import Function.Equality as F
-  using (_⟶_) renaming (_∘_ to _⟪∘⟫_)
-open import Function.Equivalence using (Equivalence)
-open import Function.Injection           hiding (id; _∘_; injection)
-open import Function.LeftInverse as Left hiding (id; _∘_)
-open import Data.Product
-open import Relation.Binary
-open import Relation.Binary.PropositionalEquality as P using (_≡_)
-
-------------------------------------------------------------------------
--- Surjective functions.
-
-record Surjective {f₁ f₂ t₁ t₂}
-                  {From : Setoid f₁ f₂} {To : Setoid t₁ t₂}
-                  (to : From ⟶ To) :
-                  Set (f₁ ⊔ f₂ ⊔ t₁ ⊔ t₂) where
-  field
-    from             : To ⟶ From
-    right-inverse-of : from RightInverseOf to
-
-------------------------------------------------------------------------
--- The set of all surjections from one setoid to another.
-
-record Surjection {f₁ f₂ t₁ t₂}
-                  (From : Setoid f₁ f₂) (To : Setoid t₁ t₂) :
-                  Set (f₁ ⊔ f₂ ⊔ t₁ ⊔ t₂) where
-  field
-    to         : From ⟶ To
-    surjective : Surjective to
-
-  open Surjective surjective public
-
-  right-inverse : RightInverse From To
-  right-inverse = record
-    { to              = from
-    ; from            = to
-    ; left-inverse-of = right-inverse-of
-    }
-
-  open LeftInverse right-inverse public
-    using () renaming (to-from to from-to)
-
-  injective : Injective from
-  injective = LeftInverse.injective right-inverse
-
-  injection : Injection To From
-  injection = LeftInverse.injection right-inverse
-
-  equivalence : Equivalence From To
-  equivalence = record
-    { to   = to
-    ; from = from
-    }
-
--- Right inverses can be turned into surjections.
-
-fromRightInverse :
-  ∀ {f₁ f₂ t₁ t₂} {From : Setoid f₁ f₂} {To : Setoid t₁ t₂} →
-  RightInverse From To → Surjection From To
-fromRightInverse r = record
-  { to         = from
-  ; surjective = record
-    { from             = to
-    ; right-inverse-of = left-inverse-of
-    }
-  } where open LeftInverse r
-
-------------------------------------------------------------------------
--- The set of all surjections from one set to another (i.e. sujections
--- with propositional equality)
-
-infix 3 _↠_
-
-_↠_ : ∀ {f t} → Set f → Set t → Set _
-From ↠ To = Surjection (P.setoid From) (P.setoid To)
-
-surjection : ∀ {f t} {From : Set f} {To : Set t} →
-             (to : From → To) (from : To → From) →
-             (∀ x → to (from x) ≡ x) →
-             From ↠ To
-surjection to from surjective = record
-  { to         = P.→-to-⟶ to
-  ; surjective = record
-    { from             = P.→-to-⟶ from
-    ; right-inverse-of = surjective
-    }
-  }
-
-------------------------------------------------------------------------
--- Identity and composition.
-
-id : ∀ {s₁ s₂} {S : Setoid s₁ s₂} → Surjection S S
-id {S = S} = record
-  { to         = F.id
-  ; surjective = record
-    { from             = LeftInverse.to              id′
-    ; right-inverse-of = LeftInverse.left-inverse-of id′
-    }
-  } where id′ = Left.id {S = S}
-
-infixr 9 _∘_
-
-_∘_ : ∀ {f₁ f₂ m₁ m₂ t₁ t₂}
-        {F : Setoid f₁ f₂} {M : Setoid m₁ m₂} {T : Setoid t₁ t₂} →
-      Surjection M T → Surjection F M → Surjection F T
-f ∘ g = record
-  { to         = to f ⟪∘⟫ to g
-  ; surjective = record
-    { from             = LeftInverse.to              g∘f
-    ; right-inverse-of = LeftInverse.left-inverse-of g∘f
-    }
-  }
-  where
-  open Surjection
-  g∘f = Left._∘_ (right-inverse g) (right-inverse f)
-
\ No newline at end of file diff --git a/Function.html b/Function.html index 6cfa0090..e3f10898 100644 --- a/Function.html +++ b/Function.html @@ -14,5 +14,6 @@ open import Function.Strict public open import Function.Definitions public open import Function.Structures public -open import Function.Bundles public +open import Function.Structures.Biased public +open import Function.Bundles public \ No newline at end of file diff --git a/Induction.Lexicographic.html b/Induction.Lexicographic.html index 67b1ab7b..20b3e269 100644 --- a/Induction.Lexicographic.html +++ b/Induction.Lexicographic.html @@ -9,77 +9,77 @@ module Induction.Lexicographic where -open import Data.Product -open import Induction -open import Level - --- The structure of lexicographic induction. - -Σ-Rec : ∀ {a b ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : A → Set b} → - RecStruct A (ℓ₁ ⊔ b) ℓ₂ → (∀ x → RecStruct (B x) ℓ₁ ℓ₃) → - RecStruct (Σ A B) _ _ -Σ-Rec RecA RecB P (x , y) = - -- Either x is constant and y is "smaller", ... - RecB x (λ y′ → P (x , y′)) y - × - -- ...or x is "smaller" and y is arbitrary. - RecA (λ x′ → ∀ y′ → P (x′ , y′)) x - -infixr 2 _⊗_ - -_⊗_ : ∀ {a b ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : Set b} → - RecStruct A (ℓ₁ ⊔ b) ℓ₂ → RecStruct B ℓ₁ ℓ₃ → - RecStruct (A × B) _ _ -RecA ⊗ RecB = Σ-Rec RecA (λ _ → RecB) - --- Constructs a recursor builder for lexicographic induction. - -Σ-rec-builder : - ∀ {a b ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : A → Set b} - {RecA : RecStruct A (ℓ₁ ⊔ b) ℓ₂} - {RecB : ∀ x → RecStruct (B x) ℓ₁ ℓ₃} → - RecursorBuilder RecA → (∀ x → RecursorBuilder (RecB x)) → - RecursorBuilder (Σ-Rec RecA RecB) -Σ-rec-builder {RecA = RecA} {RecB = RecB} recA recB P f (x , y) = - (p₁ x y p₂x , p₂x) - where - p₁ : ∀ x y → - RecA (λ x′ → ∀ y′ → P (x′ , y′)) x → - RecB x (λ y′ → P (x , y′)) y - p₁ x y x-rec = recB x - (λ y′ → P (x , y′)) - (λ y y-rec → f (x , y) (y-rec , x-rec)) - y - - p₂ : ∀ x → RecA (λ x′ → ∀ y′ → P (x′ , y′)) x - p₂ = recA (λ x → ∀ y → P (x , y)) - (λ x x-rec y → f (x , y) (p₁ x y x-rec , x-rec)) - - p₂x = p₂ x - -[_⊗_] : ∀ {a b ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : Set b} - {RecA : RecStruct A (ℓ₁ ⊔ b) ℓ₂} {RecB : RecStruct B ℓ₁ ℓ₃} → - RecursorBuilder RecA → RecursorBuilder RecB → - RecursorBuilder (RecA ⊗ RecB) -[ recA ⊗ recB ] = Σ-rec-builder recA (λ _ → recB) - ------------------------------------------------------------------------- --- Example - -private - - open import Data.Nat.Base - open import Data.Nat.Induction as N - - -- The Ackermann function à la Rózsa Péter. - - ackermann : ℕ → ℕ → ℕ - ackermann m n = - build [ N.recBuilder ⊗ N.recBuilder ] - (λ _ → ℕ) - (λ { (zero , n) _ → 1 + n - ; (suc m , zero) (_ , ackm•) → ackm• 1 - ; (suc m , suc n) (ack[1+m]n , ackm•) → ackm• ack[1+m]n - }) - (m , n) +open import Data.Product.Base using (Σ; _,_; _×_) +open import Induction +open import Level + +-- The structure of lexicographic induction. + +Σ-Rec : ∀ {a b ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : A → Set b} → + RecStruct A (ℓ₁ ⊔ b) ℓ₂ → (∀ x → RecStruct (B x) ℓ₁ ℓ₃) → + RecStruct (Σ A B) _ _ +Σ-Rec RecA RecB P (x , y) = + -- Either x is constant and y is "smaller", ... + RecB x (λ y′ → P (x , y′)) y + × + -- ...or x is "smaller" and y is arbitrary. + RecA (λ x′ → ∀ y′ → P (x′ , y′)) x + +infixr 2 _⊗_ + +_⊗_ : ∀ {a b ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : Set b} → + RecStruct A (ℓ₁ ⊔ b) ℓ₂ → RecStruct B ℓ₁ ℓ₃ → + RecStruct (A × B) _ _ +RecA ⊗ RecB = Σ-Rec RecA (λ _ → RecB) + +-- Constructs a recursor builder for lexicographic induction. + +Σ-rec-builder : + ∀ {a b ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : A → Set b} + {RecA : RecStruct A (ℓ₁ ⊔ b) ℓ₂} + {RecB : ∀ x → RecStruct (B x) ℓ₁ ℓ₃} → + RecursorBuilder RecA → (∀ x → RecursorBuilder (RecB x)) → + RecursorBuilder (Σ-Rec RecA RecB) +Σ-rec-builder {RecA = RecA} {RecB = RecB} recA recB P f (x , y) = + (p₁ x y p₂x , p₂x) + where + p₁ : ∀ x y → + RecA (λ x′ → ∀ y′ → P (x′ , y′)) x → + RecB x (λ y′ → P (x , y′)) y + p₁ x y x-rec = recB x + (λ y′ → P (x , y′)) + (λ y y-rec → f (x , y) (y-rec , x-rec)) + y + + p₂ : ∀ x → RecA (λ x′ → ∀ y′ → P (x′ , y′)) x + p₂ = recA (λ x → ∀ y → P (x , y)) + (λ x x-rec y → f (x , y) (p₁ x y x-rec , x-rec)) + + p₂x = p₂ x + +[_⊗_] : ∀ {a b ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : Set b} + {RecA : RecStruct A (ℓ₁ ⊔ b) ℓ₂} {RecB : RecStruct B ℓ₁ ℓ₃} → + RecursorBuilder RecA → RecursorBuilder RecB → + RecursorBuilder (RecA ⊗ RecB) +[ recA ⊗ recB ] = Σ-rec-builder recA (λ _ → recB) + +------------------------------------------------------------------------ +-- Example + +private + + open import Data.Nat.Base + open import Data.Nat.Induction as N + + -- The Ackermann function à la Rózsa Péter. + + ackermann : ℕ → ℕ → ℕ + ackermann m n = + build [ N.recBuilder ⊗ N.recBuilder ] + (λ _ → ℕ) + (λ { (zero , n) _ → 1 + n + ; (suc m , zero) (_ , ackm•) → ackm• 1 + ; (suc m , suc n) (ack[1+m]n , ackm•) → ackm• ack[1+m]n + }) + (m , n) \ No newline at end of file diff --git a/Induction.WellFounded.html b/Induction.WellFounded.html index ce320a63..18248f2d 100644 --- a/Induction.WellFounded.html +++ b/Induction.WellFounded.html @@ -7,235 +7,261 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary +module Induction.WellFounded where -module Induction.WellFounded where +open import Data.Product.Base using (Σ; _,_; proj₁; proj₂) +open import Function.Base using (_∘_; flip; _on_) +open import Induction +open import Level using (Level; _⊔_) +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Definitions + using (Symmetric; Asymmetric; Irreflexive; _Respects₂_; + _Respectsʳ_; _Respects_) +open import Relation.Binary.PropositionalEquality.Core using (_≡_; refl) +open import Relation.Binary.Consequences using (asym⇒irr) +open import Relation.Unary +open import Relation.Nullary.Negation.Core using (¬_) -open import Data.Product -open import Function -open import Induction -open import Level -open import Relation.Binary.PropositionalEquality hiding (trans) -open import Relation.Unary +private + variable + a b ℓ ℓ₁ ℓ₂ r : Level + A : Set a + B : Set b -private - variable - a b ℓ ℓ₁ ℓ₂ r : Level - A : Set a - B : Set b +------------------------------------------------------------------------ +-- Definitions ------------------------------------------------------------------------- --- Definitions +-- When using well-founded recursion you can recurse arbitrarily, as +-- long as the arguments become smaller, and "smaller" is +-- well-founded. --- When using well-founded recursion you can recurse arbitrarily, as --- long as the arguments become smaller, and "smaller" is --- well-founded. +WfRec : Rel A r → ∀ {ℓ} → RecStruct A ℓ _ +WfRec _<_ P x = ∀ {y} → y < x → P y -WfRec : Rel A r → ∀ {ℓ} → RecStruct A ℓ _ -WfRec _<_ P x = ∀ y → y < x → P y +-- The accessibility predicate: x is accessible if everything which is +-- smaller than x is also accessible (inductively). --- The accessibility predicate: x is accessible if everything which is --- smaller than x is also accessible (inductively). +data Acc {A : Set a} (_<_ : Rel A ℓ) (x : A) : Set (a ⊔ ℓ) where + acc : (rs : WfRec _<_ (Acc _<_) x) → Acc _<_ x -data Acc {A : Set a} (_<_ : Rel A ℓ) (x : A) : Set (a ⊔ ℓ) where - acc : (rs : WfRec _<_ (Acc _<_) x) → Acc _<_ x +-- The accessibility predicate encodes what it means to be +-- well-founded; if all elements are accessible, then _<_ is +-- well-founded. --- The accessibility predicate encodes what it means to be --- well-founded; if all elements are accessible, then _<_ is --- well-founded. +WellFounded : Rel A ℓ → Set _ +WellFounded _<_ = ∀ x → Acc _<_ x -WellFounded : Rel A ℓ → Set _ -WellFounded _<_ = ∀ x → Acc _<_ x +------------------------------------------------------------------------ +-- Basic properties ------------------------------------------------------------------------- --- Basic properties +acc-inverse : ∀ {_<_ : Rel A ℓ} {x : A} (q : Acc _<_ x) → + WfRec _<_ (Acc _<_) x +acc-inverse (acc rs) y<x = rs y<x -acc-inverse : ∀ {_<_ : Rel A ℓ} {x : A} (q : Acc _<_ x) → - (y : A) → y < x → Acc _<_ y -acc-inverse (acc rs) y y<x = rs y y<x +module _ {_≈_ : Rel A ℓ₁} {_<_ : Rel A ℓ₂} where -Acc-resp-≈ : {_≈_ : Rel A ℓ₁} {_<_ : Rel A ℓ₂} → Symmetric _≈_ → - _<_ Respectsʳ _≈_ → (Acc _<_) Respects _≈_ -Acc-resp-≈ sym respʳ x≈y (acc rec) = - acc (λ z z<y → rec z (respʳ (sym x≈y) z<y)) + Acc-resp-flip-≈ : _<_ Respectsʳ (flip _≈_) → (Acc _<_) Respects _≈_ + Acc-resp-flip-≈ respʳ x≈y (acc rec) = acc λ z<y → rec (respʳ x≈y z<y) ------------------------------------------------------------------------- --- Well-founded induction for the subset of accessible elements: + Acc-resp-≈ : Symmetric _≈_ → _<_ Respectsʳ _≈_ → (Acc _<_) Respects _≈_ + Acc-resp-≈ sym respʳ x≈y wf = Acc-resp-flip-≈ (respʳ ∘ sym) x≈y wf -module Some {_<_ : Rel A r} {ℓ} where +------------------------------------------------------------------------ +-- Well-founded induction for the subset of accessible elements: - wfRecBuilder : SubsetRecursorBuilder (Acc _<_) (WfRec _<_ {ℓ = ℓ}) - wfRecBuilder P f x (acc rs) = λ y y<x → - f y (wfRecBuilder P f y (rs y y<x)) +module Some {_<_ : Rel A r} {ℓ} where - wfRec : SubsetRecursor (Acc _<_) (WfRec _<_) - wfRec = subsetBuild wfRecBuilder + wfRecBuilder : SubsetRecursorBuilder (Acc _<_) (WfRec _<_ {ℓ = ℓ}) + wfRecBuilder P f x (acc rs) = λ y<x → f _ (wfRecBuilder P f _ (rs y<x)) - unfold-wfRec : (P : Pred A ℓ) (f : WfRec _<_ P ⊆′ P) {x : A} (q : Acc _<_ x) → - wfRec P f x q ≡ f x (λ y y<x → wfRec P f y (acc-inverse q y y<x)) - unfold-wfRec P f (acc rs) = refl + wfRec : SubsetRecursor (Acc _<_) (WfRec _<_) + wfRec = subsetBuild wfRecBuilder + unfold-wfRec : (P : Pred A ℓ) (f : WfRec _<_ P ⊆′ P) {x : A} (q : Acc _<_ x) → + wfRec P f x q ≡ f x λ y<x → wfRec P f _ (acc-inverse q y<x) + unfold-wfRec P f (acc rs) = refl ------------------------------------------------------------------------- --- Well-founded induction for all elements, assuming they are all --- accessible: -module All {_<_ : Rel A r} (wf : WellFounded _<_) ℓ where +------------------------------------------------------------------------ +-- Well-founded induction for all elements, assuming they are all +-- accessible: - wfRecBuilder : RecursorBuilder (WfRec _<_ {ℓ = ℓ}) - wfRecBuilder P f x = Some.wfRecBuilder P f x (wf x) +module All {_<_ : Rel A r} (wf : WellFounded _<_) ℓ where - wfRec : Recursor (WfRec _<_) - wfRec = build wfRecBuilder + wfRecBuilder : RecursorBuilder (WfRec _<_ {ℓ = ℓ}) + wfRecBuilder P f x = Some.wfRecBuilder P f x (wf x) - wfRec-builder = wfRecBuilder + wfRec : Recursor (WfRec _<_) + wfRec = build wfRecBuilder -module FixPoint - {_<_ : Rel A r} (wf : WellFounded _<_) - (P : Pred A ℓ) (f : WfRec _<_ P ⊆′ P) - (f-ext : (x : A) {IH IH′ : WfRec _<_ P x} → (∀ {y} y<x → IH y y<x ≡ IH′ y y<x) → f x IH ≡ f x IH′) - where + wfRec-builder = wfRecBuilder - some-wfRec-irrelevant : ∀ x → (q q′ : Acc _<_ x) → Some.wfRec P f x q ≡ Some.wfRec P f x q′ - some-wfRec-irrelevant = All.wfRec wf _ - (λ x → (q q′ : Acc _<_ x) → Some.wfRec P f x q ≡ Some.wfRec P f x q′) - (λ { x IH (acc rs) (acc rs′) → f-ext x (λ y<x → IH _ y<x (rs _ y<x) (rs′ _ y<x)) }) +module FixPoint + {_<_ : Rel A r} (wf : WellFounded _<_) + (P : Pred A ℓ) (f : WfRec _<_ P ⊆′ P) + (f-ext : (x : A) {IH IH′ : WfRec _<_ P x} → + (∀ {y} y<x → IH {y} y<x ≡ IH′ y<x) → + f x IH ≡ f x IH′) + where - open All wf ℓ - wfRecBuilder-wfRec : ∀ {x y} y<x → wfRecBuilder P f x y y<x ≡ wfRec P f y - wfRecBuilder-wfRec {x} {y} y<x with wf x - ... | acc rs = some-wfRec-irrelevant y (rs y y<x) (wf y) + some-wfrec-Irrelevant : Pred A _ + some-wfrec-Irrelevant x = ∀ q q′ → Some.wfRec P f x q ≡ Some.wfRec P f x q′ - unfold-wfRec : ∀ {x} → wfRec P f x ≡ f x (λ y _ → wfRec P f y) - unfold-wfRec {x} = f-ext x wfRecBuilder-wfRec + some-wfRec-irrelevant : ∀ x → some-wfrec-Irrelevant x + some-wfRec-irrelevant = All.wfRec wf _ some-wfrec-Irrelevant + λ { x IH (acc rs) (acc rs′) → f-ext x λ y<x → IH y<x (rs y<x) (rs′ y<x) } + open All wf ℓ ------------------------------------------------------------------------- --- It might be useful to establish proofs of Acc or Well-founded using --- combinators such as the ones below (see, for instance, --- "Constructing Recursion Operators in Intuitionistic Type Theory" by --- Lawrence C Paulson). + wfRecBuilder-wfRec : ∀ {x y} y<x → wfRecBuilder P f x y<x ≡ wfRec P f y + wfRecBuilder-wfRec {x} {y} y<x with acc rs ← wf x + = some-wfRec-irrelevant y (rs y<x) (wf y) -module Subrelation {_<₁_ : Rel A ℓ₁} {_<₂_ : Rel A ℓ₂} - (<₁⇒<₂ : ∀ {x y} → x <₁ y → x <₂ y) where + unfold-wfRec : ∀ {x} → wfRec P f x ≡ f x λ _ → wfRec P f _ + unfold-wfRec {x} = f-ext x wfRecBuilder-wfRec - accessible : Acc _<₂_ ⊆ Acc _<₁_ - accessible (acc rs) = acc (λ y y<x → accessible (rs y (<₁⇒<₂ y<x))) +------------------------------------------------------------------------ +-- Well-founded relations are asymmetric and irreflexive. - wellFounded : WellFounded _<₂_ → WellFounded _<₁_ - wellFounded wf = λ x → accessible (wf x) +module _ {_<_ : Rel A r} where + acc⇒asym : ∀ {x y} → Acc _<_ x → x < y → ¬ (y < x) + acc⇒asym {x} hx = + Some.wfRec (λ x → ∀ {y} → x < y → ¬ (y < x)) (λ _ hx x<y y<x → hx y<x y<x x<y) _ hx + wf⇒asym : WellFounded _<_ → Asymmetric _<_ + wf⇒asym wf = acc⇒asym (wf _) --- DEPRECATED in v1.4. --- Please use proofs in `Relation.Binary.Construct.On` instead. -module InverseImage {_<_ : Rel B ℓ} (f : A → B) where + wf⇒irrefl : {_≈_ : Rel A ℓ} → _<_ Respects₂ _≈_ → + Symmetric _≈_ → WellFounded _<_ → Irreflexive _≈_ _<_ + wf⇒irrefl r s wf = asym⇒irr r s (wf⇒asym wf) - accessible : ∀ {x} → Acc _<_ (f x) → Acc (_<_ on f) x - accessible (acc rs) = acc (λ y fy<fx → accessible (rs (f y) fy<fx)) +------------------------------------------------------------------------ +-- It might be useful to establish proofs of Acc or Well-founded using +-- combinators such as the ones below (see, for instance, +-- "Constructing Recursion Operators in Intuitionistic Type Theory" by +-- Lawrence C Paulson). - wellFounded : WellFounded _<_ → WellFounded (_<_ on f) - wellFounded wf = λ x → accessible (wf (f x)) +module Subrelation {_<₁_ : Rel A ℓ₁} {_<₂_ : Rel A ℓ₂} + (<₁⇒<₂ : ∀ {x y} → x <₁ y → x <₂ y) where - well-founded = wellFounded - {-# WARNING_ON_USAGE accessible - "Warning: accessible was deprecated in v1.4. + accessible : Acc _<₂_ ⊆ Acc _<₁_ + accessible (acc rs) = acc λ y<x → accessible (rs (<₁⇒<₂ y<x)) + + wellFounded : WellFounded _<₂_ → WellFounded _<₁_ + wellFounded wf = λ x → accessible (wf x) + + +-- DEPRECATED in v1.4. +-- Please use proofs in `Relation.Binary.Construct.On` instead. +module InverseImage {_<_ : Rel B ℓ} (f : A → B) where + + accessible : ∀ {x} → Acc _<_ (f x) → Acc (_<_ on f) x + accessible (acc rs) = acc λ fy<fx → accessible (rs fy<fx) + + wellFounded : WellFounded _<_ → WellFounded (_<_ on f) + wellFounded wf = λ x → accessible (wf (f x)) + + well-founded = wellFounded + {-# WARNING_ON_USAGE accessible + "Warning: accessible was deprecated in v1.4. \ \Please use accessible from `Relation.Binary.Construct.On` instead." - #-} - {-# WARNING_ON_USAGE wellFounded - "Warning: wellFounded was deprecated in v1.4. + #-} + {-# WARNING_ON_USAGE wellFounded + "Warning: wellFounded was deprecated in v1.4. \ \Please use wellFounded from `Relation.Binary.Construct.On` instead." - #-} + #-} --- DEPRECATED in v1.5. --- Please use `TransClosure` from `Relation.Binary.Construct.Closure.Transitive` instead. -module TransitiveClosure {A : Set a} (_<_ : Rel A ℓ) where +-- DEPRECATED in v1.5. +-- Please use `TransClosure` from `Relation.Binary.Construct.Closure.Transitive` instead. +module TransitiveClosure {A : Set a} (_<_ : Rel A ℓ) where - infix 4 _<⁺_ + infix 4 _<⁺_ - data _<⁺_ : Rel A (a ⊔ ℓ) where - [_] : ∀ {x y} (x<y : x < y) → x <⁺ y - trans : ∀ {x y z} (x<y : x <⁺ y) (y<z : y <⁺ z) → x <⁺ z + data _<⁺_ : Rel A (a ⊔ ℓ) where + [_] : ∀ {x y} (x<y : x < y) → x <⁺ y + trans : ∀ {x y z} (x<y : x <⁺ y) (y<z : y <⁺ z) → x <⁺ z - downwardsClosed : ∀ {x y} → Acc _<⁺_ y → x <⁺ y → Acc _<⁺_ x - downwardsClosed (acc rs) x<y = acc (λ z z<x → rs z (trans z<x x<y)) + downwardsClosed : ∀ {x y} → Acc _<⁺_ y → x <⁺ y → Acc _<⁺_ x + downwardsClosed (acc rs) x<y = acc λ z<x → rs (trans z<x x<y) - mutual + mutual - accessible : ∀ {x} → Acc _<_ x → Acc _<⁺_ x - accessible acc-x = acc (accessible′ acc-x) + accessible : ∀ {x} → Acc _<_ x → Acc _<⁺_ x + accessible acc-x = acc (accessible′ acc-x) - accessible′ : ∀ {x} → Acc _<_ x → WfRec _<⁺_ (Acc _<⁺_) x - accessible′ (acc rs) y [ y<x ] = accessible (rs y y<x) - accessible′ acc-x y (trans y<z z<x) = - downwardsClosed (accessible′ acc-x _ z<x) y<z + accessible′ : ∀ {x} → Acc _<_ x → WfRec _<⁺_ (Acc _<⁺_) x + accessible′ (acc rs) [ y<x ] = accessible (rs y<x) + accessible′ acc-x (trans y<z z<x) = + downwardsClosed (accessible′ acc-x z<x) y<z - wellFounded : WellFounded _<_ → WellFounded _<⁺_ - wellFounded wf = λ x → accessible (wf x) + wellFounded : WellFounded _<_ → WellFounded _<⁺_ + wellFounded wf = λ x → accessible (wf x) - {-# WARNING_ON_USAGE _<⁺_ - "Warning: _<⁺_ was deprecated in v1.5. + {-# WARNING_ON_USAGE _<⁺_ + "Warning: _<⁺_ was deprecated in v1.5. \ \Please use TransClosure from Relation.Binary.Construct.Closure.Transitive instead." - #-} + #-} --- DEPRECATED in v1.3. --- Please use `×-Lex` from `Data.Product.Relation.Binary.Lex.Strict` instead. -module Lexicographic {A : Set a} {B : A → Set b} - (RelA : Rel A ℓ₁) - (RelB : ∀ x → Rel (B x) ℓ₂) where +-- DEPRECATED in v1.3. +-- Please use `×-Lex` from `Data.Product.Relation.Binary.Lex.Strict` instead. +module Lexicographic {A : Set a} {B : A → Set b} + (RelA : Rel A ℓ₁) + (RelB : ∀ x → Rel (B x) ℓ₂) where - data _<_ : Rel (Σ A B) (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - left : ∀ {x₁ y₁ x₂ y₂} (x₁<x₂ : RelA x₁ x₂) → (x₁ , y₁) < (x₂ , y₂) - right : ∀ {x y₁ y₂} (y₁<y₂ : RelB x y₁ y₂) → (x , y₁) < (x , y₂) + infix 4 _<_ + data _<_ : Rel (Σ A B) (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + left : ∀ {x₁ y₁ x₂ y₂} (x₁<x₂ : RelA x₁ x₂) → (x₁ , y₁) < (x₂ , y₂) + right : ∀ {x y₁ y₂} (y₁<y₂ : RelB x y₁ y₂) → (x , y₁) < (x , y₂) - mutual + mutual - accessible : ∀ {x y} → - Acc RelA x → (∀ {x} → WellFounded (RelB x)) → - Acc _<_ (x , y) - accessible accA wfB = acc (accessible′ accA (wfB _) wfB) + accessible : ∀ {x y} → + Acc RelA x → (∀ {x} → WellFounded (RelB x)) → + Acc _<_ (x , y) + accessible accA wfB = acc (accessible′ accA (wfB _) wfB) - accessible′ : - ∀ {x y} → - Acc RelA x → Acc (RelB x) y → (∀ {x} → WellFounded (RelB x)) → - WfRec _<_ (Acc _<_) (x , y) - accessible′ (acc rsA) _ wfB ._ (left x′<x) = accessible (rsA _ x′<x) wfB - accessible′ accA (acc rsB) wfB ._ (right y′<y) = - acc (accessible′ accA (rsB _ y′<y) wfB) + accessible′ : + ∀ {x y} → + Acc RelA x → Acc (RelB x) y → (∀ {x} → WellFounded (RelB x)) → + WfRec _<_ (Acc _<_) (x , y) + accessible′ (acc rsA) _ wfB (left x′<x) = accessible (rsA x′<x) wfB + accessible′ accA (acc rsB) wfB (right y′<y) = + acc (accessible′ accA (rsB y′<y) wfB) - wellFounded : WellFounded RelA → (∀ {x} → WellFounded (RelB x)) → - WellFounded _<_ - wellFounded wfA wfB p = accessible (wfA (proj₁ p)) wfB + wellFounded : WellFounded RelA → (∀ {x} → WellFounded (RelB x)) → + WellFounded _<_ + wellFounded wfA wfB p = accessible (wfA (proj₁ p)) wfB - well-founded = wellFounded + well-founded = wellFounded - {-# WARNING_ON_USAGE _<_ - "Warning: _<_ was deprecated in v1.3. + {-# WARNING_ON_USAGE _<_ + "Warning: _<_ was deprecated in v1.3. \ \Please use `×-Lex` from `Data.Product.Relation.Binary.Lex.Strict` instead." - #-} - {-# WARNING_ON_USAGE accessible - "Warning: accessible was deprecated in v1.3." - #-} - {-# WARNING_ON_USAGE accessible′ - "Warning: accessible′ was deprecated in v1.3." - #-} - {-# WARNING_ON_USAGE wellFounded - "Warning: wellFounded was deprecated in v1.3. + #-} + {-# WARNING_ON_USAGE accessible + "Warning: accessible was deprecated in v1.3." + #-} + {-# WARNING_ON_USAGE accessible′ + "Warning: accessible′ was deprecated in v1.3." + #-} + {-# WARNING_ON_USAGE wellFounded + "Warning: wellFounded was deprecated in v1.3. \ \Please use `×-wellFounded` from `Data.Product.Relation.Binary.Lex.Strict` instead." - #-} + #-} ------------------------------------------------------------------------- --- DEPRECATED NAMES ------------------------------------------------------------------------- --- Please use the new names as continuing support for the old names is --- not guaranteed. +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. --- Version 1.0 +-- Version 1.0 -module Inverse-image = InverseImage -module Transitive-closure = TransitiveClosure +module Inverse-image = InverseImage +module Transitive-closure = TransitiveClosure \ No newline at end of file diff --git a/Induction.html b/Induction.html index a7dca4fd..84af7e1a 100644 --- a/Induction.html +++ b/Induction.html @@ -24,18 +24,18 @@ -- about. RecStruct : ∀ {a} → Set a → (ℓ₁ ℓ₂ : Level) → Set _ -RecStruct A ℓ₁ ℓ₂ = Pred A ℓ₁ → Pred A ℓ₂ +RecStruct A ℓ₁ ℓ₂ = Pred A ℓ₁ → Pred A ℓ₂ -- A recursor builder constructs an instance of a recursion structure -- for a given input. RecursorBuilder : ∀ {a ℓ₁ ℓ₂} {A : Set a} → RecStruct A ℓ₁ ℓ₂ → Set _ -RecursorBuilder Rec = ∀ P → Rec P ⊆′ P → Universal (Rec P) +RecursorBuilder Rec = ∀ P → Rec P ⊆′ P → Universal (Rec P) -- A recursor can be used to actually compute/prove something useful. Recursor : ∀ {a ℓ₁ ℓ₂} {A : Set a} → RecStruct A ℓ₁ ℓ₂ → Set _ -Recursor Rec = ∀ P → Rec P ⊆′ P → Universal P +Recursor Rec = ∀ P → Rec P ⊆′ P → Universal P -- And recursors can be constructed from recursor builders. @@ -48,15 +48,15 @@ -- recursing over. SubsetRecursorBuilder : ∀ {a ℓ₁ ℓ₂ ℓ₃} {A : Set a} → - Pred A ℓ₁ → RecStruct A ℓ₂ ℓ₃ → Set _ -SubsetRecursorBuilder Q Rec = ∀ P → Rec P ⊆′ P → Q ⊆′ Rec P + Pred A ℓ₁ → RecStruct A ℓ₂ ℓ₃ → Set _ +SubsetRecursorBuilder Q Rec = ∀ P → Rec P ⊆′ P → Q ⊆′ Rec P SubsetRecursor : ∀ {a ℓ₁ ℓ₂ ℓ₃} {A : Set a} → - Pred A ℓ₁ → RecStruct A ℓ₂ ℓ₃ → Set _ -SubsetRecursor Q Rec = ∀ P → Rec P ⊆′ P → Q ⊆′ P + Pred A ℓ₁ → RecStruct A ℓ₂ ℓ₃ → Set _ +SubsetRecursor Q Rec = ∀ P → Rec P ⊆′ P → Q ⊆′ P subsetBuild : ∀ {a ℓ₁ ℓ₂ ℓ₃} - {A : Set a} {Q : Pred A ℓ₁} {Rec : RecStruct A ℓ₂ ℓ₃} → + {A : Set a} {Q : Pred A ℓ₁} {Rec : RecStruct A ℓ₂ ℓ₃} → SubsetRecursorBuilder Q Rec → SubsetRecursor Q Rec subsetBuild builder P f x q = f x (builder P f x q) diff --git a/Relation.Binary.Bundles.html b/Relation.Binary.Bundles.html index bda6009f..17674cb3 100644 --- a/Relation.Binary.Bundles.html +++ b/Relation.Binary.Bundles.html @@ -11,306 +11,385 @@ module Relation.Binary.Bundles where -open import Level -open import Relation.Nullary.Negation using (¬_) -open import Relation.Binary.Core -open import Relation.Binary.Definitions -open import Relation.Binary.Structures +open import Function.Base using (flip) +open import Level +open import Relation.Nullary.Negation using (¬_) +open import Relation.Binary.Core +open import Relation.Binary.Definitions +open import Relation.Binary.Structures + +------------------------------------------------------------------------ +-- Setoids +------------------------------------------------------------------------ + +record PartialSetoid a ℓ : Set (suc (a ⊔ ℓ)) where + infix 4 _≈_ + field + Carrier : Set a + _≈_ : Rel Carrier ℓ + isPartialEquivalence : IsPartialEquivalence _≈_ + + open IsPartialEquivalence isPartialEquivalence public + + infix 4 _≉_ + _≉_ : Rel Carrier _ + x ≉ y = ¬ (x ≈ y) + + +record Setoid c ℓ : Set (suc (c ⊔ ℓ)) where + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + isEquivalence : IsEquivalence _≈_ + + open IsEquivalence isEquivalence public + using (refl; reflexive; isPartialEquivalence) + + partialSetoid : PartialSetoid c ℓ + partialSetoid = record + { isPartialEquivalence = isPartialEquivalence + } + + open PartialSetoid partialSetoid public + hiding (Carrier; _≈_; isPartialEquivalence) + + +record DecSetoid c ℓ : Set (suc (c ⊔ ℓ)) where + infix 4 _≈_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ + isDecEquivalence : IsDecEquivalence _≈_ + + open IsDecEquivalence isDecEquivalence public + using (_≟_; isEquivalence) + + setoid : Setoid c ℓ + setoid = record + { isEquivalence = isEquivalence + } + + open Setoid setoid public + hiding (Carrier; _≈_; isEquivalence) + +------------------------------------------------------------------------ +-- Preorders +------------------------------------------------------------------------ + +record Preorder c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _≲_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ₁ -- The underlying equality. + _≲_ : Rel Carrier ℓ₂ -- The relation. + isPreorder : IsPreorder _≈_ _≲_ + + open IsPreorder isPreorder public + hiding (module Eq) + + module Eq where + setoid : Setoid c ℓ₁ + setoid = record + { isEquivalence = isEquivalence + } + + open Setoid setoid public + + infix 4 _⋦_ + _⋦_ : Rel Carrier _ + x ⋦ y = ¬ (x ≲ y) + + infix 4 _≳_ + _≳_ = flip _≲_ + + infix 4 _⋧_ + _⋧_ = flip _⋦_ + + -- Deprecated. + infix 4 _∼_ + _∼_ = _≲_ + {-# WARNING_ON_USAGE _∼_ + "Warning: _∼_ was deprecated in v2.0. + Please use _≲_ instead. " + #-} + + +record TotalPreorder c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _≲_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ₁ -- The underlying equality. + _≲_ : Rel Carrier ℓ₂ -- The relation. + isTotalPreorder : IsTotalPreorder _≈_ _≲_ + + open IsTotalPreorder isTotalPreorder public + using (total; isPreorder) + + preorder : Preorder c ℓ₁ ℓ₂ + preorder = record + { isPreorder = isPreorder + } + + open Preorder preorder public + hiding (Carrier; _≈_; _≲_; isPreorder) + +------------------------------------------------------------------------ +-- Partial orders +------------------------------------------------------------------------ + +record Poset c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _≤_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ₁ + _≤_ : Rel Carrier ℓ₂ + isPartialOrder : IsPartialOrder _≈_ _≤_ + + open IsPartialOrder isPartialOrder public + using (antisym; isPreorder) + + preorder : Preorder c ℓ₁ ℓ₂ + preorder = record + { isPreorder = isPreorder + } ------------------------------------------------------------------------- --- Setoids ------------------------------------------------------------------------- + open Preorder preorder public + hiding (Carrier; _≈_; _≲_; isPreorder) + renaming + ( _⋦_ to _≰_; _≳_ to _≥_; _⋧_ to _≱_ + ; ≲-respˡ-≈ to ≤-respˡ-≈ + ; ≲-respʳ-≈ to ≤-respʳ-≈ + ; ≲-resp-≈ to ≤-resp-≈ + ) + + +record DecPoset c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _≤_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ₁ + _≤_ : Rel Carrier ℓ₂ + isDecPartialOrder : IsDecPartialOrder _≈_ _≤_ + + private module DPO = IsDecPartialOrder isDecPartialOrder + + open DPO public + using (_≟_; _≤?_; isPartialOrder) + + poset : Poset c ℓ₁ ℓ₂ + poset = record + { isPartialOrder = isPartialOrder + } + + open Poset poset public + hiding (Carrier; _≈_; _≤_; isPartialOrder; module Eq) -record PartialSetoid a ℓ : Set (suc (a ⊔ ℓ)) where - field - Carrier : Set a - _≈_ : Rel Carrier ℓ - isPartialEquivalence : IsPartialEquivalence _≈_ + module Eq where + decSetoid : DecSetoid c ℓ₁ + decSetoid = record + { isDecEquivalence = DPO.Eq.isDecEquivalence + } + + open DecSetoid decSetoid public - open IsPartialEquivalence isPartialEquivalence public - infix 4 _≉_ - _≉_ : Rel Carrier _ - x ≉ y = ¬ (x ≈ y) +record StrictPartialOrder c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _<_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ₁ + _<_ : Rel Carrier ℓ₂ + isStrictPartialOrder : IsStrictPartialOrder _≈_ _<_ + open IsStrictPartialOrder isStrictPartialOrder public + hiding (module Eq) -record Setoid c ℓ : Set (suc (c ⊔ ℓ)) where - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - isEquivalence : IsEquivalence _≈_ + module Eq where + setoid : Setoid c ℓ₁ + setoid = record + { isEquivalence = isEquivalence + } - open IsEquivalence isEquivalence public + open Setoid setoid public - partialSetoid : PartialSetoid c ℓ - partialSetoid = record - { isPartialEquivalence = isPartialEquivalence - } + infix 4 _≮_ + _≮_ : Rel Carrier _ + x ≮ y = ¬ (x < y) - open PartialSetoid partialSetoid public using (_≉_) + infix 4 _>_ + _>_ = flip _<_ + infix 4 _≯_ + _≯_ = flip _≮_ -record DecSetoid c ℓ : Set (suc (c ⊔ ℓ)) where - infix 4 _≈_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ - isDecEquivalence : IsDecEquivalence _≈_ - open IsDecEquivalence isDecEquivalence public +record DecStrictPartialOrder c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _<_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ₁ + _<_ : Rel Carrier ℓ₂ + isDecStrictPartialOrder : IsDecStrictPartialOrder _≈_ _<_ + + private module DSPO = IsDecStrictPartialOrder isDecStrictPartialOrder - setoid : Setoid c ℓ - setoid = record - { isEquivalence = isEquivalence - } + open DSPO public + using (_<?_; _≟_; isStrictPartialOrder) + + strictPartialOrder : StrictPartialOrder c ℓ₁ ℓ₂ + strictPartialOrder = record + { isStrictPartialOrder = isStrictPartialOrder + } - open Setoid setoid public using (partialSetoid; _≉_) + open StrictPartialOrder strictPartialOrder public + hiding (Carrier; _≈_; _<_; isStrictPartialOrder; module Eq) + module Eq where ------------------------------------------------------------------------- --- Preorders ------------------------------------------------------------------------- + decSetoid : DecSetoid c ℓ₁ + decSetoid = record + { isDecEquivalence = DSPO.Eq.isDecEquivalence + } -record Preorder c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where - infix 4 _≈_ _∼_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ₁ -- The underlying equality. - _∼_ : Rel Carrier ℓ₂ -- The relation. - isPreorder : IsPreorder _≈_ _∼_ + open DecSetoid decSetoid public - open IsPreorder isPreorder public - hiding (module Eq) - module Eq where - setoid : Setoid c ℓ₁ - setoid = record - { isEquivalence = isEquivalence - } +------------------------------------------------------------------------ +-- Total orders +------------------------------------------------------------------------ + +record TotalOrder c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _≤_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ₁ + _≤_ : Rel Carrier ℓ₂ + isTotalOrder : IsTotalOrder _≈_ _≤_ - open Setoid setoid public + open IsTotalOrder isTotalOrder public + using (total; isPartialOrder; isTotalPreorder) + poset : Poset c ℓ₁ ℓ₂ + poset = record + { isPartialOrder = isPartialOrder + } -record TotalPreorder c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where - infix 4 _≈_ _≲_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ₁ -- The underlying equality. - _≲_ : Rel Carrier ℓ₂ -- The relation. - isTotalPreorder : IsTotalPreorder _≈_ _≲_ + open Poset poset public + hiding (Carrier; _≈_; _≤_; isPartialOrder) - open IsTotalPreorder isTotalPreorder public - hiding (module Eq) + totalPreorder : TotalPreorder c ℓ₁ ℓ₂ + totalPreorder = record + { isTotalPreorder = isTotalPreorder + } - preorder : Preorder c ℓ₁ ℓ₂ - preorder = record { isPreorder = isPreorder } - open Preorder preorder public - using (module Eq) +record DecTotalOrder c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _≤_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ₁ + _≤_ : Rel Carrier ℓ₂ + isDecTotalOrder : IsDecTotalOrder _≈_ _≤_ + private module DTO = IsDecTotalOrder isDecTotalOrder ------------------------------------------------------------------------- --- Partial orders ------------------------------------------------------------------------- + open DTO public + using (_≟_; _≤?_; isTotalOrder; isDecPartialOrder) -record Poset c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where - infix 4 _≈_ _≤_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ₁ - _≤_ : Rel Carrier ℓ₂ - isPartialOrder : IsPartialOrder _≈_ _≤_ + totalOrder : TotalOrder c ℓ₁ ℓ₂ + totalOrder = record + { isTotalOrder = isTotalOrder + } - open IsPartialOrder isPartialOrder public - hiding (module Eq) + open TotalOrder totalOrder public + hiding (Carrier; _≈_; _≤_; isTotalOrder; module Eq) - preorder : Preorder c ℓ₁ ℓ₂ - preorder = record - { isPreorder = isPreorder - } + decPoset : DecPoset c ℓ₁ ℓ₂ + decPoset = record + { isDecPartialOrder = isDecPartialOrder + } - open Preorder preorder public - using (module Eq) + open DecPoset decPoset public + using (module Eq) -record DecPoset c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where - infix 4 _≈_ _≤_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ₁ - _≤_ : Rel Carrier ℓ₂ - isDecPartialOrder : IsDecPartialOrder _≈_ _≤_ +-- 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. - private - module DPO = IsDecPartialOrder isDecPartialOrder - open DPO public hiding (module Eq) +record StrictTotalOrder c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _<_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ₁ + _<_ : Rel Carrier ℓ₂ + isStrictTotalOrder : IsStrictTotalOrder _≈_ _<_ + + open IsStrictTotalOrder isStrictTotalOrder public + using + ( _≟_; _<?_; compare; isStrictPartialOrder + ; isDecStrictPartialOrder; isDecEquivalence + ) - poset : Poset c ℓ₁ ℓ₂ - poset = record - { isPartialOrder = isPartialOrder - } + strictPartialOrder : StrictPartialOrder c ℓ₁ ℓ₂ + strictPartialOrder = record + { isStrictPartialOrder = isStrictPartialOrder + } + + open StrictPartialOrder strictPartialOrder public + hiding (Carrier; _≈_; _<_; isStrictPartialOrder; module Eq) - open Poset poset public - using (preorder) - - module Eq where - decSetoid : DecSetoid c ℓ₁ - decSetoid = record - { isDecEquivalence = DPO.Eq.isDecEquivalence - } - - open DecSetoid decSetoid public - - -record StrictPartialOrder c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where - infix 4 _≈_ _<_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ₁ - _<_ : Rel Carrier ℓ₂ - isStrictPartialOrder : IsStrictPartialOrder _≈_ _<_ - - open IsStrictPartialOrder isStrictPartialOrder public - hiding (module Eq) - - module Eq where - setoid : Setoid c ℓ₁ - setoid = record - { isEquivalence = isEquivalence - } - - open Setoid setoid public - - -record DecStrictPartialOrder c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where - infix 4 _≈_ _<_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ₁ - _<_ : Rel Carrier ℓ₂ - isDecStrictPartialOrder : IsDecStrictPartialOrder _≈_ _<_ - - private - module DSPO = IsDecStrictPartialOrder isDecStrictPartialOrder - open DSPO public hiding (module Eq) - - strictPartialOrder : StrictPartialOrder c ℓ₁ ℓ₂ - strictPartialOrder = record - { isStrictPartialOrder = isStrictPartialOrder - } - - module Eq where - - decSetoid : DecSetoid c ℓ₁ - decSetoid = record - { isDecEquivalence = DSPO.Eq.isDecEquivalence - } - - open DecSetoid decSetoid public - - ------------------------------------------------------------------------- --- Total orders ------------------------------------------------------------------------- - -record TotalOrder c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where - infix 4 _≈_ _≤_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ₁ - _≤_ : Rel Carrier ℓ₂ - isTotalOrder : IsTotalOrder _≈_ _≤_ - - open IsTotalOrder isTotalOrder public - hiding (module Eq) - - poset : Poset c ℓ₁ ℓ₂ - poset = record - { isPartialOrder = isPartialOrder - } - - open Poset poset public - using (module Eq; preorder) - - totalPreorder : TotalPreorder c ℓ₁ ℓ₂ - totalPreorder = record - { isTotalPreorder = isTotalPreorder - } - - -record DecTotalOrder c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where - infix 4 _≈_ _≤_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ₁ - _≤_ : Rel Carrier ℓ₂ - isDecTotalOrder : IsDecTotalOrder _≈_ _≤_ - - private - module DTO = IsDecTotalOrder isDecTotalOrder - open DTO public hiding (module Eq) - - totalOrder : TotalOrder c ℓ₁ ℓ₂ - totalOrder = record - { isTotalOrder = isTotalOrder - } - - open TotalOrder totalOrder public using (poset; preorder) + decStrictPartialOrder : DecStrictPartialOrder c ℓ₁ ℓ₂ + decStrictPartialOrder = record + { isDecStrictPartialOrder = isDecStrictPartialOrder + } + + open DecStrictPartialOrder decStrictPartialOrder public + using (module Eq) + + decSetoid : DecSetoid c ℓ₁ + decSetoid = record + { isDecEquivalence = Eq.isDecEquivalence + } + {-# WARNING_ON_USAGE decSetoid + "Warning: decSetoid was deprecated in v1.3. + Please use Eq.decSetoid instead." + #-} - decPoset : DecPoset c ℓ₁ ℓ₂ - decPoset = record - { isDecPartialOrder = isDecPartialOrder - } - - open DecPoset decPoset public using (module Eq) - - --- 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 StrictTotalOrder c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where - infix 4 _≈_ _<_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ₁ - _<_ : Rel Carrier ℓ₂ - isStrictTotalOrder : IsStrictTotalOrder _≈_ _<_ +record DenseLinearOrder c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _<_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ₁ + _<_ : Rel Carrier ℓ₂ + isDenseLinearOrder : IsDenseLinearOrder _≈_ _<_ - open IsStrictTotalOrder isStrictTotalOrder public - hiding (module Eq) + open IsDenseLinearOrder isDenseLinearOrder public + using (isStrictTotalOrder; dense) - strictPartialOrder : StrictPartialOrder c ℓ₁ ℓ₂ - strictPartialOrder = record - { isStrictPartialOrder = isStrictPartialOrder - } - - open StrictPartialOrder strictPartialOrder public - using (module Eq) + strictTotalOrder : StrictTotalOrder c ℓ₁ ℓ₂ + strictTotalOrder = record + { isStrictTotalOrder = isStrictTotalOrder + } - decSetoid : DecSetoid c ℓ₁ - decSetoid = record - { isDecEquivalence = isDecEquivalence - } - {-# WARNING_ON_USAGE decSetoid - "Warning: decSetoid was deprecated in v1.3. - Please use Eq.decSetoid instead." - #-} + open StrictTotalOrder strictTotalOrder public + hiding (Carrier; _≈_; _<_; isStrictTotalOrder) ------------------------------------------------------------------------- --- Apartness relations ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Apartness relations +------------------------------------------------------------------------ -record ApartnessRelation c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where - infix 4 _≈_ _#_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ₁ - _#_ : Rel Carrier ℓ₂ - isApartnessRelation : IsApartnessRelation _≈_ _#_ +record ApartnessRelation c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _#_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ₁ + _#_ : Rel Carrier ℓ₂ + isApartnessRelation : IsApartnessRelation _≈_ _#_ - open IsApartnessRelation isApartnessRelation public + open IsApartnessRelation isApartnessRelation public \ No newline at end of file diff --git a/Relation.Binary.Consequences.html b/Relation.Binary.Consequences.html index 56b0ba1b..ca9c978a 100644 --- a/Relation.Binary.Consequences.html +++ b/Relation.Binary.Consequences.html @@ -9,309 +9,309 @@ module Relation.Binary.Consequences where -open import Data.Maybe.Base using (just; nothing; decToMaybe) +open import Data.Maybe.Base using (just; nothing; decToMaybe) open import Data.Sum.Base as Sum using (inj₁; inj₂; [_,_]′) -open import Data.Product using (_,_) -open import Data.Empty.Irrelevant using (⊥-elim) -open import Function.Base using (_∘_; _∘₂_; _$_; flip) -open import Level using (Level) -open import Relation.Binary.Core -open import Relation.Binary.Definitions -open import Relation.Nullary using (yes; no; recompute; ¬_) -open import Relation.Nullary.Decidable.Core using (map′) -open import Relation.Unary using (∁; Pred) +open import Data.Product.Base using (_,_) +open import Data.Empty.Irrelevant using (⊥-elim) +open import Function.Base using (_∘_; _∘₂_; _$_; flip) +open import Level using (Level) +open import Relation.Binary.Core +open import Relation.Binary.Definitions +open import Relation.Nullary using (yes; no; recompute; ¬_) +open import Relation.Nullary.Decidable.Core using (map′) +open import Relation.Unary using (∁; Pred) -private - variable - a ℓ ℓ₁ ℓ₂ ℓ₃ ℓ₄ p : Level - A B : Set a +private + variable + a ℓ ℓ₁ ℓ₂ ℓ₃ ℓ₄ p : Level + A B : Set a ------------------------------------------------------------------------- --- Substitutive properties +------------------------------------------------------------------------ +-- Substitutive properties -module _ {_∼_ : Rel A ℓ} (R : Rel A p) where +module _ {_∼_ : Rel A ℓ} (R : Rel A p) where - subst⇒respˡ : Substitutive _∼_ p → R Respectsˡ _∼_ - subst⇒respˡ subst {y} x′∼x Px′y = subst (flip R y) x′∼x Px′y + subst⇒respˡ : Substitutive _∼_ p → R Respectsˡ _∼_ + subst⇒respˡ subst {y} x′∼x Px′y = subst (flip R y) x′∼x Px′y - subst⇒respʳ : Substitutive _∼_ p → R Respectsʳ _∼_ - subst⇒respʳ subst {x} y′∼y Pxy′ = subst (R x) y′∼y Pxy′ + subst⇒respʳ : Substitutive _∼_ p → R Respectsʳ _∼_ + subst⇒respʳ subst {x} y′∼y Pxy′ = subst (R x) y′∼y Pxy′ - subst⇒resp₂ : Substitutive _∼_ p → R Respects₂ _∼_ - subst⇒resp₂ subst = subst⇒respʳ subst , subst⇒respˡ subst - -module _ {_∼_ : Rel A ℓ} {P : Pred A p} where + subst⇒resp₂ : Substitutive _∼_ p → R Respects₂ _∼_ + subst⇒resp₂ subst = subst⇒respʳ subst , subst⇒respˡ subst + +module _ {_∼_ : Rel A ℓ} {P : Pred A p} where - resp⇒¬-resp : Symmetric _∼_ → P Respects _∼_ → (∁ P) Respects _∼_ - resp⇒¬-resp sym resp x∼y ¬Px Py = ¬Px (resp (sym x∼y) Py) - ------------------------------------------------------------------------- --- Proofs for negation - -module _ {_∼_ : Rel A ℓ} where - - sym⇒¬-sym : Symmetric _∼_ → Symmetric (¬_ ∘₂ _∼_) - sym⇒¬-sym sym≁ x≁y y∼x = x≁y (sym≁ y∼x) - - -- N.B. the implicit arguments to Cotransitive are permuted w.r.t. - -- those of Transitive - cotrans⇒¬-trans : Cotransitive _∼_ → Transitive (¬_ ∘₂ _∼_) - cotrans⇒¬-trans cotrans {j = z} x≁z z≁y x∼y = - [ x≁z , z≁y ]′ (cotrans x∼y z) - ------------------------------------------------------------------------- --- Proofs for Irreflexive relations - -module _ {_≈_ : Rel A ℓ₁} {_∼_ : Rel A ℓ₂} where - - irrefl⇒¬-refl : Reflexive _≈_ → Irreflexive _≈_ _∼_ → - Reflexive (¬_ ∘₂ _∼_) - irrefl⇒¬-refl re irr = irr re - ------------------------------------------------------------------------- --- Proofs for non-strict orders - -module _ {_≈_ : Rel A ℓ₁} {_≤_ : Rel A ℓ₂} where - - total⇒refl : _≤_ Respects₂ _≈_ → Symmetric _≈_ → - Total _≤_ → _≈_ ⇒ _≤_ - total⇒refl (respʳ , respˡ) sym total {x} {y} x≈y with total x y - ... | inj₁ x∼y = x∼y - ... | inj₂ y∼x = respʳ x≈y (respˡ (sym x≈y) y∼x) - - total∧dec⇒dec : _≈_ ⇒ _≤_ → Antisymmetric _≈_ _≤_ → - Total _≤_ → Decidable _≈_ → Decidable _≤_ - total∧dec⇒dec refl antisym total _≟_ x y with total x y - ... | inj₁ x≤y = yes x≤y - ... | inj₂ y≤x = map′ refl (flip antisym y≤x) (x ≟ y) - -module _ (≈₁ : Rel A ℓ₁) (≈₂ : Rel B ℓ₂) {≤₁ : Rel A ℓ₃} {≤₂ : Rel B ℓ₄} where - - mono⇒cong : Symmetric ≈₁ → ≈₁ ⇒ ≤₁ → Antisymmetric ≈₂ ≤₂ → - ∀ {f} → f Preserves ≤₁ ⟶ ≤₂ → f Preserves ≈₁ ⟶ ≈₂ - mono⇒cong sym reflexive antisym mono x≈y = antisym - (mono (reflexive x≈y)) - (mono (reflexive (sym x≈y))) - - antimono⇒cong : Symmetric ≈₁ → ≈₁ ⇒ ≤₁ → Antisymmetric ≈₂ ≤₂ → - ∀ {f} → f Preserves ≤₁ ⟶ (flip ≤₂) → f Preserves ≈₁ ⟶ ≈₂ - antimono⇒cong sym reflexive antisym antimono p≈q = antisym - (antimono (reflexive (sym p≈q))) - (antimono (reflexive p≈q)) - - mono₂⇒cong₂ : Symmetric ≈₁ → ≈₁ ⇒ ≤₁ → Antisymmetric ≈₂ ≤₂ → ∀ {f} → - f Preserves₂ ≤₁ ⟶ ≤₁ ⟶ ≤₂ → - f Preserves₂ ≈₁ ⟶ ≈₁ ⟶ ≈₂ - mono₂⇒cong₂ sym reflexive antisym mono x≈y u≈v = antisym - (mono (reflexive x≈y) (reflexive u≈v)) - (mono (reflexive (sym x≈y)) (reflexive (sym u≈v))) - ------------------------------------------------------------------------- --- Proofs for strict orders - -module _ {_≈_ : Rel A ℓ₁} {_<_ : Rel A ℓ₂} where + resp⇒¬-resp : Symmetric _∼_ → P Respects _∼_ → (∁ P) Respects _∼_ + resp⇒¬-resp sym resp x∼y ¬Px Py = ¬Px (resp (sym x∼y) Py) + +------------------------------------------------------------------------ +-- Proofs for negation + +module _ {_∼_ : Rel A ℓ} where + + sym⇒¬-sym : Symmetric _∼_ → Symmetric (¬_ ∘₂ _∼_) + sym⇒¬-sym sym≁ x≁y y∼x = x≁y (sym≁ y∼x) + + -- N.B. the implicit arguments to Cotransitive are permuted w.r.t. + -- those of Transitive + cotrans⇒¬-trans : Cotransitive _∼_ → Transitive (¬_ ∘₂ _∼_) + cotrans⇒¬-trans cotrans {j = z} x≁z z≁y x∼y = + [ x≁z , z≁y ]′ (cotrans x∼y z) + +------------------------------------------------------------------------ +-- Proofs for Irreflexive relations + +module _ {_≈_ : Rel A ℓ₁} {_∼_ : Rel A ℓ₂} where + + irrefl⇒¬-refl : Reflexive _≈_ → Irreflexive _≈_ _∼_ → + Reflexive (¬_ ∘₂ _∼_) + irrefl⇒¬-refl re irr = irr re + +------------------------------------------------------------------------ +-- Proofs for non-strict orders + +module _ {_≈_ : Rel A ℓ₁} {_≤_ : Rel A ℓ₂} where + + total⇒refl : _≤_ Respects₂ _≈_ → Symmetric _≈_ → + Total _≤_ → _≈_ ⇒ _≤_ + total⇒refl (respʳ , respˡ) sym total {x} {y} x≈y with total x y + ... | inj₁ x∼y = x∼y + ... | inj₂ y∼x = respʳ x≈y (respˡ (sym x≈y) y∼x) + + total∧dec⇒dec : _≈_ ⇒ _≤_ → Antisymmetric _≈_ _≤_ → + Total _≤_ → Decidable _≈_ → Decidable _≤_ + total∧dec⇒dec refl antisym total _≟_ x y with total x y + ... | inj₁ x≤y = yes x≤y + ... | inj₂ y≤x = map′ refl (flip antisym y≤x) (x ≟ y) + +module _ (≈₁ : Rel A ℓ₁) (≈₂ : Rel B ℓ₂) {≤₁ : Rel A ℓ₃} {≤₂ : Rel B ℓ₄} where + + mono⇒cong : Symmetric ≈₁ → ≈₁ ⇒ ≤₁ → Antisymmetric ≈₂ ≤₂ → + ∀ {f} → f Preserves ≤₁ ⟶ ≤₂ → f Preserves ≈₁ ⟶ ≈₂ + mono⇒cong sym reflexive antisym mono x≈y = antisym + (mono (reflexive x≈y)) + (mono (reflexive (sym x≈y))) + + antimono⇒cong : Symmetric ≈₁ → ≈₁ ⇒ ≤₁ → Antisymmetric ≈₂ ≤₂ → + ∀ {f} → f Preserves ≤₁ ⟶ (flip ≤₂) → f Preserves ≈₁ ⟶ ≈₂ + antimono⇒cong sym reflexive antisym antimono p≈q = antisym + (antimono (reflexive (sym p≈q))) + (antimono (reflexive p≈q)) + + mono₂⇒cong₂ : Symmetric ≈₁ → ≈₁ ⇒ ≤₁ → Antisymmetric ≈₂ ≤₂ → ∀ {f} → + f Preserves₂ ≤₁ ⟶ ≤₁ ⟶ ≤₂ → + f Preserves₂ ≈₁ ⟶ ≈₁ ⟶ ≈₂ + mono₂⇒cong₂ sym reflexive antisym mono x≈y u≈v = antisym + (mono (reflexive x≈y) (reflexive u≈v)) + (mono (reflexive (sym x≈y)) (reflexive (sym u≈v))) + +------------------------------------------------------------------------ +-- Proofs for strict orders + +module _ {_≈_ : Rel A ℓ₁} {_<_ : Rel A ℓ₂} where - trans∧irr⇒asym : Reflexive _≈_ → Transitive _<_ → - Irreflexive _≈_ _<_ → Asymmetric _<_ - trans∧irr⇒asym refl trans irrefl x<y y<x = - irrefl refl (trans x<y y<x) + trans∧irr⇒asym : Reflexive _≈_ → Transitive _<_ → + Irreflexive _≈_ _<_ → Asymmetric _<_ + trans∧irr⇒asym refl trans irrefl x<y y<x = + irrefl refl (trans x<y y<x) - irr∧antisym⇒asym : Irreflexive _≈_ _<_ → Antisymmetric _≈_ _<_ → - Asymmetric _<_ - irr∧antisym⇒asym irrefl antisym x<y y<x = - irrefl (antisym x<y y<x) x<y + irr∧antisym⇒asym : Irreflexive _≈_ _<_ → Antisymmetric _≈_ _<_ → + Asymmetric _<_ + irr∧antisym⇒asym irrefl antisym x<y y<x = + irrefl (antisym x<y y<x) x<y - asym⇒antisym : Asymmetric _<_ → Antisymmetric _≈_ _<_ - asym⇒antisym asym x<y y<x = ⊥-elim (asym x<y y<x) + asym⇒antisym : Asymmetric _<_ → Antisymmetric _≈_ _<_ + asym⇒antisym asym x<y y<x = ⊥-elim (asym x<y y<x) - asym⇒irr : _<_ Respects₂ _≈_ → Symmetric _≈_ → - Asymmetric _<_ → Irreflexive _≈_ _<_ - asym⇒irr (respʳ , respˡ) sym asym {x} {y} x≈y x<y = - asym x<y (respʳ (sym x≈y) (respˡ x≈y x<y)) + asym⇒irr : _<_ Respects₂ _≈_ → Symmetric _≈_ → + Asymmetric _<_ → Irreflexive _≈_ _<_ + asym⇒irr (respʳ , respˡ) sym asym {x} {y} x≈y x<y = + asym x<y (respʳ (sym x≈y) (respˡ x≈y x<y)) - tri⇒asym : Trichotomous _≈_ _<_ → Asymmetric _<_ - tri⇒asym tri {x} {y} x<y x>y with tri x y - ... | tri< _ _ x≯y = x≯y x>y - ... | tri≈ _ _ x≯y = x≯y x>y - ... | tri> x≮y _ _ = x≮y x<y + tri⇒asym : Trichotomous _≈_ _<_ → Asymmetric _<_ + tri⇒asym tri {x} {y} x<y x>y with tri x y + ... | tri< _ _ x≯y = x≯y x>y + ... | tri≈ _ _ x≯y = x≯y x>y + ... | tri> x≮y _ _ = x≮y x<y - tri⇒irr : Trichotomous _≈_ _<_ → Irreflexive _≈_ _<_ - tri⇒irr compare {x} {y} x≈y x<y with compare x y - ... | tri< _ x≉y y≮x = x≉y x≈y - ... | tri> x≮y x≉y y<x = x≉y x≈y - ... | tri≈ x≮y _ y≮x = x≮y x<y + tri⇒irr : Trichotomous _≈_ _<_ → Irreflexive _≈_ _<_ + tri⇒irr compare {x} {y} x≈y x<y with compare x y + ... | tri< _ x≉y y≮x = x≉y x≈y + ... | tri> x≮y x≉y y<x = x≉y x≈y + ... | tri≈ x≮y _ y≮x = x≮y x<y - tri⇒dec≈ : Trichotomous _≈_ _<_ → Decidable _≈_ - tri⇒dec≈ compare x y with compare x y - ... | tri< _ x≉y _ = no x≉y - ... | tri≈ _ x≈y _ = yes x≈y - ... | tri> _ x≉y _ = no x≉y - - tri⇒dec< : Trichotomous _≈_ _<_ → Decidable _<_ - tri⇒dec< compare x y with compare x y - ... | tri< x<y _ _ = yes x<y - ... | tri≈ x≮y _ _ = no x≮y - ... | tri> x≮y _ _ = no x≮y - - trans∧tri⇒respʳ : Symmetric _≈_ → Transitive _≈_ → - Transitive _<_ → Trichotomous _≈_ _<_ → - _<_ Respectsʳ _≈_ - trans∧tri⇒respʳ sym ≈-tr <-tr tri {x} {y} {z} y≈z x<y with tri x z - ... | tri< x<z _ _ = x<z - ... | tri≈ _ x≈z _ = ⊥-elim (tri⇒irr tri (≈-tr x≈z (sym y≈z)) x<y) - ... | tri> _ _ z<x = ⊥-elim (tri⇒irr tri (sym y≈z) (<-tr z<x x<y)) - - trans∧tri⇒respˡ : Transitive _≈_ → - Transitive _<_ → Trichotomous _≈_ _<_ → - _<_ Respectsˡ _≈_ - trans∧tri⇒respˡ ≈-tr <-tr tri {z} {_} {y} x≈y x<z with tri y z - ... | tri< y<z _ _ = y<z - ... | tri≈ _ y≈z _ = ⊥-elim (tri⇒irr tri (≈-tr x≈y y≈z) x<z) - ... | tri> _ _ z<y = ⊥-elim (tri⇒irr tri x≈y (<-tr x<z z<y)) - - trans∧tri⇒resp : Symmetric _≈_ → Transitive _≈_ → - Transitive _<_ → Trichotomous _≈_ _<_ → - _<_ Respects₂ _≈_ - trans∧tri⇒resp sym ≈-tr <-tr tri = - trans∧tri⇒respʳ sym ≈-tr <-tr tri , - trans∧tri⇒respˡ ≈-tr <-tr tri - ------------------------------------------------------------------------- --- Without Loss of Generality - -module _ {_R_ : Rel A ℓ₁} {Q : Rel A ℓ₂} where - - wlog : Total _R_ → Symmetric Q → - (∀ a b → a R b → Q a b) → - ∀ a b → Q a b - wlog r-total q-sym prf a b with r-total a b - ... | inj₁ aRb = prf a b aRb - ... | inj₂ bRa = q-sym (prf b a bRa) - ------------------------------------------------------------------------- --- Other proofs - -module _ {R : REL A B p} where - - dec⇒weaklyDec : Decidable R → WeaklyDecidable R - dec⇒weaklyDec dec x y = decToMaybe (dec x y) - - dec⇒recomputable : Decidable R → Recomputable R - dec⇒recomputable dec {a} {b} = recompute $ dec a b - -module _ {R : REL A B ℓ₁} {S : REL A B ℓ₂} where - - map-NonEmpty : R ⇒ S → NonEmpty R → NonEmpty S - map-NonEmpty f x = nonEmpty (f (NonEmpty.proof x)) + tri⇒dec≈ : Trichotomous _≈_ _<_ → Decidable _≈_ + tri⇒dec≈ compare x y with compare x y + ... | tri< _ x≉y _ = no x≉y + ... | tri≈ _ x≈y _ = yes x≈y + ... | tri> _ x≉y _ = no x≉y + + tri⇒dec< : Trichotomous _≈_ _<_ → Decidable _<_ + tri⇒dec< compare x y with compare x y + ... | tri< x<y _ _ = yes x<y + ... | tri≈ x≮y _ _ = no x≮y + ... | tri> x≮y _ _ = no x≮y + + trans∧tri⇒respʳ : Symmetric _≈_ → Transitive _≈_ → + Transitive _<_ → Trichotomous _≈_ _<_ → + _<_ Respectsʳ _≈_ + trans∧tri⇒respʳ sym ≈-tr <-tr tri {x} {y} {z} y≈z x<y with tri x z + ... | tri< x<z _ _ = x<z + ... | tri≈ _ x≈z _ = ⊥-elim (tri⇒irr tri (≈-tr x≈z (sym y≈z)) x<y) + ... | tri> _ _ z<x = ⊥-elim (tri⇒irr tri (sym y≈z) (<-tr z<x x<y)) + + trans∧tri⇒respˡ : Transitive _≈_ → + Transitive _<_ → Trichotomous _≈_ _<_ → + _<_ Respectsˡ _≈_ + trans∧tri⇒respˡ ≈-tr <-tr tri {z} {_} {y} x≈y x<z with tri y z + ... | tri< y<z _ _ = y<z + ... | tri≈ _ y≈z _ = ⊥-elim (tri⇒irr tri (≈-tr x≈y y≈z) x<z) + ... | tri> _ _ z<y = ⊥-elim (tri⇒irr tri x≈y (<-tr x<z z<y)) + + trans∧tri⇒resp : Symmetric _≈_ → Transitive _≈_ → + Transitive _<_ → Trichotomous _≈_ _<_ → + _<_ Respects₂ _≈_ + trans∧tri⇒resp sym ≈-tr <-tr tri = + trans∧tri⇒respʳ sym ≈-tr <-tr tri , + trans∧tri⇒respˡ ≈-tr <-tr tri + +------------------------------------------------------------------------ +-- Without Loss of Generality + +module _ {_R_ : Rel A ℓ₁} {Q : Rel A ℓ₂} where + + wlog : Total _R_ → Symmetric Q → + (∀ a b → a R b → Q a b) → + ∀ a b → Q a b + wlog r-total q-sym prf a b with r-total a b + ... | inj₁ aRb = prf a b aRb + ... | inj₂ bRa = q-sym (prf b a bRa) + +------------------------------------------------------------------------ +-- Other proofs + +module _ {R : REL A B p} where + + dec⇒weaklyDec : Decidable R → WeaklyDecidable R + dec⇒weaklyDec dec x y = decToMaybe (dec x y) + + dec⇒recomputable : Decidable R → Recomputable R + dec⇒recomputable dec {a} {b} = recompute $ dec a b + +module _ {R : REL A B ℓ₁} {S : REL A B ℓ₂} where + + map-NonEmpty : R ⇒ S → NonEmpty R → NonEmpty S + map-NonEmpty f x = nonEmpty (f (NonEmpty.proof x)) -module _ {R : REL A B ℓ₁} {S : REL B A ℓ₂} where +module _ {R : REL A B ℓ₁} {S : REL B A ℓ₂} where - flip-Connex : Connex R S → Connex S R - flip-Connex f x y = Sum.swap (f y x) + flip-Connex : Connex R S → Connex S R + flip-Connex f x y = Sum.swap (f y x) - - ------------------------------------------------------------------------- --- DEPRECATED NAMES ------------------------------------------------------------------------- --- Please use the new names as continuing support for the old names is --- not guaranteed. - --- Version 1.6 - -subst⟶respˡ = subst⇒respˡ -{-# WARNING_ON_USAGE subst⟶respˡ -"Warning: subst⟶respˡ was deprecated in v1.6. + + +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 1.6 + +subst⟶respˡ = subst⇒respˡ +{-# WARNING_ON_USAGE subst⟶respˡ +"Warning: subst⟶respˡ was deprecated in v1.6. Please use subst⇒respˡ instead." -#-} -subst⟶respʳ = subst⇒respʳ -{-# WARNING_ON_USAGE subst⟶respʳ -"Warning: subst⟶respʳ was deprecated in v1.6. +#-} +subst⟶respʳ = subst⇒respʳ +{-# WARNING_ON_USAGE subst⟶respʳ +"Warning: subst⟶respʳ was deprecated in v1.6. Please use subst⇒respʳ instead." -#-} -subst⟶resp₂ = subst⇒resp₂ -{-# WARNING_ON_USAGE subst⟶resp₂ -"Warning: subst⟶resp₂ was deprecated in v1.6. +#-} +subst⟶resp₂ = subst⇒resp₂ +{-# WARNING_ON_USAGE subst⟶resp₂ +"Warning: subst⟶resp₂ was deprecated in v1.6. Please use subst⇒resp₂ instead." -#-} -P-resp⟶¬P-resp = resp⇒¬-resp -{-# WARNING_ON_USAGE P-resp⟶¬P-resp -"Warning: P-resp⟶¬P-resp was deprecated in v1.6. +#-} +P-resp⟶¬P-resp = resp⇒¬-resp +{-# WARNING_ON_USAGE P-resp⟶¬P-resp +"Warning: P-resp⟶¬P-resp was deprecated in v1.6. Please use resp⇒¬-resp instead." -#-} -total⟶refl = total⇒refl -{-# WARNING_ON_USAGE total⟶refl -"Warning: total⟶refl was deprecated in v1.6. +#-} +total⟶refl = total⇒refl +{-# WARNING_ON_USAGE total⟶refl +"Warning: total⟶refl was deprecated in v1.6. Please use total⇒refl instead." -#-} -total+dec⟶dec = total∧dec⇒dec -{-# WARNING_ON_USAGE total+dec⟶dec -"Warning: total+dec⟶dec was deprecated in v1.6. +#-} +total+dec⟶dec = total∧dec⇒dec +{-# WARNING_ON_USAGE total+dec⟶dec +"Warning: total+dec⟶dec was deprecated in v1.6. Please use total∧dec⇒dec instead." -#-} -trans∧irr⟶asym = trans∧irr⇒asym -{-# WARNING_ON_USAGE trans∧irr⟶asym -"Warning: trans∧irr⟶asym was deprecated in v1.6. +#-} +trans∧irr⟶asym = trans∧irr⇒asym +{-# WARNING_ON_USAGE trans∧irr⟶asym +"Warning: trans∧irr⟶asym was deprecated in v1.6. Please use trans∧irr⇒asym instead." -#-} -irr∧antisym⟶asym = irr∧antisym⇒asym -{-# WARNING_ON_USAGE irr∧antisym⟶asym -"Warning: irr∧antisym⟶asym was deprecated in v1.6. +#-} +irr∧antisym⟶asym = irr∧antisym⇒asym +{-# WARNING_ON_USAGE irr∧antisym⟶asym +"Warning: irr∧antisym⟶asym was deprecated in v1.6. Please use irr∧antisym⇒asym instead." -#-} -asym⟶antisym = asym⇒antisym -{-# WARNING_ON_USAGE asym⟶antisym -"Warning: asym⟶antisym was deprecated in v1.6. +#-} +asym⟶antisym = asym⇒antisym +{-# WARNING_ON_USAGE asym⟶antisym +"Warning: asym⟶antisym was deprecated in v1.6. Please use asym⇒antisym instead." -#-} -asym⟶irr = asym⇒irr -{-# WARNING_ON_USAGE asym⟶irr -"Warning: asym⟶irr was deprecated in v1.6. +#-} +asym⟶irr = asym⇒irr +{-# WARNING_ON_USAGE asym⟶irr +"Warning: asym⟶irr was deprecated in v1.6. Please use asym⇒irr instead." -#-} -tri⟶asym = tri⇒asym -{-# WARNING_ON_USAGE tri⟶asym -"Warning: tri⟶asym was deprecated in v1.6. +#-} +tri⟶asym = tri⇒asym +{-# WARNING_ON_USAGE tri⟶asym +"Warning: tri⟶asym was deprecated in v1.6. Please use tri⇒asym instead." -#-} -tri⟶irr = tri⇒irr -{-# WARNING_ON_USAGE tri⟶irr -"Warning: tri⟶irr was deprecated in v1.6. +#-} +tri⟶irr = tri⇒irr +{-# WARNING_ON_USAGE tri⟶irr +"Warning: tri⟶irr was deprecated in v1.6. Please use tri⇒irr instead." -#-} -tri⟶dec≈ = tri⇒dec≈ -{-# WARNING_ON_USAGE tri⟶dec≈ -"Warning: tri⟶dec≈ was deprecated in v1.6. +#-} +tri⟶dec≈ = tri⇒dec≈ +{-# WARNING_ON_USAGE tri⟶dec≈ +"Warning: tri⟶dec≈ was deprecated in v1.6. Please use tri⇒dec≈ instead." -#-} -tri⟶dec< = tri⇒dec< -{-# WARNING_ON_USAGE tri⟶dec< -"Warning: tri⟶dec< was deprecated in v1.6. +#-} +tri⟶dec< = tri⇒dec< +{-# WARNING_ON_USAGE tri⟶dec< +"Warning: tri⟶dec< was deprecated in v1.6. Please use tri⇒dec< instead." -#-} -trans∧tri⟶respʳ≈ = trans∧tri⇒respʳ -{-# WARNING_ON_USAGE trans∧tri⟶respʳ≈ -"Warning: trans∧tri⟶respʳ≈ was deprecated in v1.6. +#-} +trans∧tri⟶respʳ≈ = trans∧tri⇒respʳ +{-# WARNING_ON_USAGE trans∧tri⟶respʳ≈ +"Warning: trans∧tri⟶respʳ≈ was deprecated in v1.6. Please use trans∧tri⇒respʳ instead." -#-} -trans∧tri⟶respˡ≈ = trans∧tri⇒respˡ -{-# WARNING_ON_USAGE trans∧tri⟶respˡ≈ -"Warning: trans∧tri⟶respˡ≈ was deprecated in v1.6. +#-} +trans∧tri⟶respˡ≈ = trans∧tri⇒respˡ +{-# WARNING_ON_USAGE trans∧tri⟶respˡ≈ +"Warning: trans∧tri⟶respˡ≈ was deprecated in v1.6. Please use trans∧tri⇒respˡ instead." -#-} -trans∧tri⟶resp≈ = trans∧tri⇒resp -{-# WARNING_ON_USAGE trans∧tri⟶resp≈ -"Warning: trans∧tri⟶resp≈ was deprecated in v1.6. +#-} +trans∧tri⟶resp≈ = trans∧tri⇒resp +{-# WARNING_ON_USAGE trans∧tri⟶resp≈ +"Warning: trans∧tri⟶resp≈ was deprecated in v1.6. Please use trans∧tri⇒resp instead." -#-} -dec⟶weaklyDec = dec⇒weaklyDec -{-# WARNING_ON_USAGE dec⟶weaklyDec -"Warning: dec⟶weaklyDec was deprecated in v1.6. +#-} +dec⟶weaklyDec = dec⇒weaklyDec +{-# WARNING_ON_USAGE dec⟶weaklyDec +"Warning: dec⟶weaklyDec was deprecated in v1.6. Please use dec⇒weaklyDec instead." -#-} -dec⟶recomputable = dec⇒recomputable -{-# WARNING_ON_USAGE dec⟶recomputable -"Warning: dec⟶recomputable was deprecated in v1.6. +#-} +dec⟶recomputable = dec⇒recomputable +{-# WARNING_ON_USAGE dec⟶recomputable +"Warning: dec⟶recomputable was deprecated in v1.6. Please use dec⇒recomputable instead." -#-} +#-} \ No newline at end of file diff --git a/Relation.Binary.Construct.Closure.Reflexive.Properties.html b/Relation.Binary.Construct.Closure.Reflexive.Properties.html deleted file mode 100644 index 7d4bd7eb..00000000 --- a/Relation.Binary.Construct.Closure.Reflexive.Properties.html +++ /dev/null @@ -1,144 +0,0 @@ - -Relation.Binary.Construct.Closure.Reflexive.Properties
------------------------------------------------------------------------
--- The Agda standard library
---
--- Some properties of reflexive closures
-------------------------------------------------------------------------
-
-{-# OPTIONS --safe --cubical-compatible #-}
-
-module Relation.Binary.Construct.Closure.Reflexive.Properties where
-
-open import Data.Product.Base as Prod
-open import Data.Sum.Base as Sum
-open import Function.Bundles using (_⇔_; mk⇔)
-open import Function.Base using (id)
-open import Level
-open import Relation.Binary hiding (_⇔_)
-open import Relation.Binary.Construct.Closure.Reflexive
-open import Relation.Binary.PropositionalEquality as PropEq using (_≡_; refl)
-open import Relation.Nullary
-import Relation.Nullary.Decidable as Dec
-open import Relation.Unary using (Pred)
-
-private
-  variable
-    a b ℓ p q : Level
-    A : Set a
-    B : Set b
-
-------------------------------------------------------------------------
--- Relational properties
-
-module _ {P : Rel A p} {Q : Rel B q} where
-
-  =[]⇒ : ∀ {f : A → B} → P =[ f ]⇒ Q → ReflClosure P =[ f ]⇒ ReflClosure Q
-  =[]⇒ x [ x∼y ] = [ x x∼y ]
-  =[]⇒ x refl    = refl
-
-module _ {_~_ : Rel A ℓ} where
-
-  private
-    _~ᵒ_ = ReflClosure _~_
-
-  fromSum : ∀ {x y} → x ≡ y ⊎ x ~ y → x ~ᵒ y
-  fromSum (inj₁ refl) = refl
-  fromSum (inj₂ y) = [ y ]
-
-  toSum : ∀ {x y} → x ~ᵒ y → x ≡ y ⊎ x ~ y
-  toSum [ x∼y ] = inj₂ x∼y
-  toSum refl = inj₁ refl
-
-  ⊎⇔Refl : ∀ {a b} → (a ≡ b ⊎ a ~ b) ⇔ a ~ᵒ b
-  ⊎⇔Refl = mk⇔ fromSum toSum
-
-  sym : Symmetric _~_ → Symmetric _~ᵒ_
-  sym ~-sym [ x∼y ] = [ ~-sym x∼y ]
-  sym ~-sym refl    = refl
-
-  trans : Transitive _~_ → Transitive _~ᵒ_
-  trans ~-trans [ x∼y ] [ x∼y₁ ] = [ ~-trans x∼y x∼y₁ ]
-  trans ~-trans [ x∼y ] refl     = [ x∼y ]
-  trans ~-trans refl    [ x∼y ]  = [ x∼y ]
-  trans ~-trans refl    refl     = refl
-
-  antisym : (_≈_ : Rel A p) → Reflexive _≈_ →
-            Asymmetric _~_ → Antisymmetric _≈_ _~ᵒ_
-  antisym _≈_ ref asym [ x∼y ] [ y∼x ] = contradiction x∼y (asym y∼x)
-  antisym _≈_ ref asym [ x∼y ] refl    = ref
-  antisym _≈_ ref asym refl    _       = ref
-
-  total : Trichotomous _≡_ _~_ → Total _~ᵒ_
-  total compare x y with compare x y
-  ... | tri< a _    _ = inj₁ [ a ]
-  ... | tri≈ _ refl _ = inj₁ refl
-  ... | tri> _ _    c = inj₂ [ c ]
-
-  dec : Decidable {A = A} _≡_ → Decidable _~_ → Decidable _~ᵒ_
-  dec ≡-dec ~-dec a b = Dec.map ⊎⇔Refl (≡-dec a b ⊎-dec ~-dec a b)
-
-  decidable : Trichotomous _≡_ _~_ → Decidable _~ᵒ_
-  decidable ~-tri a b with ~-tri a b
-  ... | tri< a~b  _  _ = yes [ a~b ]
-  ... | tri≈ _  refl _ = yes refl
-  ... | tri> ¬a ¬b   _ = no λ { refl → ¬b refl ; [ p ] → ¬a p }
-
-  respˡ : ∀ {P : REL A B p} → P Respectsˡ _~_ → P Respectsˡ _~ᵒ_
-  respˡ p-respˡ-~ [ x∼y ] = p-respˡ-~ x∼y
-  respˡ _         refl    = id
-
-  respʳ : ∀ {P : REL B A p} → P Respectsʳ _~_ → P Respectsʳ _~ᵒ_
-  respʳ = respˡ
-
-module _ {_~_ : Rel A ℓ} {P : Pred A p} where
-
-  resp : P Respects _~_ → P Respects (ReflClosure _~_)
-  resp p-resp-~ [ x∼y ] = p-resp-~ x∼y
-  resp _        refl    = id
-
-module _ {_~_ : Rel A ℓ} {P : Rel A p} where
-
-  resp₂ : P Respects₂ _~_ → P Respects₂ (ReflClosure _~_)
-  resp₂ = Prod.map respˡ respʳ
-
-------------------------------------------------------------------------
--- Structures
-
-module _ {_~_ : Rel A ℓ} where
-
-  private
-    _~ᵒ_ = ReflClosure _~_
-
-  isPreorder : Transitive _~_ → IsPreorder _≡_ _~ᵒ_
-  isPreorder ~-trans = record
-    { isEquivalence = PropEq.isEquivalence
-    ; reflexive     = λ { refl → refl }
-    ; trans         = trans ~-trans
-    }
-
-  isPartialOrder : IsStrictPartialOrder _≡_ _~_ → IsPartialOrder _≡_ _~ᵒ_
-  isPartialOrder O = record
-    { isPreorder = isPreorder O.trans
-    ; antisym    = antisym _≡_ refl O.asym
-    } where module O = IsStrictPartialOrder O
-
-  isDecPartialOrder : IsDecStrictPartialOrder _≡_ _~_ → IsDecPartialOrder _≡_ _~ᵒ_
-  isDecPartialOrder O = record
-    { isPartialOrder = isPartialOrder O.isStrictPartialOrder
-    ; _≟_            = O._≟_
-    ; _≤?_           = dec O._≟_ O._<?_
-    } where module O = IsDecStrictPartialOrder O
-
-  isTotalOrder : IsStrictTotalOrder _≡_ _~_ → IsTotalOrder _≡_ _~ᵒ_
-  isTotalOrder O = record
-    { isPartialOrder = isPartialOrder isStrictPartialOrder
-    ; total          = total compare
-    } where open IsStrictTotalOrder O
-
-  isDecTotalOrder : IsStrictTotalOrder _≡_ _~_ → IsDecTotalOrder _≡_ _~ᵒ_
-  isDecTotalOrder O = record
-    { isTotalOrder = isTotalOrder O
-    ; _≟_          = _≟_
-    ; _≤?_         = dec _≟_ _<?_
-    } where open IsStrictTotalOrder O
-
\ No newline at end of file diff --git a/Relation.Binary.Construct.Closure.Reflexive.html b/Relation.Binary.Construct.Closure.Reflexive.html index 9a154160..3237e82c 100644 --- a/Relation.Binary.Construct.Closure.Reflexive.html +++ b/Relation.Binary.Construct.Closure.Reflexive.html @@ -11,9 +11,9 @@ open import Data.Unit.Base open import Level -open import Function.Base using (_∋_) -open import Relation.Binary.Core using (Rel; _=[_]⇒_; _⇒_) -open import Relation.Binary.Definitions using (Reflexive) +open import Function.Base using (_∋_) +open import Relation.Binary.Core using (Rel; _=[_]⇒_; _⇒_) +open import Relation.Binary.Definitions using (Reflexive) open import Relation.Binary.Construct.Constant.Core using (Const) open import Relation.Binary.PropositionalEquality.Core using (_≡_ ; refl) @@ -25,15 +25,15 @@ ------------------------------------------------------------------------ -- Definition -data ReflClosure {A : Set a} (_∼_ : Rel A ℓ) : Rel A (a ⊔ ℓ) where - refl : Reflexive (ReflClosure _∼_) +data ReflClosure {A : Set a} (_∼_ : Rel A ℓ) : Rel A (a ⊔ ℓ) where + refl : Reflexive (ReflClosure _∼_) [_] : ∀ {x y} (x∼y : x ∼ y) → ReflClosure _∼_ x y ------------------------------------------------------------------------ -- Operations -map : ∀ {R : Rel A ℓ₁} {S : Rel B ℓ₂} {f : A → B} → - R =[ f ]⇒ S → ReflClosure R =[ f ]⇒ ReflClosure S +map : ∀ {R : Rel A ℓ₁} {S : Rel B ℓ₂} {f : A → B} → + R =[ f ]⇒ S → ReflClosure R =[ f ]⇒ ReflClosure S map R⇒S [ xRy ] = [ R⇒S xRy ] map R⇒S refl = refl @@ -41,15 +41,15 @@ -- Properties -- The reflexive closure has no effect on reflexive relations. -drop-refl : {R : Rel A ℓ} → Reflexive R → ReflClosure R ⇒ R +drop-refl : {R : Rel A ℓ} → Reflexive R → ReflClosure R ⇒ R drop-refl rfl [ xRy ] = xRy drop-refl rfl refl = rfl -reflexive : {R : Rel A ℓ} → _≡_ ⇒ ReflClosure R +reflexive : {R : Rel A ℓ} → _≡_ ⇒ ReflClosure R reflexive refl = refl -[]-injective : {R : Rel A ℓ} → ∀ {x y p q} → - (ReflClosure R x y ∋ [ p ]) ≡ [ q ] → p ≡ q +[]-injective : {R : Rel A ℓ} → ∀ {x y p q} → + (ReflClosure R x y ∋ [ p ]) ≡ [ q ] → p ≡ q []-injective refl = refl ------------------------------------------------------------------------ diff --git a/Relation.Binary.Construct.Constant.Core.html b/Relation.Binary.Construct.Constant.Core.html index f5a59525..78f197ff 100644 --- a/Relation.Binary.Construct.Constant.Core.html +++ b/Relation.Binary.Construct.Constant.Core.html @@ -10,7 +10,7 @@ module Relation.Binary.Construct.Constant.Core where open import Level -open import Relation.Binary.Core using (REL) +open import Relation.Binary.Core using (REL) private variable @@ -21,6 +21,6 @@ ------------------------------------------------------------------------ -- Definition -Const : Set c → REL A B c +Const : Set c → REL A B c Const I = λ _ _ → I \ No newline at end of file diff --git a/Relation.Binary.Construct.Converse.html b/Relation.Binary.Construct.Converse.html deleted file mode 100644 index 46d9e092..00000000 --- a/Relation.Binary.Construct.Converse.html +++ /dev/null @@ -1,197 +0,0 @@ - -Relation.Binary.Construct.Converse
------------------------------------------------------------------------
--- The Agda standard library
---
--- Many properties which hold for `∼` also hold for `flip ∼`. Unlike
--- the module `Relation.Binary.Construct.Flip` this module does not
--- flip the underlying equality.
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-open import Relation.Binary
-
-module Relation.Binary.Construct.Converse where
-
-open import Data.Product
-open import Function.Base using (flip; _∘_)
-open import Level using (Level)
-
-private
-  variable
-    a b p ℓ ℓ₁ ℓ₂ : Level
-    A B : Set a
-    ≈ ∼ ≤ < : Rel A ℓ
-
-------------------------------------------------------------------------
--- Properties
-
-module _ (∼ : Rel A ℓ) where
-
-  refl : Reflexive ∼ → Reflexive (flip ∼)
-  refl refl = refl
-
-  sym : Symmetric ∼ → Symmetric (flip ∼)
-  sym sym = sym
-
-  trans : Transitive ∼ → Transitive (flip ∼)
-  trans trans = flip trans
-
-  asym : Asymmetric ∼ → Asymmetric (flip ∼)
-  asym asym = asym
-
-  total : Total ∼ → Total (flip ∼)
-  total total x y = total y x
-
-  resp : ∀ {p} (P : A → Set p) → Symmetric ∼ →
-             P Respects ∼ → P Respects (flip ∼)
-  resp _ sym resp ∼ = resp (sym ∼)
-
-  max : ∀ {⊥} → Minimum ∼ ⊥ → Maximum (flip ∼) ⊥
-  max min = min
-
-  min : ∀ {⊤} → Maximum ∼ ⊤ → Minimum (flip ∼) ⊤
-  min max = max
-
-module _ {≈ : Rel A ℓ₁} (∼ : Rel A ℓ₂) where
-
-  reflexive : Symmetric ≈ → (≈ ⇒ ∼) → (≈ ⇒ flip ∼)
-  reflexive sym impl = impl ∘ sym
-
-  irrefl : Symmetric ≈ → Irreflexive ≈ ∼ → Irreflexive ≈ (flip ∼)
-  irrefl sym irrefl x≈y y∼x = irrefl (sym x≈y) y∼x
-
-  antisym : Antisymmetric ≈ ∼ → Antisymmetric ≈ (flip ∼)
-  antisym antisym = flip antisym
-
-  compare : Trichotomous ≈ ∼ → Trichotomous ≈ (flip ∼)
-  compare cmp x y with cmp x y
-  ... | tri< x<y x≉y y≮x = tri> y≮x x≉y x<y
-  ... | tri≈ x≮y x≈y y≮x = tri≈ y≮x x≈y x≮y
-  ... | tri> x≮y x≉y y<x = tri< y<x x≉y x≮y
-
-module _ (∼₁ : Rel A ℓ₁) (∼₂ : Rel A ℓ₂) where
-
-  resp₂ : ∼₁ Respects₂ ∼₂ → (flip ∼₁) Respects₂ ∼₂
-  resp₂ (resp₁ , resp₂) = resp₂ , resp₁
-
-module _ (∼ : REL A B ℓ) where
-
-  dec : Decidable ∼ → Decidable (flip ∼)
-  dec dec = flip dec
-
-------------------------------------------------------------------------
--- Structures
-
-isEquivalence : IsEquivalence ≈ → IsEquivalence (flip ≈)
-isEquivalence {≈ = ≈} eq = record
-  { refl  = refl  ≈ Eq.refl
-  ; sym   = sym   ≈ Eq.sym
-  ; trans = trans ≈ Eq.trans
-  } where module Eq = IsEquivalence eq
-
-isDecEquivalence : IsDecEquivalence ≈ → IsDecEquivalence (flip ≈)
-isDecEquivalence {≈ = ≈} eq = record
-  { isEquivalence = isEquivalence Dec.isEquivalence
-  ; _≟_           = dec ≈ Dec._≟_
-  } where module Dec = IsDecEquivalence eq
-
-isPreorder : IsPreorder ≈ ∼ → IsPreorder ≈ (flip ∼)
-isPreorder {≈ = ≈} {∼ = ∼} O = record
-  { isEquivalence = O.isEquivalence
-  ; reflexive     = reflexive ∼ O.Eq.sym O.reflexive
-  ; trans         = trans ∼ O.trans
-  } where module O = IsPreorder O
-
-isTotalPreorder : IsTotalPreorder ≈ ∼ → IsTotalPreorder ≈ (flip ∼)
-isTotalPreorder O = record
-  { isPreorder = isPreorder O.isPreorder
-  ; total      = total _ O.total
-  } where module O = IsTotalPreorder O
-
-isPartialOrder : IsPartialOrder ≈ ≤ → IsPartialOrder ≈ (flip ≤)
-isPartialOrder {≤ = ≤} O = record
-  { isPreorder = isPreorder O.isPreorder
-  ; antisym    = antisym ≤ O.antisym
-  } where module O = IsPartialOrder O
-
-isTotalOrder : IsTotalOrder ≈ ≤ → IsTotalOrder ≈ (flip ≤)
-isTotalOrder O = record
-  { isPartialOrder = isPartialOrder O.isPartialOrder
-  ; total          = total _ O.total
-  } where module O = IsTotalOrder O
-
-isDecTotalOrder : IsDecTotalOrder ≈ ≤ → IsDecTotalOrder ≈ (flip ≤)
-isDecTotalOrder O = record
-  { isTotalOrder = isTotalOrder O.isTotalOrder
-  ; _≟_          = O._≟_
-  ; _≤?_         = dec _ O._≤?_
-  } where module O = IsDecTotalOrder O
-
-isStrictPartialOrder : IsStrictPartialOrder ≈ < →
-                       IsStrictPartialOrder ≈ (flip <)
-isStrictPartialOrder {< = <} O = record
-  { isEquivalence = O.isEquivalence
-  ; irrefl        = irrefl < O.Eq.sym O.irrefl
-  ; trans         = trans < O.trans
-  ; <-resp-≈      = resp₂ _ _ O.<-resp-≈
-  } where module O = IsStrictPartialOrder O
-
-isStrictTotalOrder : IsStrictTotalOrder ≈ < →
-                     IsStrictTotalOrder ≈ (flip <)
-isStrictTotalOrder {< = <} O = record
-  { isEquivalence = O.isEquivalence
-  ; trans         = trans < O.trans
-  ; compare       = compare _ O.compare
-  } where module O = IsStrictTotalOrder O
-
-------------------------------------------------------------------------
--- Bundles
-
-setoid : Setoid a ℓ → Setoid a ℓ
-setoid S = record
-  { isEquivalence = isEquivalence S.isEquivalence
-  } where module S = Setoid S
-
-decSetoid : DecSetoid a ℓ → DecSetoid a ℓ
-decSetoid S = record
-  { isDecEquivalence = isDecEquivalence S.isDecEquivalence
-  } where module S = DecSetoid S
-
-preorder : Preorder a ℓ₁ ℓ₂ → Preorder a ℓ₁ ℓ₂
-preorder O = record
-  { isPreorder = isPreorder O.isPreorder
-  } where module O = Preorder O
-
-totalPreorder : TotalPreorder a ℓ₁ ℓ₂ → TotalPreorder a ℓ₁ ℓ₂
-totalPreorder O = record
-  { isTotalPreorder = isTotalPreorder O.isTotalPreorder
-  } where module O = TotalPreorder O
-
-poset : Poset a ℓ₁ ℓ₂ → Poset a ℓ₁ ℓ₂
-poset O = record
-  { isPartialOrder = isPartialOrder O.isPartialOrder
-  } where module O = Poset O
-
-totalOrder : TotalOrder a ℓ₁ ℓ₂ → TotalOrder a ℓ₁ ℓ₂
-totalOrder O = record
-  { isTotalOrder = isTotalOrder O.isTotalOrder
-  } where module O = TotalOrder O
-
-decTotalOrder : DecTotalOrder a ℓ₁ ℓ₂ → DecTotalOrder a ℓ₁ ℓ₂
-decTotalOrder O = record
-  { isDecTotalOrder = isDecTotalOrder O.isDecTotalOrder
-  } where module O = DecTotalOrder O
-
-strictPartialOrder : StrictPartialOrder a ℓ₁ ℓ₂ →
-                     StrictPartialOrder a ℓ₁ ℓ₂
-strictPartialOrder O = record
-  { isStrictPartialOrder = isStrictPartialOrder O.isStrictPartialOrder
-  } where module O = StrictPartialOrder O
-
-strictTotalOrder : StrictTotalOrder a ℓ₁ ℓ₂ →
-                   StrictTotalOrder a ℓ₁ ℓ₂
-strictTotalOrder O = record
-  { isStrictTotalOrder = isStrictTotalOrder O.isStrictTotalOrder
-  } where module O = StrictTotalOrder O
-
\ No newline at end of file diff --git a/Relation.Binary.Construct.Flip.EqAndOrd.html b/Relation.Binary.Construct.Flip.EqAndOrd.html new file mode 100644 index 00000000..3133ae76 --- /dev/null +++ b/Relation.Binary.Construct.Flip.EqAndOrd.html @@ -0,0 +1,202 @@ + +Relation.Binary.Construct.Flip.EqAndOrd
------------------------------------------------------------------------
+-- The Agda standard library
+--
+-- Many properties which hold for `∼` also hold for `flip ∼`. Unlike
+-- the module `Relation.Binary.Construct.Flip.Ord` this module does not
+-- flip the underlying equality.
+------------------------------------------------------------------------
+
+{-# OPTIONS --cubical-compatible --safe #-}
+
+open import Relation.Binary.Core using (Rel; REL; _⇒_)
+open import Relation.Binary.Bundles
+  using (Setoid; DecSetoid; Preorder; Poset; TotalOrder; DecTotalOrder; StrictPartialOrder; StrictTotalOrder; TotalPreorder)
+open import Relation.Binary.Structures
+  using (IsEquivalence; IsDecEquivalence; IsPreorder; IsPartialOrder; IsTotalOrder; IsDecTotalOrder; IsStrictPartialOrder; IsStrictTotalOrder; IsTotalPreorder)
+open import Relation.Binary.Definitions
+  using (Reflexive; Symmetric; Transitive; Asymmetric; Total; _Respects_; _Respects₂_; Minimum; Maximum; Irreflexive; Antisymmetric; Trichotomous; Decidable; tri<; tri>; tri≈)
+
+module Relation.Binary.Construct.Flip.EqAndOrd where
+
+open import Data.Product.Base using (_,_)
+open import Function.Base using (flip; _∘_)
+open import Level using (Level)
+
+private
+  variable
+    a b p ℓ ℓ₁ ℓ₂ : Level
+    A B : Set a
+    ≈ ∼ ≤ < : Rel A ℓ
+
+------------------------------------------------------------------------
+-- Properties
+
+module _ (∼ : Rel A ℓ) where
+
+  refl : Reflexive ∼ → Reflexive (flip ∼)
+  refl refl = refl
+
+  sym : Symmetric ∼ → Symmetric (flip ∼)
+  sym sym = sym
+
+  trans : Transitive ∼ → Transitive (flip ∼)
+  trans trans = flip trans
+
+  asym : Asymmetric ∼ → Asymmetric (flip ∼)
+  asym asym = asym
+
+  total : Total ∼ → Total (flip ∼)
+  total total x y = total y x
+
+  resp : ∀ {p} (P : A → Set p) → Symmetric ∼ →
+             P Respects ∼ → P Respects (flip ∼)
+  resp _ sym resp ∼ = resp (sym ∼)
+
+  max : ∀ {⊥} → Minimum ∼ ⊥ → Maximum (flip ∼) ⊥
+  max min = min
+
+  min : ∀ {⊤} → Maximum ∼ ⊤ → Minimum (flip ∼) ⊤
+  min max = max
+
+module _ {≈ : Rel A ℓ₁} (∼ : Rel A ℓ₂) where
+
+  reflexive : Symmetric ≈ → (≈ ⇒ ∼) → (≈ ⇒ flip ∼)
+  reflexive sym impl = impl ∘ sym
+
+  irrefl : Symmetric ≈ → Irreflexive ≈ ∼ → Irreflexive ≈ (flip ∼)
+  irrefl sym irrefl x≈y y∼x = irrefl (sym x≈y) y∼x
+
+  antisym : Antisymmetric ≈ ∼ → Antisymmetric ≈ (flip ∼)
+  antisym antisym = flip antisym
+
+  compare : Trichotomous ≈ ∼ → Trichotomous ≈ (flip ∼)
+  compare cmp x y with cmp x y
+  ... | tri< x<y x≉y y≮x = tri> y≮x x≉y x<y
+  ... | tri≈ x≮y x≈y y≮x = tri≈ y≮x x≈y x≮y
+  ... | tri> x≮y x≉y y<x = tri< y<x x≉y x≮y
+
+module _ (∼₁ : Rel A ℓ₁) (∼₂ : Rel A ℓ₂) where
+
+  resp₂ : ∼₁ Respects₂ ∼₂ → (flip ∼₁) Respects₂ ∼₂
+  resp₂ (resp₁ , resp₂) = resp₂ , resp₁
+
+module _ (∼ : REL A B ℓ) where
+
+  dec : Decidable ∼ → Decidable (flip ∼)
+  dec dec = flip dec
+
+------------------------------------------------------------------------
+-- Structures
+
+isEquivalence : IsEquivalence ≈ → IsEquivalence (flip ≈)
+isEquivalence {≈ = ≈} eq = record
+  { refl  = refl  ≈ Eq.refl
+  ; sym   = sym   ≈ Eq.sym
+  ; trans = trans ≈ Eq.trans
+  } where module Eq = IsEquivalence eq
+
+isDecEquivalence : IsDecEquivalence ≈ → IsDecEquivalence (flip ≈)
+isDecEquivalence {≈ = ≈} eq = record
+  { isEquivalence = isEquivalence Dec.isEquivalence
+  ; _≟_           = dec ≈ Dec._≟_
+  } where module Dec = IsDecEquivalence eq
+
+isPreorder : IsPreorder ≈ ∼ → IsPreorder ≈ (flip ∼)
+isPreorder {≈ = ≈} {∼ = ∼} O = record
+  { isEquivalence = O.isEquivalence
+  ; reflexive     = reflexive ∼ O.Eq.sym O.reflexive
+  ; trans         = trans ∼ O.trans
+  } where module O = IsPreorder O
+
+isTotalPreorder : IsTotalPreorder ≈ ∼ → IsTotalPreorder ≈ (flip ∼)
+isTotalPreorder O = record
+  { isPreorder = isPreorder O.isPreorder
+  ; total      = total _ O.total
+  } where module O = IsTotalPreorder O
+
+isPartialOrder : IsPartialOrder ≈ ≤ → IsPartialOrder ≈ (flip ≤)
+isPartialOrder {≤ = ≤} O = record
+  { isPreorder = isPreorder O.isPreorder
+  ; antisym    = antisym ≤ O.antisym
+  } where module O = IsPartialOrder O
+
+isTotalOrder : IsTotalOrder ≈ ≤ → IsTotalOrder ≈ (flip ≤)
+isTotalOrder O = record
+  { isPartialOrder = isPartialOrder O.isPartialOrder
+  ; total          = total _ O.total
+  } where module O = IsTotalOrder O
+
+isDecTotalOrder : IsDecTotalOrder ≈ ≤ → IsDecTotalOrder ≈ (flip ≤)
+isDecTotalOrder O = record
+  { isTotalOrder = isTotalOrder O.isTotalOrder
+  ; _≟_          = O._≟_
+  ; _≤?_         = dec _ O._≤?_
+  } where module O = IsDecTotalOrder O
+
+isStrictPartialOrder : IsStrictPartialOrder ≈ < →
+                       IsStrictPartialOrder ≈ (flip <)
+isStrictPartialOrder {< = <} O = record
+  { isEquivalence = O.isEquivalence
+  ; irrefl        = irrefl < O.Eq.sym O.irrefl
+  ; trans         = trans < O.trans
+  ; <-resp-≈      = resp₂ _ _ O.<-resp-≈
+  } where module O = IsStrictPartialOrder O
+
+isStrictTotalOrder : IsStrictTotalOrder ≈ < →
+                     IsStrictTotalOrder ≈ (flip <)
+isStrictTotalOrder {< = <} O = record
+  { isStrictPartialOrder = isStrictPartialOrder O.isStrictPartialOrder
+  ; compare              = compare _ O.compare
+  } where module O = IsStrictTotalOrder O
+
+------------------------------------------------------------------------
+-- Bundles
+
+setoid : Setoid a ℓ → Setoid a ℓ
+setoid S = record
+  { isEquivalence = isEquivalence S.isEquivalence
+  } where module S = Setoid S
+
+decSetoid : DecSetoid a ℓ → DecSetoid a ℓ
+decSetoid S = record
+  { isDecEquivalence = isDecEquivalence S.isDecEquivalence
+  } where module S = DecSetoid S
+
+preorder : Preorder a ℓ₁ ℓ₂ → Preorder a ℓ₁ ℓ₂
+preorder O = record
+  { isPreorder = isPreorder O.isPreorder
+  } where module O = Preorder O
+
+totalPreorder : TotalPreorder a ℓ₁ ℓ₂ → TotalPreorder a ℓ₁ ℓ₂
+totalPreorder O = record
+  { isTotalPreorder = isTotalPreorder O.isTotalPreorder
+  } where module O = TotalPreorder O
+
+poset : Poset a ℓ₁ ℓ₂ → Poset a ℓ₁ ℓ₂
+poset O = record
+  { isPartialOrder = isPartialOrder O.isPartialOrder
+  } where module O = Poset O
+
+totalOrder : TotalOrder a ℓ₁ ℓ₂ → TotalOrder a ℓ₁ ℓ₂
+totalOrder O = record
+  { isTotalOrder = isTotalOrder O.isTotalOrder
+  } where module O = TotalOrder O
+
+decTotalOrder : DecTotalOrder a ℓ₁ ℓ₂ → DecTotalOrder a ℓ₁ ℓ₂
+decTotalOrder O = record
+  { isDecTotalOrder = isDecTotalOrder O.isDecTotalOrder
+  } where module O = DecTotalOrder O
+
+strictPartialOrder : StrictPartialOrder a ℓ₁ ℓ₂ →
+                     StrictPartialOrder a ℓ₁ ℓ₂
+strictPartialOrder O = record
+  { isStrictPartialOrder = isStrictPartialOrder O.isStrictPartialOrder
+  } where module O = StrictPartialOrder O
+
+strictTotalOrder : StrictTotalOrder a ℓ₁ ℓ₂ →
+                   StrictTotalOrder a ℓ₁ ℓ₂
+strictTotalOrder O = record
+  { isStrictTotalOrder = isStrictTotalOrder O.isStrictTotalOrder
+  } where module O = StrictTotalOrder O
+
\ No newline at end of file diff --git a/Relation.Binary.Construct.Intersection.html b/Relation.Binary.Construct.Intersection.html index 78b8b883..8d6ad5a2 100644 --- a/Relation.Binary.Construct.Intersection.html +++ b/Relation.Binary.Construct.Intersection.html @@ -13,128 +13,134 @@ open import Data.Sum.Base using (_⊎_; inj₁; inj₂; [_,_]) open import Function.Base using (_∘_) open import Level using (Level; _⊔_) -open import Relation.Binary -open import Relation.Nullary.Decidable using (yes; no; _×-dec_) +open import Relation.Binary.Core using (Rel; REL; _⇒_) +open import Relation.Binary.Structures + using (IsEquivalence; IsDecEquivalence; IsPreorder; IsPartialOrder; IsStrictPartialOrder) +open import Relation.Binary.Definitions + using (Reflexive; Symmetric; Transitive; Antisymmetric; Decidable; _Respects_; _Respectsˡ_; _Respectsʳ_; _Respects₂_; Minimum; Maximum; Irreflexive) +open import Relation.Nullary.Decidable using (yes; no; _×-dec_) -private - variable - a b ℓ₁ ℓ₂ ℓ₃ : Level - A B : Set a - ≈ L R : Rel A ℓ₁ +private + variable + a b ℓ₁ ℓ₂ ℓ₃ : Level + A B : Set a + ≈ L R : Rel A ℓ₁ ------------------------------------------------------------------------- --- Definition +------------------------------------------------------------------------ +-- Definition -_∩_ : REL A B ℓ₁ → REL A B ℓ₂ → REL A B (ℓ₁ ⊔ ℓ₂) -L ∩ R = λ i j → L i j × R i j +infixl 6 _∩_ ------------------------------------------------------------------------- --- Properties +_∩_ : REL A B ℓ₁ → REL A B ℓ₂ → REL A B (ℓ₁ ⊔ ℓ₂) +L ∩ R = λ i j → L i j × R i j -module _ (L : Rel A ℓ₁) (R : Rel A ℓ₂) where +------------------------------------------------------------------------ +-- Properties - reflexive : Reflexive L → Reflexive R → Reflexive (L ∩ R) - reflexive L-refl R-refl = L-refl , R-refl +module _ (L : Rel A ℓ₁) (R : Rel A ℓ₂) where - symmetric : Symmetric L → Symmetric R → Symmetric (L ∩ R) - symmetric L-sym R-sym = map L-sym R-sym - - transitive : Transitive L → Transitive R → Transitive (L ∩ R) - transitive L-trans R-trans = zip L-trans R-trans - - respects : ∀ {p} (P : A → Set p) → - P Respects L ⊎ P Respects R → P Respects (L ∩ R) - respects P resp (Lxy , Rxy) = [ (λ x → x Lxy) , (λ x → x Rxy) ] resp - - min : ∀ {⊤} → Minimum L ⊤ → Minimum R ⊤ → Minimum (L ∩ R) ⊤ - min L-min R-min = < L-min , R-min > - - max : ∀ {⊥} → Maximum L ⊥ → Maximum R ⊥ → Maximum (L ∩ R) ⊥ - max L-max R-max = < L-max , R-max > - -module _ (≈ : REL A B ℓ₁) {L : REL A B ℓ₂} {R : REL A B ℓ₃} where - - implies : (≈ ⇒ L) → (≈ ⇒ R) → ≈ ⇒ (L ∩ R) - implies ≈⇒L ≈⇒R = < ≈⇒L , ≈⇒R > - -module _ (≈ : REL A B ℓ₁) (L : REL A B ℓ₂) (R : REL A B ℓ₃) where - - irreflexive : Irreflexive ≈ L ⊎ Irreflexive ≈ R → Irreflexive ≈ (L ∩ R) - irreflexive irrefl x≈y (Lxy , Rxy) = [ (λ x → x x≈y Lxy) , (λ x → x x≈y Rxy) ] irrefl - -module _ (≈ : Rel A ℓ₁) (L : Rel A ℓ₂) (R : Rel A ℓ₃) where - - respectsˡ : L Respectsˡ ≈ → R Respectsˡ ≈ → (L ∩ R) Respectsˡ ≈ - respectsˡ L-resp R-resp x≈y = map (L-resp x≈y) (R-resp x≈y) - - respectsʳ : L Respectsʳ ≈ → R Respectsʳ ≈ → (L ∩ R) Respectsʳ ≈ - respectsʳ L-resp R-resp x≈y = map (L-resp x≈y) (R-resp x≈y) - - respects₂ : L Respects₂ ≈ → R Respects₂ ≈ → (L ∩ R) Respects₂ ≈ - respects₂ (Lʳ , Lˡ) (Rʳ , Rˡ) = respectsʳ Lʳ Rʳ , respectsˡ Lˡ Rˡ - - antisymmetric : Antisymmetric ≈ L ⊎ Antisymmetric ≈ R → Antisymmetric ≈ (L ∩ R) - antisymmetric (inj₁ L-antisym) (Lxy , _) (Lyx , _) = L-antisym Lxy Lyx - antisymmetric (inj₂ R-antisym) (_ , Rxy) (_ , Ryx) = R-antisym Rxy Ryx - -module _ {L : REL A B ℓ₁} {R : REL A B ℓ₂} where - - decidable : Decidable L → Decidable R → Decidable (L ∩ R) - decidable L? R? x y = L? x y ×-dec R? x y - ------------------------------------------------------------------------- --- Structures - -isEquivalence : IsEquivalence L → IsEquivalence R → IsEquivalence (L ∩ R) -isEquivalence {L = L} {R = R} eqₗ eqᵣ = record - { refl = reflexive L R L.refl R.refl - ; sym = symmetric L R L.sym R.sym - ; trans = transitive L R L.trans R.trans - } where module L = IsEquivalence eqₗ; module R = IsEquivalence eqᵣ - -isDecEquivalence : IsDecEquivalence L → IsDecEquivalence R → IsDecEquivalence (L ∩ R) -isDecEquivalence eqₗ eqᵣ = record - { isEquivalence = isEquivalence L.isEquivalence R.isEquivalence - ; _≟_ = decidable L._≟_ R._≟_ - } where module L = IsDecEquivalence eqₗ; module R = IsDecEquivalence eqᵣ - -isPreorder : IsPreorder ≈ L → IsPreorder ≈ R → IsPreorder ≈ (L ∩ R) -isPreorder {≈ = ≈} {L = L} {R = R} Oₗ Oᵣ = record - { isEquivalence = Oₗ.isEquivalence - ; reflexive = implies ≈ Oₗ.reflexive Oᵣ.reflexive - ; trans = transitive L R Oₗ.trans Oᵣ.trans - } - where module Oₗ = IsPreorder Oₗ; module Oᵣ = IsPreorder Oᵣ - -isPartialOrderˡ : IsPartialOrder ≈ L → IsPreorder ≈ R → IsPartialOrder ≈ (L ∩ R) -isPartialOrderˡ {≈ = ≈} {L = L} {R = R} Oₗ Oᵣ = record - { isPreorder = isPreorder Oₗ.isPreorder Oᵣ - ; antisym = antisymmetric ≈ L R (inj₁ Oₗ.antisym) - } where module Oₗ = IsPartialOrder Oₗ; module Oᵣ = IsPreorder Oᵣ - -isPartialOrderʳ : IsPreorder ≈ L → IsPartialOrder ≈ R → IsPartialOrder ≈ (L ∩ R) -isPartialOrderʳ {≈ = ≈} {L = L} {R = R} Oₗ Oᵣ = record - { isPreorder = isPreorder Oₗ Oᵣ.isPreorder - ; antisym = antisymmetric ≈ L R (inj₂ Oᵣ.antisym) - } where module Oₗ = IsPreorder Oₗ; module Oᵣ = IsPartialOrder Oᵣ - -isStrictPartialOrderˡ : IsStrictPartialOrder ≈ L → - Transitive R → R Respects₂ ≈ → - IsStrictPartialOrder ≈ (L ∩ R) -isStrictPartialOrderˡ {≈ = ≈} {L = L} {R = R} Oₗ transᵣ respᵣ = record - { isEquivalence = Oₗ.isEquivalence - ; irrefl = irreflexive ≈ L R (inj₁ Oₗ.irrefl) - ; trans = transitive L R Oₗ.trans transᵣ - ; <-resp-≈ = respects₂ ≈ L R Oₗ.<-resp-≈ respᵣ - } where module Oₗ = IsStrictPartialOrder Oₗ + reflexive : Reflexive L → Reflexive R → Reflexive (L ∩ R) + reflexive L-refl R-refl = L-refl , R-refl + + symmetric : Symmetric L → Symmetric R → Symmetric (L ∩ R) + symmetric L-sym R-sym = map L-sym R-sym + + transitive : Transitive L → Transitive R → Transitive (L ∩ R) + transitive L-trans R-trans = zip L-trans R-trans + + respects : ∀ {p} (P : A → Set p) → + P Respects L ⊎ P Respects R → P Respects (L ∩ R) + respects P resp (Lxy , Rxy) = [ (λ x → x Lxy) , (λ x → x Rxy) ] resp + + min : ∀ {⊤} → Minimum L ⊤ → Minimum R ⊤ → Minimum (L ∩ R) ⊤ + min L-min R-min = < L-min , R-min > + + max : ∀ {⊥} → Maximum L ⊥ → Maximum R ⊥ → Maximum (L ∩ R) ⊥ + max L-max R-max = < L-max , R-max > + +module _ (≈ : REL A B ℓ₁) {L : REL A B ℓ₂} {R : REL A B ℓ₃} where + + implies : (≈ ⇒ L) → (≈ ⇒ R) → ≈ ⇒ (L ∩ R) + implies ≈⇒L ≈⇒R = < ≈⇒L , ≈⇒R > + +module _ (≈ : REL A B ℓ₁) (L : REL A B ℓ₂) (R : REL A B ℓ₃) where + + irreflexive : Irreflexive ≈ L ⊎ Irreflexive ≈ R → Irreflexive ≈ (L ∩ R) + irreflexive irrefl x≈y (Lxy , Rxy) = [ (λ x → x x≈y Lxy) , (λ x → x x≈y Rxy) ] irrefl + +module _ (≈ : Rel A ℓ₁) (L : Rel A ℓ₂) (R : Rel A ℓ₃) where + + respectsˡ : L Respectsˡ ≈ → R Respectsˡ ≈ → (L ∩ R) Respectsˡ ≈ + respectsˡ L-resp R-resp x≈y = map (L-resp x≈y) (R-resp x≈y) + + respectsʳ : L Respectsʳ ≈ → R Respectsʳ ≈ → (L ∩ R) Respectsʳ ≈ + respectsʳ L-resp R-resp x≈y = map (L-resp x≈y) (R-resp x≈y) + + respects₂ : L Respects₂ ≈ → R Respects₂ ≈ → (L ∩ R) Respects₂ ≈ + respects₂ (Lʳ , Lˡ) (Rʳ , Rˡ) = respectsʳ Lʳ Rʳ , respectsˡ Lˡ Rˡ + + antisymmetric : Antisymmetric ≈ L ⊎ Antisymmetric ≈ R → Antisymmetric ≈ (L ∩ R) + antisymmetric (inj₁ L-antisym) (Lxy , _) (Lyx , _) = L-antisym Lxy Lyx + antisymmetric (inj₂ R-antisym) (_ , Rxy) (_ , Ryx) = R-antisym Rxy Ryx + +module _ {L : REL A B ℓ₁} {R : REL A B ℓ₂} where + + decidable : Decidable L → Decidable R → Decidable (L ∩ R) + decidable L? R? x y = L? x y ×-dec R? x y + +------------------------------------------------------------------------ +-- Structures + +isEquivalence : IsEquivalence L → IsEquivalence R → IsEquivalence (L ∩ R) +isEquivalence {L = L} {R = R} eqₗ eqᵣ = record + { refl = reflexive L R L.refl R.refl + ; sym = symmetric L R L.sym R.sym + ; trans = transitive L R L.trans R.trans + } where module L = IsEquivalence eqₗ; module R = IsEquivalence eqᵣ + +isDecEquivalence : IsDecEquivalence L → IsDecEquivalence R → IsDecEquivalence (L ∩ R) +isDecEquivalence eqₗ eqᵣ = record + { isEquivalence = isEquivalence L.isEquivalence R.isEquivalence + ; _≟_ = decidable L._≟_ R._≟_ + } where module L = IsDecEquivalence eqₗ; module R = IsDecEquivalence eqᵣ + +isPreorder : IsPreorder ≈ L → IsPreorder ≈ R → IsPreorder ≈ (L ∩ R) +isPreorder {≈ = ≈} {L = L} {R = R} Oₗ Oᵣ = record + { isEquivalence = Oₗ.isEquivalence + ; reflexive = implies ≈ Oₗ.reflexive Oᵣ.reflexive + ; trans = transitive L R Oₗ.trans Oᵣ.trans + } + where module Oₗ = IsPreorder Oₗ; module Oᵣ = IsPreorder Oᵣ + +isPartialOrderˡ : IsPartialOrder ≈ L → IsPreorder ≈ R → IsPartialOrder ≈ (L ∩ R) +isPartialOrderˡ {≈ = ≈} {L = L} {R = R} Oₗ Oᵣ = record + { isPreorder = isPreorder Oₗ.isPreorder Oᵣ + ; antisym = antisymmetric ≈ L R (inj₁ Oₗ.antisym) + } where module Oₗ = IsPartialOrder Oₗ; module Oᵣ = IsPreorder Oᵣ -isStrictPartialOrderʳ : Transitive L → L Respects₂ ≈ → - IsStrictPartialOrder ≈ R → - IsStrictPartialOrder ≈ (L ∩ R) -isStrictPartialOrderʳ {L = L} {≈ = ≈} {R = R} transₗ respₗ Oᵣ = record - { isEquivalence = Oᵣ.isEquivalence - ; irrefl = irreflexive ≈ L R (inj₂ Oᵣ.irrefl) - ; trans = transitive L R transₗ Oᵣ.trans - ; <-resp-≈ = respects₂ ≈ L R respₗ Oᵣ.<-resp-≈ - } where module Oᵣ = IsStrictPartialOrder Oᵣ +isPartialOrderʳ : IsPreorder ≈ L → IsPartialOrder ≈ R → IsPartialOrder ≈ (L ∩ R) +isPartialOrderʳ {≈ = ≈} {L = L} {R = R} Oₗ Oᵣ = record + { isPreorder = isPreorder Oₗ Oᵣ.isPreorder + ; antisym = antisymmetric ≈ L R (inj₂ Oᵣ.antisym) + } where module Oₗ = IsPreorder Oₗ; module Oᵣ = IsPartialOrder Oᵣ + +isStrictPartialOrderˡ : IsStrictPartialOrder ≈ L → + Transitive R → R Respects₂ ≈ → + IsStrictPartialOrder ≈ (L ∩ R) +isStrictPartialOrderˡ {≈ = ≈} {L = L} {R = R} Oₗ transᵣ respᵣ = record + { isEquivalence = Oₗ.isEquivalence + ; irrefl = irreflexive ≈ L R (inj₁ Oₗ.irrefl) + ; trans = transitive L R Oₗ.trans transᵣ + ; <-resp-≈ = respects₂ ≈ L R Oₗ.<-resp-≈ respᵣ + } where module Oₗ = IsStrictPartialOrder Oₗ + +isStrictPartialOrderʳ : Transitive L → L Respects₂ ≈ → + IsStrictPartialOrder ≈ R → + IsStrictPartialOrder ≈ (L ∩ R) +isStrictPartialOrderʳ {L = L} {≈ = ≈} {R = R} transₗ respₗ Oᵣ = record + { isEquivalence = Oᵣ.isEquivalence + ; irrefl = irreflexive ≈ L R (inj₂ Oᵣ.irrefl) + ; trans = transitive L R transₗ Oᵣ.trans + ; <-resp-≈ = respects₂ ≈ L R respₗ Oᵣ.<-resp-≈ + } where module Oᵣ = IsStrictPartialOrder Oᵣ \ No newline at end of file diff --git a/Relation.Binary.Construct.NaturalOrder.Left.html b/Relation.Binary.Construct.NaturalOrder.Left.html index 41628d6a..c8e6f24a 100644 --- a/Relation.Binary.Construct.NaturalOrder.Left.html +++ b/Relation.Binary.Construct.NaturalOrder.Left.html @@ -9,179 +9,185 @@ {-# OPTIONS --cubical-compatible --safe #-} open import Algebra.Core -open import Data.Product using (_,_; _×_) -open import Data.Sum.Base using (inj₁; inj₂) -open import Relation.Binary -open import Relation.Nullary.Negation using (¬_) -import Relation.Binary.Reasoning.Setoid as EqReasoning -open import Relation.Binary.Lattice using (Infimum) - -module Relation.Binary.Construct.NaturalOrder.Left - {a ℓ} {A : Set a} (_≈_ : Rel A ℓ) (_∙_ : Op₂ A) where - -open import Algebra.Definitions _≈_ -open import Algebra.Structures _≈_ -open import Algebra.Lattice.Structures _≈_ - ------------------------------------------------------------------------- --- Definition - -infix 4 _≤_ - -_≤_ : Rel A ℓ -x ≤ y = x ≈ (x ∙ y) - ------------------------------------------------------------------------- --- Relational properties - -reflexive : IsMagma _∙_ → Idempotent _∙_ → _≈_ ⇒ _≤_ -reflexive magma idem {x} {y} x≈y = begin - x ≈⟨ sym (idem x) ⟩ - x ∙ x ≈⟨ ∙-cong refl x≈y ⟩ - x ∙ y ∎ - where open IsMagma magma; open EqReasoning setoid - -refl : Symmetric _≈_ → Idempotent _∙_ → Reflexive _≤_ -refl sym idem {x} = sym (idem x) - -antisym : IsEquivalence _≈_ → Commutative _∙_ → Antisymmetric _≈_ _≤_ -antisym isEq comm {x} {y} x≤y y≤x = begin - x ≈⟨ x≤y ⟩ - x ∙ y ≈⟨ comm x y ⟩ - y ∙ x ≈⟨ sym y≤x ⟩ - y ∎ - where open IsEquivalence isEq; open EqReasoning (record { isEquivalence = isEq }) - -total : Symmetric _≈_ → Transitive _≈_ → Selective _∙_ → Commutative _∙_ → Total _≤_ -total sym trans sel comm x y with sel x y -... | inj₁ x∙y≈x = inj₁ (sym x∙y≈x) -... | inj₂ x∙y≈y = inj₂ (sym (trans (comm y x) x∙y≈y)) - -trans : IsSemigroup _∙_ → Transitive _≤_ -trans semi {x} {y} {z} x≤y y≤z = begin - x ≈⟨ x≤y ⟩ - x ∙ y ≈⟨ ∙-cong S.refl y≤z ⟩ - x ∙ (y ∙ z) ≈⟨ sym (assoc x y z) ⟩ - (x ∙ y) ∙ z ≈⟨ ∙-cong (sym x≤y) S.refl ⟩ - x ∙ z ∎ - where open module S = IsSemigroup semi; open EqReasoning S.setoid - -respʳ : IsMagma _∙_ → _≤_ Respectsʳ _≈_ -respʳ magma {x} {y} {z} y≈z x≤y = begin - x ≈⟨ x≤y ⟩ - x ∙ y ≈⟨ ∙-cong M.refl y≈z ⟩ - x ∙ z ∎ - where open module M = IsMagma magma; open EqReasoning M.setoid - -respˡ : IsMagma _∙_ → _≤_ Respectsˡ _≈_ -respˡ magma {x} {y} {z} y≈z y≤x = begin - z ≈⟨ sym y≈z ⟩ - y ≈⟨ y≤x ⟩ - y ∙ x ≈⟨ ∙-cong y≈z M.refl ⟩ - z ∙ x ∎ - where open module M = IsMagma magma; open EqReasoning M.setoid - -resp₂ : IsMagma _∙_ → _≤_ Respects₂ _≈_ -resp₂ magma = respʳ magma , respˡ magma - -dec : Decidable _≈_ → Decidable _≤_ -dec _≟_ x y = x ≟ (x ∙ y) - -module _ (semi : IsSemilattice _∙_) where - - private open module S = IsSemilattice semi - open EqReasoning setoid - - x∙y≤x : ∀ x y → (x ∙ y) ≤ x - x∙y≤x x y = begin - x ∙ y ≈⟨ ∧-cong (sym (idem x)) S.refl ⟩ - (x ∙ x) ∙ y ≈⟨ assoc x x y ⟩ - x ∙ (x ∙ y) ≈⟨ comm x (x ∙ y) ⟩ - (x ∙ y) ∙ x ∎ - - x∙y≤y : ∀ x y → (x ∙ y) ≤ y - x∙y≤y x y = begin - x ∙ y ≈⟨ ∧-cong S.refl (sym (idem y)) ⟩ - x ∙ (y ∙ y) ≈⟨ sym (assoc x y y) ⟩ - (x ∙ y) ∙ y ∎ - - ∙-presʳ-≤ : ∀ {x y} z → z ≤ x → z ≤ y → z ≤ (x ∙ y) - ∙-presʳ-≤ {x} {y} z z≤x z≤y = begin - z ≈⟨ z≤y ⟩ - z ∙ y ≈⟨ ∧-cong z≤x S.refl ⟩ - (z ∙ x) ∙ y ≈⟨ assoc z x y ⟩ - z ∙ (x ∙ y) ∎ - - infimum : Infimum _≤_ _∙_ - infimum x y = x∙y≤x x y , x∙y≤y x y , ∙-presʳ-≤ - ------------------------------------------------------------------------- --- Structures - -isPreorder : IsBand _∙_ → IsPreorder _≈_ _≤_ -isPreorder band = record - { isEquivalence = isEquivalence - ; reflexive = reflexive isMagma idem - ; trans = trans isSemigroup - } - where open IsBand band hiding (reflexive; trans) - -isPartialOrder : IsSemilattice _∙_ → IsPartialOrder _≈_ _≤_ -isPartialOrder semilattice = record - { isPreorder = isPreorder isBand - ; antisym = antisym isEquivalence comm - } - where open IsSemilattice semilattice - -isDecPartialOrder : IsSemilattice _∙_ → Decidable _≈_ → - IsDecPartialOrder _≈_ _≤_ -isDecPartialOrder semilattice _≟_ = record - { isPartialOrder = isPartialOrder semilattice - ; _≟_ = _≟_ - ; _≤?_ = dec _≟_ - } - -isTotalOrder : IsSemilattice _∙_ → Selective _∙_ → IsTotalOrder _≈_ _≤_ -isTotalOrder latt sel = record - { isPartialOrder = isPartialOrder latt - ; total = total sym S.trans sel comm - } - where open module S = IsSemilattice latt - -isDecTotalOrder : IsSemilattice _∙_ → Selective _∙_ → - Decidable _≈_ → IsDecTotalOrder _≈_ _≤_ -isDecTotalOrder latt sel _≟_ = record - { isTotalOrder = isTotalOrder latt sel - ; _≟_ = _≟_ - ; _≤?_ = dec _≟_ - } - ------------------------------------------------------------------------- --- Bundles - -preorder : IsBand _∙_ → Preorder a ℓ ℓ -preorder band = record - { isPreorder = isPreorder band - } - -poset : IsSemilattice _∙_ → Poset a ℓ ℓ -poset latt = record - { isPartialOrder = isPartialOrder latt - } - -decPoset : IsSemilattice _∙_ → Decidable _≈_ → DecPoset a ℓ ℓ -decPoset latt dec = record - { isDecPartialOrder = isDecPartialOrder latt dec - } - -totalOrder : IsSemilattice _∙_ → Selective _∙_ → TotalOrder a ℓ ℓ -totalOrder latt sel = record - { isTotalOrder = isTotalOrder latt sel - } - -decTotalOrder : IsSemilattice _∙_ → Selective _∙_ → - Decidable _≈_ → DecTotalOrder a ℓ ℓ -decTotalOrder latt sel dec = record - { isDecTotalOrder = isDecTotalOrder latt sel dec - } +open import Data.Product.Base using (_,_; _×_) +open import Data.Sum.Base using (inj₁; inj₂) +open import Relation.Binary.Core using (Rel; _⇒_) +open import Relation.Binary.Bundles + using (Preorder; Poset; DecPoset; TotalOrder; DecTotalOrder) +open import Relation.Binary.Structures + using (IsEquivalence; IsPreorder; IsPartialOrder; IsDecPartialOrder; IsTotalOrder; IsDecTotalOrder) +open import Relation.Binary.Definitions + using (Symmetric; Transitive; Reflexive; Antisymmetric; Total; _Respectsʳ_; _Respectsˡ_; _Respects₂_; Decidable) +open import Relation.Nullary.Negation using (¬_) +import Relation.Binary.Reasoning.Setoid as EqReasoning +open import Relation.Binary.Lattice using (Infimum) + +module Relation.Binary.Construct.NaturalOrder.Left + {a ℓ} {A : Set a} (_≈_ : Rel A ℓ) (_∙_ : Op₂ A) where + +open import Algebra.Definitions _≈_ +open import Algebra.Structures _≈_ +open import Algebra.Lattice.Structures _≈_ + +------------------------------------------------------------------------ +-- Definition + +infix 4 _≤_ + +_≤_ : Rel A ℓ +x ≤ y = x ≈ (x ∙ y) + +------------------------------------------------------------------------ +-- Relational properties + +reflexive : IsMagma _∙_ → Idempotent _∙_ → _≈_ ⇒ _≤_ +reflexive magma idem {x} {y} x≈y = begin + x ≈⟨ sym (idem x) ⟩ + x ∙ x ≈⟨ ∙-cong refl x≈y ⟩ + x ∙ y ∎ + where open IsMagma magma; open EqReasoning setoid + +refl : Symmetric _≈_ → Idempotent _∙_ → Reflexive _≤_ +refl sym idem {x} = sym (idem x) + +antisym : IsEquivalence _≈_ → Commutative _∙_ → Antisymmetric _≈_ _≤_ +antisym isEq comm {x} {y} x≤y y≤x = begin + x ≈⟨ x≤y ⟩ + x ∙ y ≈⟨ comm x y ⟩ + y ∙ x ≈⟨ sym y≤x ⟩ + y ∎ + where open IsEquivalence isEq; open EqReasoning (record { isEquivalence = isEq }) + +total : Symmetric _≈_ → Transitive _≈_ → Selective _∙_ → Commutative _∙_ → Total _≤_ +total sym trans sel comm x y with sel x y +... | inj₁ x∙y≈x = inj₁ (sym x∙y≈x) +... | inj₂ x∙y≈y = inj₂ (sym (trans (comm y x) x∙y≈y)) + +trans : IsSemigroup _∙_ → Transitive _≤_ +trans semi {x} {y} {z} x≤y y≤z = begin + x ≈⟨ x≤y ⟩ + x ∙ y ≈⟨ ∙-cong S.refl y≤z ⟩ + x ∙ (y ∙ z) ≈⟨ sym (assoc x y z) ⟩ + (x ∙ y) ∙ z ≈⟨ ∙-cong (sym x≤y) S.refl ⟩ + x ∙ z ∎ + where open module S = IsSemigroup semi; open EqReasoning S.setoid + +respʳ : IsMagma _∙_ → _≤_ Respectsʳ _≈_ +respʳ magma {x} {y} {z} y≈z x≤y = begin + x ≈⟨ x≤y ⟩ + x ∙ y ≈⟨ ∙-cong M.refl y≈z ⟩ + x ∙ z ∎ + where open module M = IsMagma magma; open EqReasoning M.setoid + +respˡ : IsMagma _∙_ → _≤_ Respectsˡ _≈_ +respˡ magma {x} {y} {z} y≈z y≤x = begin + z ≈⟨ sym y≈z ⟩ + y ≈⟨ y≤x ⟩ + y ∙ x ≈⟨ ∙-cong y≈z M.refl ⟩ + z ∙ x ∎ + where open module M = IsMagma magma; open EqReasoning M.setoid + +resp₂ : IsMagma _∙_ → _≤_ Respects₂ _≈_ +resp₂ magma = respʳ magma , respˡ magma + +dec : Decidable _≈_ → Decidable _≤_ +dec _≟_ x y = x ≟ (x ∙ y) + +module _ (semi : IsSemilattice _∙_) where + + private open module S = IsSemilattice semi + open EqReasoning setoid + + x∙y≤x : ∀ x y → (x ∙ y) ≤ x + x∙y≤x x y = begin + x ∙ y ≈⟨ ∙-cong (sym (idem x)) S.refl ⟩ + (x ∙ x) ∙ y ≈⟨ assoc x x y ⟩ + x ∙ (x ∙ y) ≈⟨ comm x (x ∙ y) ⟩ + (x ∙ y) ∙ x ∎ + + x∙y≤y : ∀ x y → (x ∙ y) ≤ y + x∙y≤y x y = begin + x ∙ y ≈⟨ ∙-cong S.refl (sym (idem y)) ⟩ + x ∙ (y ∙ y) ≈⟨ sym (assoc x y y) ⟩ + (x ∙ y) ∙ y ∎ + + ∙-presʳ-≤ : ∀ {x y} z → z ≤ x → z ≤ y → z ≤ (x ∙ y) + ∙-presʳ-≤ {x} {y} z z≤x z≤y = begin + z ≈⟨ z≤y ⟩ + z ∙ y ≈⟨ ∙-cong z≤x S.refl ⟩ + (z ∙ x) ∙ y ≈⟨ assoc z x y ⟩ + z ∙ (x ∙ y) ∎ + + infimum : Infimum _≤_ _∙_ + infimum x y = x∙y≤x x y , x∙y≤y x y , ∙-presʳ-≤ + +------------------------------------------------------------------------ +-- Structures + +isPreorder : IsBand _∙_ → IsPreorder _≈_ _≤_ +isPreorder band = record + { isEquivalence = isEquivalence + ; reflexive = reflexive isMagma idem + ; trans = trans isSemigroup + } + where open IsBand band hiding (reflexive; trans) + +isPartialOrder : IsSemilattice _∙_ → IsPartialOrder _≈_ _≤_ +isPartialOrder semilattice = record + { isPreorder = isPreorder isBand + ; antisym = antisym isEquivalence comm + } + where open IsSemilattice semilattice + +isDecPartialOrder : IsSemilattice _∙_ → Decidable _≈_ → + IsDecPartialOrder _≈_ _≤_ +isDecPartialOrder semilattice _≟_ = record + { isPartialOrder = isPartialOrder semilattice + ; _≟_ = _≟_ + ; _≤?_ = dec _≟_ + } + +isTotalOrder : IsSemilattice _∙_ → Selective _∙_ → IsTotalOrder _≈_ _≤_ +isTotalOrder latt sel = record + { isPartialOrder = isPartialOrder latt + ; total = total sym S.trans sel comm + } + where open module S = IsSemilattice latt + +isDecTotalOrder : IsSemilattice _∙_ → Selective _∙_ → + Decidable _≈_ → IsDecTotalOrder _≈_ _≤_ +isDecTotalOrder latt sel _≟_ = record + { isTotalOrder = isTotalOrder latt sel + ; _≟_ = _≟_ + ; _≤?_ = dec _≟_ + } + +------------------------------------------------------------------------ +-- Bundles + +preorder : IsBand _∙_ → Preorder a ℓ ℓ +preorder band = record + { isPreorder = isPreorder band + } + +poset : IsSemilattice _∙_ → Poset a ℓ ℓ +poset latt = record + { isPartialOrder = isPartialOrder latt + } + +decPoset : IsSemilattice _∙_ → Decidable _≈_ → DecPoset a ℓ ℓ +decPoset latt dec = record + { isDecPartialOrder = isDecPartialOrder latt dec + } + +totalOrder : IsSemilattice _∙_ → Selective _∙_ → TotalOrder a ℓ ℓ +totalOrder latt sel = record + { isTotalOrder = isTotalOrder latt sel + } + +decTotalOrder : IsSemilattice _∙_ → Selective _∙_ → + Decidable _≈_ → DecTotalOrder a ℓ ℓ +decTotalOrder latt sel dec = record + { isDecTotalOrder = isDecTotalOrder latt sel dec + } \ No newline at end of file diff --git a/Relation.Binary.Construct.NonStrictToStrict.html b/Relation.Binary.Construct.NonStrictToStrict.html index 64270884..9e00144a 100644 --- a/Relation.Binary.Construct.NonStrictToStrict.html +++ b/Relation.Binary.Construct.NonStrictToStrict.html @@ -7,141 +7,144 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary - -module Relation.Binary.Construct.NonStrictToStrict - {a ℓ₁ ℓ₂} {A : Set a} (_≈_ : Rel A ℓ₁) (_≤_ : Rel A ℓ₂) where - -open import Data.Product.Base using (_×_; _,_; proj₁; proj₂) -open import Data.Sum.Base using (inj₁; inj₂) -open import Function.Base using (_∘_; flip) -open import Relation.Nullary using (¬_; yes; no) -open import Relation.Nullary.Negation using (contradiction) -open import Relation.Nullary.Decidable using (¬?; _×-dec_) - -private - _≉_ : Rel A ℓ₁ - x ≉ y = ¬ (x ≈ y) - ------------------------------------------------------------------------- --- _≤_ can be turned into _<_ as follows: - -infix 4 _<_ - -_<_ : Rel A _ -x < y = x ≤ y × x ≉ y - ------------------------------------------------------------------------- --- Relationship between relations - -<⇒≤ : _<_ ⇒ _≤_ -<⇒≤ = proj₁ - -<⇒≉ : ∀ {x y} → x < y → x ≉ y -<⇒≉ = proj₂ - -≤∧≉⇒< : ∀ {x y} → x ≤ y → x ≉ y → x < y -≤∧≉⇒< = _,_ - -<⇒≱ : Antisymmetric _≈_ _≤_ → ∀ {x y} → x < y → ¬ (y ≤ x) -<⇒≱ antisym (x≤y , x≉y) y≤x = x≉y (antisym x≤y y≤x) - -≤⇒≯ : Antisymmetric _≈_ _≤_ → ∀ {x y} → x ≤ y → ¬ (y < x) -≤⇒≯ antisym x≤y y<x = <⇒≱ antisym y<x x≤y - -≰⇒> : Symmetric _≈_ → (_≈_ ⇒ _≤_) → Total _≤_ → - ∀ {x y} → ¬ (x ≤ y) → y < x -≰⇒> sym refl total {x} {y} x≰y with total x y -... | inj₁ x≤y = contradiction x≤y x≰y -... | inj₂ y≤x = y≤x , x≰y ∘ refl ∘ sym - -≮⇒≥ : Symmetric _≈_ → Decidable _≈_ → _≈_ ⇒ _≤_ → Total _≤_ → - ∀ {x y} → ¬ (x < y) → y ≤ x -≮⇒≥ sym _≟_ ≤-refl _≤?_ {x} {y} x≮y with x ≟ y | y ≤? x -... | yes x≈y | _ = ≤-refl (sym x≈y) -... | _ | inj₁ y≤x = y≤x -... | no x≉y | inj₂ x≤y = contradiction (x≤y , x≉y) x≮y - ------------------------------------------------------------------------- --- Relational properties - -<-irrefl : Irreflexive _≈_ _<_ -<-irrefl x≈y (_ , x≉y) = x≉y x≈y - -<-trans : IsPartialOrder _≈_ _≤_ → Transitive _<_ -<-trans po (x≤y , x≉y) (y≤z , y≉z) = - (trans x≤y y≤z , x≉y ∘ antisym x≤y ∘ trans y≤z ∘ reflexive ∘ Eq.sym) - where open IsPartialOrder po - -<-≤-trans : Symmetric _≈_ → Transitive _≤_ → Antisymmetric _≈_ _≤_ → - _≤_ Respectsʳ _≈_ → Trans _<_ _≤_ _<_ -<-≤-trans sym trans antisym respʳ (x≤y , x≉y) y≤z = - trans x≤y y≤z , (λ x≈z → x≉y (antisym x≤y (respʳ (sym x≈z) y≤z))) - -≤-<-trans : Transitive _≤_ → Antisymmetric _≈_ _≤_ → - _≤_ Respectsˡ _≈_ → Trans _≤_ _<_ _<_ -≤-<-trans trans antisym respʳ x≤y (y≤z , y≉z) = - trans x≤y y≤z , (λ x≈z → y≉z (antisym y≤z (respʳ x≈z x≤y))) - -<-asym : Antisymmetric _≈_ _≤_ → Asymmetric _<_ -<-asym antisym (x≤y , x≉y) (y≤x , _) = x≉y (antisym x≤y y≤x) - -<-respˡ-≈ : Transitive _≈_ → _≤_ Respectsˡ _≈_ → _<_ Respectsˡ _≈_ -<-respˡ-≈ trans respˡ y≈z (y≤x , y≉x) = - respˡ y≈z y≤x , y≉x ∘ trans y≈z - -<-respʳ-≈ : Symmetric _≈_ → Transitive _≈_ → - _≤_ Respectsʳ _≈_ → _<_ Respectsʳ _≈_ -<-respʳ-≈ sym trans respʳ y≈z (x≤y , x≉y) = - (respʳ y≈z x≤y) , λ x≈z → x≉y (trans x≈z (sym y≈z)) - -<-resp-≈ : IsEquivalence _≈_ → _≤_ Respects₂ _≈_ → _<_ Respects₂ _≈_ -<-resp-≈ eq (respʳ , respˡ) = - <-respʳ-≈ sym trans respʳ , <-respˡ-≈ trans respˡ - where open IsEquivalence eq - -<-trichotomous : Symmetric _≈_ → Decidable _≈_ → - Antisymmetric _≈_ _≤_ → Total _≤_ → - Trichotomous _≈_ _<_ -<-trichotomous ≈-sym _≟_ antisym total x y with x ≟ y -... | yes x≈y = tri≈ (<-irrefl x≈y) x≈y (<-irrefl (≈-sym x≈y)) -... | no x≉y with total x y -... | inj₁ x≤y = tri< (x≤y , x≉y) x≉y (x≉y ∘ antisym x≤y ∘ proj₁) -... | inj₂ y≤x = tri> (x≉y ∘ flip antisym y≤x ∘ proj₁) x≉y (y≤x , x≉y ∘ ≈-sym) - -<-decidable : Decidable _≈_ → Decidable _≤_ → Decidable _<_ -<-decidable _≟_ _≤?_ x y = x ≤? y ×-dec ¬? (x ≟ y) - ------------------------------------------------------------------------- --- Structures - -<-isStrictPartialOrder : IsPartialOrder _≈_ _≤_ → - IsStrictPartialOrder _≈_ _<_ -<-isStrictPartialOrder po = record - { isEquivalence = isEquivalence - ; irrefl = <-irrefl - ; trans = <-trans po - ; <-resp-≈ = <-resp-≈ isEquivalence ≤-resp-≈ - } where open IsPartialOrder po - -<-isDecStrictPartialOrder : IsDecPartialOrder _≈_ _≤_ → - IsDecStrictPartialOrder _≈_ _<_ -<-isDecStrictPartialOrder dpo = record - { isStrictPartialOrder = <-isStrictPartialOrder isPartialOrder - ; _≟_ = _≟_ - ; _<?_ = <-decidable _≟_ _≤?_ - } where open IsDecPartialOrder dpo - -<-isStrictTotalOrder₁ : Decidable _≈_ → IsTotalOrder _≈_ _≤_ → - IsStrictTotalOrder _≈_ _<_ -<-isStrictTotalOrder₁ ≟ tot = record - { isEquivalence = isEquivalence - ; trans = <-trans isPartialOrder - ; compare = <-trichotomous Eq.sym ≟ antisym total - } where open IsTotalOrder tot - -<-isStrictTotalOrder₂ : IsDecTotalOrder _≈_ _≤_ → - IsStrictTotalOrder _≈_ _<_ -<-isStrictTotalOrder₂ dtot = <-isStrictTotalOrder₁ _≟_ isTotalOrder - where open IsDecTotalOrder dtot +open import Relation.Binary.Core using (Rel; _⇒_) +open import Relation.Binary.Structures + using (IsPartialOrder; IsEquivalence; IsStrictPartialOrder; IsDecPartialOrder; IsDecStrictPartialOrder; IsTotalOrder; IsStrictTotalOrder; IsDecTotalOrder) +open import Relation.Binary.Definitions + using (Trichotomous; Antisymmetric; Symmetric; Total; Decidable; Irreflexive; Transitive; _Respectsʳ_; _Respectsˡ_; _Respects₂_; Trans; Asymmetric; tri≈; tri<; tri>) + +module Relation.Binary.Construct.NonStrictToStrict + {a ℓ₁ ℓ₂} {A : Set a} (_≈_ : Rel A ℓ₁) (_≤_ : Rel A ℓ₂) where + +open import Data.Product.Base using (_×_; _,_; proj₁; proj₂) +open import Data.Sum.Base using (inj₁; inj₂) +open import Function.Base using (_∘_; flip) +open import Relation.Nullary using (¬_; yes; no) +open import Relation.Nullary.Negation using (contradiction) +open import Relation.Nullary.Decidable using (¬?; _×-dec_) + +private + _≉_ : Rel A ℓ₁ + x ≉ y = ¬ (x ≈ y) + +------------------------------------------------------------------------ +-- _≤_ can be turned into _<_ as follows: + +infix 4 _<_ + +_<_ : Rel A _ +x < y = x ≤ y × x ≉ y + +------------------------------------------------------------------------ +-- Relationship between relations + +<⇒≤ : _<_ ⇒ _≤_ +<⇒≤ = proj₁ + +<⇒≉ : ∀ {x y} → x < y → x ≉ y +<⇒≉ = proj₂ + +≤∧≉⇒< : ∀ {x y} → x ≤ y → x ≉ y → x < y +≤∧≉⇒< = _,_ + +<⇒≱ : Antisymmetric _≈_ _≤_ → ∀ {x y} → x < y → ¬ (y ≤ x) +<⇒≱ antisym (x≤y , x≉y) y≤x = x≉y (antisym x≤y y≤x) + +≤⇒≯ : Antisymmetric _≈_ _≤_ → ∀ {x y} → x ≤ y → ¬ (y < x) +≤⇒≯ antisym x≤y y<x = <⇒≱ antisym y<x x≤y + +≰⇒> : Symmetric _≈_ → (_≈_ ⇒ _≤_) → Total _≤_ → + ∀ {x y} → ¬ (x ≤ y) → y < x +≰⇒> sym refl total {x} {y} x≰y with total x y +... | inj₁ x≤y = contradiction x≤y x≰y +... | inj₂ y≤x = y≤x , x≰y ∘ refl ∘ sym + +≮⇒≥ : Symmetric _≈_ → Decidable _≈_ → _≈_ ⇒ _≤_ → Total _≤_ → + ∀ {x y} → ¬ (x < y) → y ≤ x +≮⇒≥ sym _≟_ ≤-refl _≤?_ {x} {y} x≮y with x ≟ y | y ≤? x +... | yes x≈y | _ = ≤-refl (sym x≈y) +... | _ | inj₁ y≤x = y≤x +... | no x≉y | inj₂ x≤y = contradiction (x≤y , x≉y) x≮y + +------------------------------------------------------------------------ +-- Relational properties + +<-irrefl : Irreflexive _≈_ _<_ +<-irrefl x≈y (_ , x≉y) = x≉y x≈y + +<-trans : IsPartialOrder _≈_ _≤_ → Transitive _<_ +<-trans po (x≤y , x≉y) (y≤z , y≉z) = + (trans x≤y y≤z , x≉y ∘ antisym x≤y ∘ trans y≤z ∘ reflexive ∘ Eq.sym) + where open IsPartialOrder po + +<-≤-trans : Symmetric _≈_ → Transitive _≤_ → Antisymmetric _≈_ _≤_ → + _≤_ Respectsʳ _≈_ → Trans _<_ _≤_ _<_ +<-≤-trans sym trans antisym respʳ (x≤y , x≉y) y≤z = + trans x≤y y≤z , (λ x≈z → x≉y (antisym x≤y (respʳ (sym x≈z) y≤z))) + +≤-<-trans : Transitive _≤_ → Antisymmetric _≈_ _≤_ → + _≤_ Respectsˡ _≈_ → Trans _≤_ _<_ _<_ +≤-<-trans trans antisym respʳ x≤y (y≤z , y≉z) = + trans x≤y y≤z , (λ x≈z → y≉z (antisym y≤z (respʳ x≈z x≤y))) + +<-asym : Antisymmetric _≈_ _≤_ → Asymmetric _<_ +<-asym antisym (x≤y , x≉y) (y≤x , _) = x≉y (antisym x≤y y≤x) + +<-respˡ-≈ : Transitive _≈_ → _≤_ Respectsˡ _≈_ → _<_ Respectsˡ _≈_ +<-respˡ-≈ trans respˡ y≈z (y≤x , y≉x) = + respˡ y≈z y≤x , y≉x ∘ trans y≈z + +<-respʳ-≈ : Symmetric _≈_ → Transitive _≈_ → + _≤_ Respectsʳ _≈_ → _<_ Respectsʳ _≈_ +<-respʳ-≈ sym trans respʳ y≈z (x≤y , x≉y) = + (respʳ y≈z x≤y) , λ x≈z → x≉y (trans x≈z (sym y≈z)) + +<-resp-≈ : IsEquivalence _≈_ → _≤_ Respects₂ _≈_ → _<_ Respects₂ _≈_ +<-resp-≈ eq (respʳ , respˡ) = + <-respʳ-≈ sym trans respʳ , <-respˡ-≈ trans respˡ + where open IsEquivalence eq + +<-trichotomous : Symmetric _≈_ → Decidable _≈_ → + Antisymmetric _≈_ _≤_ → Total _≤_ → + Trichotomous _≈_ _<_ +<-trichotomous ≈-sym _≟_ antisym total x y with x ≟ y +... | yes x≈y = tri≈ (<-irrefl x≈y) x≈y (<-irrefl (≈-sym x≈y)) +... | no x≉y with total x y +... | inj₁ x≤y = tri< (x≤y , x≉y) x≉y (x≉y ∘ antisym x≤y ∘ proj₁) +... | inj₂ y≤x = tri> (x≉y ∘ flip antisym y≤x ∘ proj₁) x≉y (y≤x , x≉y ∘ ≈-sym) + +<-decidable : Decidable _≈_ → Decidable _≤_ → Decidable _<_ +<-decidable _≟_ _≤?_ x y = x ≤? y ×-dec ¬? (x ≟ y) + +------------------------------------------------------------------------ +-- Structures + +<-isStrictPartialOrder : IsPartialOrder _≈_ _≤_ → + IsStrictPartialOrder _≈_ _<_ +<-isStrictPartialOrder po = record + { isEquivalence = isEquivalence + ; irrefl = <-irrefl + ; trans = <-trans po + ; <-resp-≈ = <-resp-≈ isEquivalence ≤-resp-≈ + } where open IsPartialOrder po + +<-isDecStrictPartialOrder : IsDecPartialOrder _≈_ _≤_ → + IsDecStrictPartialOrder _≈_ _<_ +<-isDecStrictPartialOrder dpo = record + { isStrictPartialOrder = <-isStrictPartialOrder isPartialOrder + ; _≟_ = _≟_ + ; _<?_ = <-decidable _≟_ _≤?_ + } where open IsDecPartialOrder dpo + +<-isStrictTotalOrder₁ : Decidable _≈_ → IsTotalOrder _≈_ _≤_ → + IsStrictTotalOrder _≈_ _<_ +<-isStrictTotalOrder₁ ≟ tot = record + { isStrictPartialOrder = <-isStrictPartialOrder isPartialOrder + ; compare = <-trichotomous Eq.sym ≟ antisym total + } where open IsTotalOrder tot + +<-isStrictTotalOrder₂ : IsDecTotalOrder _≈_ _≤_ → + IsStrictTotalOrder _≈_ _<_ +<-isStrictTotalOrder₂ dtot = <-isStrictTotalOrder₁ _≟_ isTotalOrder + where open IsDecTotalOrder dtot \ No newline at end of file diff --git a/Relation.Binary.Construct.On.html b/Relation.Binary.Construct.On.html deleted file mode 100644 index bbd9cae4..00000000 --- a/Relation.Binary.Construct.On.html +++ /dev/null @@ -1,221 +0,0 @@ - -Relation.Binary.Construct.On
------------------------------------------------------------------------
--- The Agda standard library
---
--- Many properties which hold for `_∼_` also hold for `_∼_ on f`
-------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-module Relation.Binary.Construct.On where
-
-open import Data.Product
-open import Function.Base using (_on_; _∘_)
-open import Induction.WellFounded using (WellFounded; Acc; acc)
-open import Level using (Level)
-open import Relation.Binary
-
-private
-  variable
-    a b p ℓ ℓ₁ ℓ₂ : Level
-    A : Set a
-    B : Set b
-
-------------------------------------------------------------------------
--- Definitions
-
-module _ (f : B → A) where
-
-  implies : (≈ : Rel A ℓ₁) (∼ : Rel A ℓ₂) →
-            ≈ ⇒ ∼ → (≈ on f) ⇒ (∼ on f)
-  implies _ _ impl = impl
-
-  reflexive : (∼ : Rel A ℓ) → Reflexive ∼ → Reflexive (∼ on f)
-  reflexive _ refl = refl
-
-  irreflexive : (≈ : Rel A ℓ₁) (∼ : Rel A ℓ₂) →
-                Irreflexive ≈ ∼ → Irreflexive (≈ on f) (∼ on f)
-  irreflexive _ _ irrefl = irrefl
-
-  symmetric : (∼ : Rel A ℓ) → Symmetric ∼ → Symmetric (∼ on f)
-  symmetric _ sym = sym
-
-  transitive : (∼ : Rel A ℓ) → Transitive ∼ → Transitive (∼ on f)
-  transitive _ trans = trans
-
-  antisymmetric : (≈ : Rel A ℓ₁) (≤ : Rel A ℓ₂) →
-                  Antisymmetric ≈ ≤ → Antisymmetric (≈ on f) (≤ on f)
-  antisymmetric _ _ antisym = antisym
-
-  asymmetric : (< : Rel A ℓ) → Asymmetric < → Asymmetric (< on f)
-  asymmetric _ asym = asym
-
-  respects : (∼ : Rel A ℓ) (P : A → Set p) →
-             P Respects ∼ → (P ∘ f) Respects (∼ on f)
-  respects _ _ resp = resp
-
-  respects₂ : (∼₁ : Rel A ℓ₁) (∼₂ : Rel A ℓ₂) →
-              ∼₁ Respects₂ ∼₂ → (∼₁ on f) Respects₂ (∼₂ on f)
-  respects₂ _ _ (resp₁ , resp₂) = (resp₁ , resp₂)
-
-  decidable : (∼ : Rel A ℓ) → Decidable ∼ → Decidable (∼ on f)
-  decidable _ dec x y = dec (f x) (f y)
-
-  total : (∼ : Rel A ℓ) → Total ∼ → Total (∼ on f)
-  total _ tot x y = tot (f x) (f y)
-
-  trichotomous : (≈ : Rel A ℓ₁) (< : Rel A ℓ₂) →
-                 Trichotomous ≈ < → Trichotomous (≈ on f) (< on f)
-  trichotomous _ _ compare x y = compare (f x) (f y)
-
-  accessible : ∀ {∼ : Rel A ℓ} {x} → Acc ∼ (f x) → Acc (∼ on f) x
-  accessible (acc rs) = acc (λ y fy<fx → accessible (rs (f y) fy<fx))
-
-  wellFounded : {∼ : Rel A ℓ} → WellFounded ∼ → WellFounded (∼ on f)
-  wellFounded wf x = accessible (wf (f x))
-
-------------------------------------------------------------------------
--- Structures
-
-module _ (f : B → A) {≈ : Rel A ℓ₁} where
-
-  isEquivalence : IsEquivalence ≈ →
-                  IsEquivalence (≈ on f)
-  isEquivalence eq = record
-    { refl  = reflexive  f ≈ Eq.refl
-    ; sym   = symmetric  f ≈ Eq.sym
-    ; trans = transitive f ≈ Eq.trans
-    } where module Eq = IsEquivalence eq
-
-  isDecEquivalence : IsDecEquivalence ≈ →
-                     IsDecEquivalence (≈ on f)
-  isDecEquivalence dec = record
-    { isEquivalence = isEquivalence Dec.isEquivalence
-    ; _≟_           = decidable f ≈ Dec._≟_
-    } where module Dec = IsDecEquivalence dec
-
-module _ (f : B → A) {≈ : Rel A ℓ₁} {∼ : Rel A ℓ₂} where
-
-  isPreorder : IsPreorder ≈ ∼ → IsPreorder (≈ on f) (∼ on f)
-  isPreorder pre = record
-    { isEquivalence = isEquivalence f Pre.isEquivalence
-    ; reflexive     = implies f ≈ ∼ Pre.reflexive
-    ; trans         = transitive f ∼ Pre.trans
-    } where module Pre = IsPreorder pre
-
-  isPartialOrder : IsPartialOrder ≈ ∼ →
-                   IsPartialOrder (≈ on f) (∼ on f)
-  isPartialOrder po = record
-    { isPreorder = isPreorder Po.isPreorder
-    ; antisym    = antisymmetric f ≈ ∼ Po.antisym
-    } where module Po = IsPartialOrder po
-
-  isDecPartialOrder : IsDecPartialOrder ≈ ∼ →
-                      IsDecPartialOrder (≈ on f) (∼ on f)
-  isDecPartialOrder dpo = record
-    { isPartialOrder = isPartialOrder DPO.isPartialOrder
-    ; _≟_            = decidable f _ DPO._≟_
-    ; _≤?_           = decidable f _ DPO._≤?_
-    } where module DPO = IsDecPartialOrder dpo
-
-  isStrictPartialOrder : IsStrictPartialOrder ≈ ∼ →
-                         IsStrictPartialOrder (≈ on f) (∼ on f)
-  isStrictPartialOrder spo = record
-    { isEquivalence = isEquivalence f Spo.isEquivalence
-    ; irrefl        = irreflexive f ≈ ∼ Spo.irrefl
-    ; trans         = transitive f ∼ Spo.trans
-    ; <-resp-≈      = respects₂ f ∼ ≈ Spo.<-resp-≈
-    } where module Spo = IsStrictPartialOrder spo
-
-  isTotalOrder : IsTotalOrder ≈ ∼ →
-                 IsTotalOrder (≈ on f) (∼ on f)
-  isTotalOrder to = record
-    { isPartialOrder = isPartialOrder To.isPartialOrder
-    ; total          = total f ∼ To.total
-    } where module To = IsTotalOrder to
-
-  isDecTotalOrder : IsDecTotalOrder ≈ ∼ →
-                    IsDecTotalOrder (≈ on f) (∼ on f)
-  isDecTotalOrder dec = record
-    { isTotalOrder = isTotalOrder Dec.isTotalOrder
-    ; _≟_          = decidable f ≈ Dec._≟_
-    ; _≤?_         = decidable f ∼ Dec._≤?_
-    } where module Dec = IsDecTotalOrder dec
-
-  isStrictTotalOrder : IsStrictTotalOrder ≈ ∼ →
-                       IsStrictTotalOrder (≈ on f) (∼ on f)
-  isStrictTotalOrder sto = record
-    { isEquivalence = isEquivalence f Sto.isEquivalence
-    ; trans         = transitive f ∼ Sto.trans
-    ; compare       = trichotomous f ≈ ∼ Sto.compare
-    } where module Sto = IsStrictTotalOrder sto
-
-------------------------------------------------------------------------
--- Bundles
-
-preorder : (P : Preorder a ℓ₁ ℓ₂) →
-           (B → Preorder.Carrier P) →
-           Preorder _ _ _
-preorder P f = record
-  { isPreorder = isPreorder f (Preorder.isPreorder P)
-  }
-
-setoid : (S : Setoid a ℓ) →
-         (B → Setoid.Carrier S) →
-         Setoid _ _
-setoid S f = record
-  { isEquivalence = isEquivalence f (Setoid.isEquivalence S)
-  }
-
-decSetoid : (D : DecSetoid a ℓ) →
-            (B → DecSetoid.Carrier D) →
-            DecSetoid _ _
-decSetoid D f = record
-  { isDecEquivalence = isDecEquivalence f (DecSetoid.isDecEquivalence D)
-  }
-
-poset : ∀ (P : Poset a ℓ₁ ℓ₂) →
-        (B → Poset.Carrier P) →
-        Poset _ _ _
-poset P f = record
-  { isPartialOrder = isPartialOrder f (Poset.isPartialOrder P)
-  }
-
-decPoset : (D : DecPoset a ℓ₁ ℓ₂) →
-           (B → DecPoset.Carrier D) →
-           DecPoset _ _ _
-decPoset D f = record
-  { isDecPartialOrder =
-      isDecPartialOrder f (DecPoset.isDecPartialOrder D)
-  }
-
-strictPartialOrder : (S : StrictPartialOrder a ℓ₁ ℓ₂) →
-                     (B → StrictPartialOrder.Carrier S) →
-                     StrictPartialOrder _ _ _
-strictPartialOrder S f = record
-  { isStrictPartialOrder =
-      isStrictPartialOrder f (StrictPartialOrder.isStrictPartialOrder S)
-  }
-
-totalOrder : (T : TotalOrder a ℓ₁ ℓ₂) →
-             (B → TotalOrder.Carrier T) →
-             TotalOrder _ _ _
-totalOrder T f = record
-  { isTotalOrder = isTotalOrder f (TotalOrder.isTotalOrder T)
-  }
-
-decTotalOrder : (D : DecTotalOrder a ℓ₁ ℓ₂) →
-                (B → DecTotalOrder.Carrier D) →
-                DecTotalOrder _ _ _
-decTotalOrder D f = record
-  { isDecTotalOrder = isDecTotalOrder f (DecTotalOrder.isDecTotalOrder D)
-  }
-
-strictTotalOrder : (S : StrictTotalOrder a ℓ₁ ℓ₂) →
-                   (B → StrictTotalOrder.Carrier S) →
-                   StrictTotalOrder _ _ _
-strictTotalOrder S f = record
-  { isStrictTotalOrder =
-      isStrictTotalOrder f (StrictTotalOrder.isStrictTotalOrder S)
-  }
-
\ No newline at end of file diff --git a/Relation.Binary.Construct.Subst.Equality.html b/Relation.Binary.Construct.Subst.Equality.html deleted file mode 100644 index 8a165506..00000000 --- a/Relation.Binary.Construct.Subst.Equality.html +++ /dev/null @@ -1,44 +0,0 @@ - -Relation.Binary.Construct.Subst.Equality
------------------------------------------------------------------------
--- The Agda standard library
---
--- Substituting equalities for binary relations
-------------------------------------------------------------------------
-
--- For more general transformations between binary relations
--- see `Relation.Binary.Morphisms`.
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-open import Data.Product as Prod
-open import Relation.Binary
-
-module Relation.Binary.Construct.Subst.Equality
-  {a ℓ₁ ℓ₂} {A : Set a} {≈₁ : Rel A ℓ₁} {≈₂ : Rel A ℓ₂}
-  (equiv@(to , from) : ≈₁ ⇔ ≈₂)
-  where
-
-open import Function.Base
-
-------------------------------------------------------------------------
--- Definitions
-
-refl : Reflexive ≈₁ → Reflexive ≈₂
-refl refl = to refl
-
-sym : Symmetric ≈₁ → Symmetric ≈₂
-sym sym = to ∘′ sym ∘′ from
-
-trans : Transitive ≈₁ → Transitive ≈₂
-trans trans x≈y y≈z = to (trans (from x≈y) (from y≈z))
-
-------------------------------------------------------------------------
--- Structures
-
-isEquivalence : IsEquivalence ≈₁ → IsEquivalence ≈₂
-isEquivalence E = record
-  { refl  = refl  E.refl
-  ; sym   = sym   E.sym
-  ; trans = trans E.trans
-  } where module E = IsEquivalence E
-
\ No newline at end of file diff --git a/Relation.Binary.Core.html b/Relation.Binary.Core.html index f4994533..d09845ee 100644 --- a/Relation.Binary.Core.html +++ b/Relation.Binary.Core.html @@ -11,58 +11,58 @@ module Relation.Binary.Core where -open import Data.Product using (_×_) -open import Function.Base using (_on_) -open import Level using (Level; _⊔_; suc) +open import Data.Product.Base using (_×_) +open import Function.Base using (_on_) +open import Level using (Level; _⊔_; suc) -private - variable - a b c ℓ ℓ₁ ℓ₂ ℓ₃ : Level - A : Set a - B : Set b - C : Set c +private + variable + a b c ℓ ℓ₁ ℓ₂ ℓ₃ : Level + A : Set a + B : Set b + C : Set c ------------------------------------------------------------------------- --- Definitions ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Definitions +------------------------------------------------------------------------ --- Heterogeneous binary relations +-- Heterogeneous binary relations -REL : Set a → Set b → (ℓ : Level) → Set (a ⊔ b ⊔ suc ℓ) -REL A B ℓ = A → B → Set ℓ +REL : Set a → Set b → (ℓ : Level) → Set (a ⊔ b ⊔ suc ℓ) +REL A B ℓ = A → B → Set ℓ --- Homogeneous binary relations +-- Homogeneous binary relations -Rel : Set a → (ℓ : Level) → Set (a ⊔ suc ℓ) -Rel A ℓ = REL A A ℓ +Rel : Set a → (ℓ : Level) → Set (a ⊔ suc ℓ) +Rel A ℓ = REL A A ℓ ------------------------------------------------------------------------- --- Relationships between relations ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Relationships between relations +------------------------------------------------------------------------ -infix 4 _⇒_ _⇔_ _=[_]⇒_ +infix 4 _⇒_ _⇔_ _=[_]⇒_ --- Implication/containment - could also be written _⊆_. --- and corresponding notion of equivalence +-- Implication/containment - could also be written _⊆_. +-- and corresponding notion of equivalence -_⇒_ : REL A B ℓ₁ → REL A B ℓ₂ → Set _ -P ⇒ Q = ∀ {x y} → P x y → Q x y +_⇒_ : REL A B ℓ₁ → REL A B ℓ₂ → Set _ +P ⇒ Q = ∀ {x y} → P x y → Q x y -_⇔_ : REL A B ℓ₁ → REL A B ℓ₂ → Set _ -P ⇔ Q = P ⇒ Q × Q ⇒ P +_⇔_ : REL A B ℓ₁ → REL A B ℓ₂ → Set _ +P ⇔ Q = P ⇒ Q × Q ⇒ P --- Generalised implication - if P ≡ Q it can be read as "f preserves P". +-- Generalised implication - if P ≡ Q it can be read as "f preserves P". -_=[_]⇒_ : Rel A ℓ₁ → (A → B) → Rel B ℓ₂ → Set _ -P =[ f ]⇒ Q = P ⇒ (Q on f) +_=[_]⇒_ : Rel A ℓ₁ → (A → B) → Rel B ℓ₂ → Set _ +P =[ f ]⇒ Q = P ⇒ (Q on f) --- A synonym for _=[_]⇒_. +-- A synonym for _=[_]⇒_. -_Preserves_⟶_ : (A → B) → Rel A ℓ₁ → Rel B ℓ₂ → Set _ -f Preserves P ⟶ Q = P =[ f ]⇒ Q +_Preserves_⟶_ : (A → B) → Rel A ℓ₁ → Rel B ℓ₂ → Set _ +f Preserves P ⟶ Q = P =[ f ]⇒ Q --- A binary variant of _Preserves_⟶_. +-- A binary variant of _Preserves_⟶_. -_Preserves₂_⟶_⟶_ : (A → B → C) → Rel A ℓ₁ → Rel B ℓ₂ → Rel C ℓ₃ → Set _ -_∙_ Preserves₂ P ⟶ Q ⟶ R = ∀ {x y u v} → P x y → Q u v → R (x ∙ u) (y ∙ v) +_Preserves₂_⟶_⟶_ : (A → B → C) → Rel A ℓ₁ → Rel B ℓ₂ → Rel C ℓ₃ → Set _ +_∙_ Preserves₂ P ⟶ Q ⟶ R = ∀ {x y u v} → P x y → Q u v → R (x ∙ u) (y ∙ v) \ No newline at end of file diff --git a/Relation.Binary.Definitions.html b/Relation.Binary.Definitions.html index 23e52e3f..bc78e273 100644 --- a/Relation.Binary.Definitions.html +++ b/Relation.Binary.Definitions.html @@ -14,229 +14,240 @@ open import Agda.Builtin.Equality using (_≡_) open import Data.Maybe.Base using (Maybe) -open import Data.Product using (_×_) -open import Data.Sum.Base using (_⊎_) -open import Function.Base using (_on_; flip) -open import Level -open import Relation.Binary.Core -open import Relation.Nullary.Decidable.Core using (Dec) -open import Relation.Nullary.Negation.Core using (¬_) +open import Data.Product.Base using (_×_; ∃-syntax) +open import Data.Sum.Base using (_⊎_) +open import Function.Base using (_on_; flip) +open import Level +open import Relation.Binary.Core +open import Relation.Nullary.Decidable.Core using (Dec) +open import Relation.Nullary.Negation.Core using (¬_) -private - variable - a b c ℓ ℓ₁ ℓ₂ ℓ₃ : Level - A : Set a - B : Set b - C : Set c +private + variable + a b c ℓ ℓ₁ ℓ₂ ℓ₃ : Level + A : Set a + B : Set b + C : Set c ------------------------------------------------------------------------- --- Definitions ------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Definitions +------------------------------------------------------------------------ --- Reflexivity - defined without an underlying equality. It could --- alternatively be defined as `_≈_ ⇒ _∼_` for some equality `_≈_`. +-- Reflexivity - defined without an underlying equality. It could +-- alternatively be defined as `_≈_ ⇒ _∼_` for some equality `_≈_`. --- Confusingly the convention in the library is to use the name "refl" --- for proofs of Reflexive and `reflexive` for proofs of type `_≈_ ⇒ _∼_`, --- e.g. in the definition of `IsEquivalence` later in this file. This --- convention is a legacy from the early days of the library. +-- Confusingly the convention in the library is to use the name "refl" +-- for proofs of Reflexive and `reflexive` for proofs of type `_≈_ ⇒ _∼_`, +-- e.g. in the definition of `IsEquivalence` later in this file. This +-- convention is a legacy from the early days of the library. -Reflexive : Rel A ℓ → Set _ -Reflexive _∼_ = ∀ {x} → x ∼ x +Reflexive : Rel A ℓ → Set _ +Reflexive _∼_ = ∀ {x} → x ∼ x --- Generalised symmetry. +-- Generalised symmetry. -Sym : REL A B ℓ₁ → REL B A ℓ₂ → Set _ -Sym P Q = P ⇒ flip Q +Sym : REL A B ℓ₁ → REL B A ℓ₂ → Set _ +Sym P Q = P ⇒ flip Q --- Symmetry. +-- Symmetry. -Symmetric : Rel A ℓ → Set _ -Symmetric _∼_ = Sym _∼_ _∼_ +Symmetric : Rel A ℓ → Set _ +Symmetric _∼_ = Sym _∼_ _∼_ --- Generalised transitivity. +-- Generalised transitivity. -Trans : REL A B ℓ₁ → REL B C ℓ₂ → REL A C ℓ₃ → Set _ -Trans P Q R = ∀ {i j k} → P i j → Q j k → R i k +Trans : REL A B ℓ₁ → REL B C ℓ₂ → REL A C ℓ₃ → Set _ +Trans P Q R = ∀ {i j k} → P i j → Q j k → R i k --- A flipped variant of generalised transitivity. +RightTrans : REL A B ℓ₁ → REL B B ℓ₂ → Set _ +RightTrans R S = Trans R S R -TransFlip : REL A B ℓ₁ → REL B C ℓ₂ → REL A C ℓ₃ → Set _ -TransFlip P Q R = ∀ {i j k} → Q j k → P i j → R i k +LeftTrans : REL A A ℓ₁ → REL A B ℓ₂ → Set _ +LeftTrans S R = Trans S R R --- Transitivity. +-- A flipped variant of generalised transitivity. -Transitive : Rel A ℓ → Set _ -Transitive _∼_ = Trans _∼_ _∼_ _∼_ +TransFlip : REL A B ℓ₁ → REL B C ℓ₂ → REL A C ℓ₃ → Set _ +TransFlip P Q R = ∀ {i j k} → Q j k → P i j → R i k --- Generalised antisymmetry +-- Transitivity. -Antisym : REL A B ℓ₁ → REL B A ℓ₂ → REL A B ℓ₃ → Set _ -Antisym R S E = ∀ {i j} → R i j → S j i → E i j +Transitive : Rel A ℓ → Set _ +Transitive _∼_ = Trans _∼_ _∼_ _∼_ --- Antisymmetry. +-- Generalised antisymmetry -Antisymmetric : Rel A ℓ₁ → Rel A ℓ₂ → Set _ -Antisymmetric _≈_ _≤_ = Antisym _≤_ _≤_ _≈_ +Antisym : REL A B ℓ₁ → REL B A ℓ₂ → REL A B ℓ₃ → Set _ +Antisym R S E = ∀ {i j} → R i j → S j i → E i j --- Irreflexivity - this is defined terms of the underlying equality. +-- Antisymmetry. -Irreflexive : REL A B ℓ₁ → REL A B ℓ₂ → Set _ -Irreflexive _≈_ _<_ = ∀ {x y} → x ≈ y → ¬ (x < y) +Antisymmetric : Rel A ℓ₁ → Rel A ℓ₂ → Set _ +Antisymmetric _≈_ _≤_ = Antisym _≤_ _≤_ _≈_ --- Asymmetry. +-- Irreflexivity - this is defined terms of the underlying equality. -Asymmetric : Rel A ℓ → Set _ -Asymmetric _<_ = ∀ {x y} → x < y → ¬ (y < x) +Irreflexive : REL A B ℓ₁ → REL A B ℓ₂ → Set _ +Irreflexive _≈_ _<_ = ∀ {x y} → x ≈ y → ¬ (x < y) --- Generalised connex - exactly one of the two relations holds. +-- Asymmetry. -Connex : REL A B ℓ₁ → REL B A ℓ₂ → Set _ -Connex P Q = ∀ x y → P x y ⊎ Q y x +Asymmetric : Rel A ℓ → Set _ +Asymmetric _<_ = ∀ {x y} → x < y → ¬ (y < x) --- Totality. +-- Density -Total : Rel A ℓ → Set _ -Total _∼_ = Connex _∼_ _∼_ +Dense : Rel A ℓ → Set _ +Dense _<_ = ∀ {x y} → x < y → ∃[ z ] x < z × z < y --- Generalised trichotomy - exactly one of three types has a witness. +-- Generalised connex - at least one of the two relations holds. -data Tri (A : Set a) (B : Set b) (C : Set c) : Set (a ⊔ b ⊔ c) where - tri< : ( a : A) (¬b : ¬ B) (¬c : ¬ C) → Tri A B C - tri≈ : (¬a : ¬ A) ( b : B) (¬c : ¬ C) → Tri A B C - tri> : (¬a : ¬ A) (¬b : ¬ B) ( c : C) → Tri A B C +Connex : REL A B ℓ₁ → REL B A ℓ₂ → Set _ +Connex P Q = ∀ x y → P x y ⊎ Q y x --- Trichotomy. +-- Totality. -Trichotomous : Rel A ℓ₁ → Rel A ℓ₂ → Set _ -Trichotomous _≈_ _<_ = ∀ x y → Tri (x < y) (x ≈ y) (x > y) - where _>_ = flip _<_ +Total : Rel A ℓ → Set _ +Total _∼_ = Connex _∼_ _∼_ --- Generalised maximum element. +-- Generalised trichotomy - exactly one of three types has a witness. -Max : REL A B ℓ → B → Set _ -Max _≤_ T = ∀ x → x ≤ T +data Tri (A : Set a) (B : Set b) (C : Set c) : Set (a ⊔ b ⊔ c) where + tri< : ( a : A) (¬b : ¬ B) (¬c : ¬ C) → Tri A B C + tri≈ : (¬a : ¬ A) ( b : B) (¬c : ¬ C) → Tri A B C + tri> : (¬a : ¬ A) (¬b : ¬ B) ( c : C) → Tri A B C --- Maximum element. +-- Trichotomy. -Maximum : Rel A ℓ → A → Set _ -Maximum = Max +Trichotomous : Rel A ℓ₁ → Rel A ℓ₂ → Set _ +Trichotomous _≈_ _<_ = ∀ x y → Tri (x < y) (x ≈ y) (x > y) + where _>_ = flip _<_ --- Generalised minimum element. +-- Generalised maximum element. -Min : REL A B ℓ → A → Set _ -Min R = Max (flip R) +Max : REL A B ℓ → B → Set _ +Max _≤_ T = ∀ x → x ≤ T --- Minimum element. +-- Maximum element. -Minimum : Rel A ℓ → A → Set _ -Minimum = Min +Maximum : Rel A ℓ → A → Set _ +Maximum = Max --- Definitions for apartness relations +-- Generalised minimum element. --- Note that Cotransitive's arguments are permuted with respect to Transitive's. -Cotransitive : Rel A ℓ → Set _ -Cotransitive _#_ = ∀ {x y} → x # y → ∀ z → (x # z) ⊎ (z # y) +Min : REL A B ℓ → A → Set _ +Min R = Max (flip R) -Tight : Rel A ℓ₁ → Rel A ℓ₂ → Set _ -Tight _≈_ _#_ = ∀ x y → (¬ x # y → x ≈ y) × (x ≈ y → ¬ x # y) +-- Minimum element. --- Properties of order morphisms, aka order-preserving maps +Minimum : Rel A ℓ → A → Set _ +Minimum = Min -Monotonic₁ : Rel A ℓ₁ → Rel B ℓ₂ → (A → B) → Set _ -Monotonic₁ _≤_ _⊑_ f = f Preserves _≤_ ⟶ _⊑_ +-- Definitions for apartness relations -Antitonic₁ : Rel A ℓ₁ → Rel B ℓ₂ → (A → B) → Set _ -Antitonic₁ _≤_ _⊑_ f = f Preserves (flip _≤_) ⟶ _⊑_ +-- Note that Cotransitive's arguments are permuted with respect to Transitive's. +Cotransitive : Rel A ℓ → Set _ +Cotransitive _#_ = ∀ {x y} → x # y → ∀ z → (x # z) ⊎ (z # y) -Monotonic₂ : Rel A ℓ₁ → Rel B ℓ₂ → Rel C ℓ₃ → (A → B → C) → Set _ -Monotonic₂ _≤_ _⊑_ _≼_ ∙ = ∙ Preserves₂ _≤_ ⟶ _⊑_ ⟶ _≼_ +Tight : Rel A ℓ₁ → Rel A ℓ₂ → Set _ +Tight _≈_ _#_ = ∀ x y → (¬ x # y → x ≈ y) × (x ≈ y → ¬ x # y) -MonotonicAntitonic : Rel A ℓ₁ → Rel B ℓ₂ → Rel C ℓ₃ → (A → B → C) → Set _ -MonotonicAntitonic _≤_ _⊑_ _≼_ ∙ = ∙ Preserves₂ _≤_ ⟶ (flip _⊑_) ⟶ _≼_ +-- Properties of order morphisms, aka order-preserving maps -AntitonicMonotonic : Rel A ℓ₁ → Rel B ℓ₂ → Rel C ℓ₃ → (A → B → C) → Set _ -AntitonicMonotonic _≤_ _⊑_ _≼_ ∙ = ∙ Preserves₂ (flip _≤_) ⟶ _⊑_ ⟶ _≼_ +Monotonic₁ : Rel A ℓ₁ → Rel B ℓ₂ → (A → B) → Set _ +Monotonic₁ _≤_ _⊑_ f = f Preserves _≤_ ⟶ _⊑_ -Antitonic₂ : Rel A ℓ₁ → Rel B ℓ₂ → Rel C ℓ₃ → (A → B → C) → Set _ -Antitonic₂ _≤_ _⊑_ _≼_ ∙ = ∙ Preserves₂ (flip _≤_) ⟶ (flip _⊑_) ⟶ _≼_ +Antitonic₁ : Rel A ℓ₁ → Rel B ℓ₂ → (A → B) → Set _ +Antitonic₁ _≤_ _⊑_ f = f Preserves (flip _≤_) ⟶ _⊑_ -Adjoint : Rel A ℓ₁ → Rel B ℓ₂ → (A → B) → (B → A) → Set _ -Adjoint _≤_ _⊑_ f g = ∀ {x y} → (f x ⊑ y → x ≤ g y) × (x ≤ g y → f x ⊑ y) +Monotonic₂ : Rel A ℓ₁ → Rel B ℓ₂ → Rel C ℓ₃ → (A → B → C) → Set _ +Monotonic₂ _≤_ _⊑_ _≼_ ∙ = ∙ Preserves₂ _≤_ ⟶ _⊑_ ⟶ _≼_ --- Unary relations respecting a binary relation. +MonotonicAntitonic : Rel A ℓ₁ → Rel B ℓ₂ → Rel C ℓ₃ → (A → B → C) → Set _ +MonotonicAntitonic _≤_ _⊑_ _≼_ ∙ = ∙ Preserves₂ _≤_ ⟶ (flip _⊑_) ⟶ _≼_ -_⟶_Respects_ : (A → Set ℓ₁) → (B → Set ℓ₂) → REL A B ℓ₃ → Set _ -P ⟶ Q Respects _∼_ = ∀ {x y} → x ∼ y → P x → Q y +AntitonicMonotonic : Rel A ℓ₁ → Rel B ℓ₂ → Rel C ℓ₃ → (A → B → C) → Set _ +AntitonicMonotonic _≤_ _⊑_ _≼_ ∙ = ∙ Preserves₂ (flip _≤_) ⟶ _⊑_ ⟶ _≼_ --- Unary relation respects a binary relation. +Antitonic₂ : Rel A ℓ₁ → Rel B ℓ₂ → Rel C ℓ₃ → (A → B → C) → Set _ +Antitonic₂ _≤_ _⊑_ _≼_ ∙ = ∙ Preserves₂ (flip _≤_) ⟶ (flip _⊑_) ⟶ _≼_ -_Respects_ : (A → Set ℓ₁) → Rel A ℓ₂ → Set _ -P Respects _∼_ = P ⟶ P Respects _∼_ +Adjoint : Rel A ℓ₁ → Rel B ℓ₂ → (A → B) → (B → A) → Set _ +Adjoint _≤_ _⊑_ f g = ∀ {x y} → (f x ⊑ y → x ≤ g y) × (x ≤ g y → f x ⊑ y) --- Right respecting - relatedness is preserved on the right by equality. +-- Unary relations respecting a binary relation. -_Respectsʳ_ : REL A B ℓ₁ → Rel B ℓ₂ → Set _ -_∼_ Respectsʳ _≈_ = ∀ {x} → (x ∼_) Respects _≈_ +_⟶_Respects_ : (A → Set ℓ₁) → (B → Set ℓ₂) → REL A B ℓ₃ → Set _ +P ⟶ Q Respects _∼_ = ∀ {x y} → x ∼ y → P x → Q y --- Left respecting - relatedness is preserved on the left by equality. +-- Unary relation respects a binary relation. -_Respectsˡ_ : REL A B ℓ₁ → Rel A ℓ₂ → Set _ -P Respectsˡ _∼_ = ∀ {y} → (flip P y) Respects _∼_ +_Respects_ : (A → Set ℓ₁) → Rel A ℓ₂ → Set _ +P Respects _∼_ = P ⟶ P Respects _∼_ --- Respecting - relatedness is preserved on both sides by equality +-- Right respecting - relatedness is preserved on the right by equality. -_Respects₂_ : Rel A ℓ₁ → Rel A ℓ₂ → Set _ -P Respects₂ _∼_ = (P Respectsʳ _∼_) × (P Respectsˡ _∼_) +_Respectsʳ_ : REL A B ℓ₁ → Rel B ℓ₂ → Set _ +_∼_ Respectsʳ _≈_ = ∀ {x} → (x ∼_) Respects _≈_ --- Substitutivity - any two related elements satisfy exactly the same --- set of unary relations. Note that only the various derivatives --- of propositional equality can satisfy this property. +-- Left respecting - relatedness is preserved on the left by equality. -Substitutive : Rel A ℓ₁ → (ℓ₂ : Level) → Set _ -Substitutive {A = A} _∼_ p = (P : A → Set p) → P Respects _∼_ +_Respectsˡ_ : REL A B ℓ₁ → Rel A ℓ₂ → Set _ +P Respectsˡ _∼_ = ∀ {y} → (flip P y) Respects _∼_ --- Decidability - it is possible to determine whether a given pair of --- elements are related. +-- Respecting - relatedness is preserved on both sides by equality -Decidable : REL A B ℓ → Set _ -Decidable _∼_ = ∀ x y → Dec (x ∼ y) +_Respects₂_ : Rel A ℓ₁ → Rel A ℓ₂ → Set _ +P Respects₂ _∼_ = (P Respectsʳ _∼_) × (P Respectsˡ _∼_) --- Weak decidability - it is sometimes possible to determine if a given --- pair of elements are related. +-- Substitutivity - any two related elements satisfy exactly the same +-- set of unary relations. Note that only the various derivatives +-- of propositional equality can satisfy this property. -WeaklyDecidable : REL A B ℓ → Set _ -WeaklyDecidable _∼_ = ∀ x y → Maybe (x ∼ y) +Substitutive : Rel A ℓ₁ → (ℓ₂ : Level) → Set _ +Substitutive {A = A} _∼_ p = (P : A → Set p) → P Respects _∼_ --- Propositional equality is decidable for the type. +-- Decidability - it is possible to determine whether a given pair of +-- elements are related. -DecidableEquality : (A : Set a) → Set _ -DecidableEquality A = Decidable {A = A} _≡_ +Decidable : REL A B ℓ → Set _ +Decidable _∼_ = ∀ x y → Dec (x ∼ y) --- Irrelevancy - all proofs that a given pair of elements are related --- are indistinguishable. +-- Weak decidability - it is sometimes possible to determine if a given +-- pair of elements are related. -Irrelevant : REL A B ℓ → Set _ -Irrelevant _∼_ = ∀ {x y} (a b : x ∼ y) → a ≡ b +WeaklyDecidable : REL A B ℓ → Set _ +WeaklyDecidable _∼_ = ∀ x y → Maybe (x ∼ y) --- Recomputability - we can rebuild a relevant proof given an --- irrelevant one. +-- Propositional equality is decidable for the type. -Recomputable : REL A B ℓ → Set _ -Recomputable _∼_ = ∀ {x y} → .(x ∼ y) → x ∼ y +DecidableEquality : (A : Set a) → Set _ +DecidableEquality A = Decidable {A = A} _≡_ --- Universal - all pairs of elements are related +-- Irrelevancy - all proofs that a given pair of elements are related +-- are indistinguishable. -Universal : REL A B ℓ → Set _ -Universal _∼_ = ∀ x y → x ∼ y +Irrelevant : REL A B ℓ → Set _ +Irrelevant _∼_ = ∀ {x y} (a b : x ∼ y) → a ≡ b --- Non-emptiness - at least one pair of elements are related. +-- Recomputability - we can rebuild a relevant proof given an +-- irrelevant one. -record NonEmpty {A : Set a} {B : Set b} - (T : REL A B ℓ) : Set (a ⊔ b ⊔ ℓ) where - constructor nonEmpty - field - {x} : A - {y} : B - proof : T x y +Recomputable : REL A B ℓ → Set _ +Recomputable _∼_ = ∀ {x y} → .(x ∼ y) → x ∼ y + +-- Universal - all pairs of elements are related + +Universal : REL A B ℓ → Set _ +Universal _∼_ = ∀ x y → x ∼ y + +-- Non-emptiness - at least one pair of elements are related. + +record NonEmpty {A : Set a} {B : Set b} + (T : REL A B ℓ) : Set (a ⊔ b ⊔ ℓ) where + constructor nonEmpty + field + {x} : A + {y} : B + proof : T x y \ No newline at end of file diff --git a/Relation.Binary.Indexed.Heterogeneous.Bundles.html b/Relation.Binary.Indexed.Heterogeneous.Bundles.html index 006451cc..d98e6ead 100644 --- a/Relation.Binary.Indexed.Heterogeneous.Bundles.html +++ b/Relation.Binary.Indexed.Heterogeneous.Bundles.html @@ -14,32 +14,49 @@ open import Function.Base open import Level using (suc; _⊔_) -open import Relation.Binary using (_⇒_) -open import Relation.Binary.PropositionalEquality.Core as P using (_≡_) -open import Relation.Binary.Indexed.Heterogeneous.Core -open import Relation.Binary.Indexed.Heterogeneous.Structures - ------------------------------------------------------------------------- --- Definitions - -record IndexedSetoid {i} (I : Set i) c ℓ : Set (suc (i ⊔ c ⊔ ℓ)) where - infix 4 _≈_ - field - Carrier : I → Set c - _≈_ : IRel Carrier ℓ - isEquivalence : IsIndexedEquivalence Carrier _≈_ - - open IsIndexedEquivalence isEquivalence public - - -record IndexedPreorder {i} (I : Set i) c ℓ₁ ℓ₂ : - Set (suc (i ⊔ c ⊔ ℓ₁ ⊔ ℓ₂)) where - infix 4 _≈_ _∼_ - field - Carrier : I → Set c - _≈_ : IRel Carrier ℓ₁ -- The underlying equality. - _∼_ : IRel Carrier ℓ₂ -- The relation. - isPreorder : IsIndexedPreorder Carrier _≈_ _∼_ - - open IsIndexedPreorder isPreorder public +open import Relation.Binary.Core using (_⇒_) +open import Relation.Binary.PropositionalEquality.Core as P using (_≡_) +open import Relation.Binary.Indexed.Heterogeneous.Core +open import Relation.Binary.Indexed.Heterogeneous.Structures + +------------------------------------------------------------------------ +-- Definitions + +record IndexedSetoid {i} (I : Set i) c ℓ : Set (suc (i ⊔ c ⊔ ℓ)) where + infix 4 _≈_ + field + Carrier : I → Set c + _≈_ : IRel Carrier ℓ + isEquivalence : IsIndexedEquivalence Carrier _≈_ + + open IsIndexedEquivalence isEquivalence public + + +record IndexedPreorder {i} (I : Set i) c ℓ₁ ℓ₂ : + Set (suc (i ⊔ c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _≲_ + field + Carrier : I → Set c + _≈_ : IRel Carrier ℓ₁ -- The underlying equality. + _≲_ : IRel Carrier ℓ₂ -- The relation. + isPreorder : IsIndexedPreorder Carrier _≈_ _≲_ + + open IsIndexedPreorder isPreorder public + + infix 4 _∼_ + _∼_ = _≲_ + + + +------------------------------------------------------------------------ +-- DEPRECATED +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 2.0 + +{-# WARNING_ON_USAGE IndexedPreorder._∼_ +"Warning: IndexedPreorder._∼_ was deprecated in v2.0. Please use IndexedPreorder._≲_ instead. " +#-} \ No newline at end of file diff --git a/Relation.Binary.Indexed.Heterogeneous.Construct.Trivial.html b/Relation.Binary.Indexed.Heterogeneous.Construct.Trivial.html index f02b4f38..f2635a6d 100644 --- a/Relation.Binary.Indexed.Heterogeneous.Construct.Trivial.html +++ b/Relation.Binary.Indexed.Heterogeneous.Construct.Trivial.html @@ -10,50 +10,52 @@ module Relation.Binary.Indexed.Heterogeneous.Construct.Trivial {i} {I : Set i} where -open import Relation.Binary -open import Relation.Binary.Indexed.Heterogeneous - ------------------------------------------------------------------------- --- Structures - -module _ {a} {A : Set a} where - - private - Aᵢ : I → Set a - Aᵢ i = A - - isIndexedEquivalence : ∀ {ℓ} {_≈_ : Rel A ℓ} → IsEquivalence _≈_ → - IsIndexedEquivalence Aᵢ _≈_ - isIndexedEquivalence isEq = record - { refl = refl - ; sym = sym - ; trans = trans - } - where open IsEquivalence isEq - - isIndexedPreorder : ∀ {ℓ₁ ℓ₂} {_≈_ : Rel A ℓ₁} {_∼_ : Rel A ℓ₂} → - IsPreorder _≈_ _∼_ → - IsIndexedPreorder Aᵢ _≈_ _∼_ - isIndexedPreorder isPreorder = record - { isEquivalence = isIndexedEquivalence isEquivalence - ; reflexive = reflexive - ; trans = trans - } - where open IsPreorder isPreorder - ------------------------------------------------------------------------- --- Bundles - -indexedSetoid : ∀ {a ℓ} → Setoid a ℓ → IndexedSetoid I a ℓ -indexedSetoid S = record - { isEquivalence = isIndexedEquivalence isEquivalence - } - where open Setoid S - -indexedPreorder : ∀ {a ℓ₁ ℓ₂} → Preorder a ℓ₁ ℓ₂ → - IndexedPreorder I a ℓ₁ ℓ₂ -indexedPreorder O = record - { isPreorder = isIndexedPreorder isPreorder - } - where open Preorder O +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Bundles using (Setoid; Preorder) +open import Relation.Binary.Structures using (IsEquivalence; IsPreorder) +open import Relation.Binary.Indexed.Heterogeneous + +------------------------------------------------------------------------ +-- Structures + +module _ {a} {A : Set a} where + + private + Aᵢ : I → Set a + Aᵢ i = A + + isIndexedEquivalence : ∀ {ℓ} {_≈_ : Rel A ℓ} → IsEquivalence _≈_ → + IsIndexedEquivalence Aᵢ _≈_ + isIndexedEquivalence isEq = record + { refl = refl + ; sym = sym + ; trans = trans + } + where open IsEquivalence isEq + + isIndexedPreorder : ∀ {ℓ₁ ℓ₂} {_≈_ : Rel A ℓ₁} {_∼_ : Rel A ℓ₂} → + IsPreorder _≈_ _∼_ → + IsIndexedPreorder Aᵢ _≈_ _∼_ + isIndexedPreorder isPreorder = record + { isEquivalence = isIndexedEquivalence isEquivalence + ; reflexive = reflexive + ; trans = trans + } + where open IsPreorder isPreorder + +------------------------------------------------------------------------ +-- Bundles + +indexedSetoid : ∀ {a ℓ} → Setoid a ℓ → IndexedSetoid I a ℓ +indexedSetoid S = record + { isEquivalence = isIndexedEquivalence isEquivalence + } + where open Setoid S + +indexedPreorder : ∀ {a ℓ₁ ℓ₂} → Preorder a ℓ₁ ℓ₂ → + IndexedPreorder I a ℓ₁ ℓ₂ +indexedPreorder O = record + { isPreorder = isIndexedPreorder isPreorder + } + where open Preorder O \ No newline at end of file diff --git a/Relation.Binary.Indexed.Heterogeneous.Core.html b/Relation.Binary.Indexed.Heterogeneous.Core.html index 47921bf5..2c940617 100644 --- a/Relation.Binary.Indexed.Heterogeneous.Core.html +++ b/Relation.Binary.Indexed.Heterogeneous.Core.html @@ -37,6 +37,6 @@ infixr 4 _=[_]⇒_ _=[_]⇒_ : ∀ {a b ℓ₁ ℓ₂} {A : Set a} {B : A → Set b} → - B.Rel A ℓ₁ → ((x : A) → B x) → IRel B ℓ₂ → Set _ + B.Rel A ℓ₁ → ((x : A) → B x) → IRel B ℓ₂ → Set _ P =[ f ]⇒ Q = ∀ {i j} → P i j → Q (f i) (f j) \ No newline at end of file diff --git a/Relation.Binary.Indexed.Heterogeneous.Definitions.html b/Relation.Binary.Indexed.Heterogeneous.Definitions.html index d2d8151a..0331b35b 100644 --- a/Relation.Binary.Indexed.Heterogeneous.Definitions.html +++ b/Relation.Binary.Indexed.Heterogeneous.Definitions.html @@ -27,11 +27,11 @@ -- Simple properties of indexed binary relations Reflexive : (A : I → Set a) → IRel A ℓ → Set _ -Reflexive _ _∼_ = ∀ {i} → B.Reflexive (_∼_ {i}) +Reflexive _ _∼_ = ∀ {i} → B.Reflexive (_∼_ {i}) Symmetric : (A : I → Set a) → IRel A ℓ → Set _ -Symmetric _ _∼_ = ∀ {i j} → B.Sym (_∼_ {i} {j}) _∼_ +Symmetric _ _∼_ = ∀ {i j} → B.Sym (_∼_ {i} {j}) _∼_ Transitive : (A : I → Set a) → IRel A ℓ → Set _ -Transitive _ _∼_ = ∀ {i j k} → B.Trans _∼_ (_∼_ {j}) (_∼_ {i} {k}) +Transitive _ _∼_ = ∀ {i j k} → B.Trans _∼_ (_∼_ {j}) (_∼_ {i} {k}) \ No newline at end of file diff --git a/Relation.Binary.Indexed.Heterogeneous.Structures.html b/Relation.Binary.Indexed.Heterogeneous.Structures.html index 433860bc..08410284 100644 --- a/Relation.Binary.Indexed.Heterogeneous.Structures.html +++ b/Relation.Binary.Indexed.Heterogeneous.Structures.html @@ -18,31 +18,31 @@ open import Function.Base open import Level using (suc; _⊔_) -open import Relation.Binary using (_⇒_) -open import Relation.Binary.PropositionalEquality.Core as P using (_≡_) -open import Relation.Binary.Indexed.Heterogeneous.Definitions +open import Relation.Binary.Core using (_⇒_) +open import Relation.Binary.PropositionalEquality.Core as P using (_≡_) +open import Relation.Binary.Indexed.Heterogeneous.Definitions ------------------------------------------------------------------------- --- Equivalences +------------------------------------------------------------------------ +-- Equivalences -record IsIndexedEquivalence : Set (i ⊔ a ⊔ ℓ) where - field - refl : Reflexive A _≈_ - sym : Symmetric A _≈_ - trans : Transitive A _≈_ +record IsIndexedEquivalence : Set (i ⊔ a ⊔ ℓ) where + field + refl : Reflexive A _≈_ + sym : Symmetric A _≈_ + trans : Transitive A _≈_ - reflexive : ∀ {i} → _≡_ ⟨ _⇒_ ⟩ _≈_ {i} - reflexive P.refl = refl + reflexive : ∀ {i} → _≡_ ⟨ _⇒_ ⟩ _≈_ {i} + reflexive P.refl = refl -record IsIndexedPreorder {ℓ₂} (_∼_ : IRel A ℓ₂) : Set (i ⊔ a ⊔ ℓ ⊔ ℓ₂) where - field - isEquivalence : IsIndexedEquivalence - reflexive : ∀ {i j} → (_≈_ {i} {j}) ⟨ _⇒_ ⟩ _∼_ - trans : Transitive A _∼_ +record IsIndexedPreorder {ℓ₂} (_≲_ : IRel A ℓ₂) : Set (i ⊔ a ⊔ ℓ ⊔ ℓ₂) where + field + isEquivalence : IsIndexedEquivalence + reflexive : ∀ {i j} → (_≈_ {i} {j}) ⟨ _⇒_ ⟩ _≲_ + trans : Transitive A _≲_ - module Eq = IsIndexedEquivalence isEquivalence + module Eq = IsIndexedEquivalence isEquivalence - refl : Reflexive A _∼_ - refl = reflexive Eq.refl + refl : Reflexive A _≲_ + refl = reflexive Eq.refl \ No newline at end of file diff --git a/Relation.Binary.Lattice.Bundles.html b/Relation.Binary.Lattice.Bundles.html index 5c6a1c64..c42d974b 100644 --- a/Relation.Binary.Lattice.Bundles.html +++ b/Relation.Binary.Lattice.Bundles.html @@ -14,216 +14,217 @@ open import Algebra.Core open import Level using (suc; _⊔_) -open import Relation.Binary -open import Relation.Binary.Lattice.Structures +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Bundles using (Poset; Setoid) +open import Relation.Binary.Lattice.Structures + +------------------------------------------------------------------------ +-- Join semilattices ------------------------------------------------------------------------- --- Join semilattices - -record JoinSemilattice c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where - infix 4 _≈_ _≤_ - infixr 6 _∨_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ₁ -- The underlying equality. - _≤_ : Rel Carrier ℓ₂ -- The partial order. - _∨_ : Op₂ Carrier -- The join operation. - isJoinSemilattice : IsJoinSemilattice _≈_ _≤_ _∨_ - - open IsJoinSemilattice isJoinSemilattice public - - poset : Poset c ℓ₁ ℓ₂ - poset = record { isPartialOrder = isPartialOrder } - - open Poset poset public using (preorder) - - -record BoundedJoinSemilattice c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where - infix 4 _≈_ _≤_ - infixr 6 _∨_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ₁ -- The underlying equality. - _≤_ : Rel Carrier ℓ₂ -- The partial order. - _∨_ : Op₂ Carrier -- The join operation. - ⊥ : Carrier -- The minimum. - isBoundedJoinSemilattice : IsBoundedJoinSemilattice _≈_ _≤_ _∨_ ⊥ - - open IsBoundedJoinSemilattice isBoundedJoinSemilattice public - - joinSemilattice : JoinSemilattice c ℓ₁ ℓ₂ - joinSemilattice = record { isJoinSemilattice = isJoinSemilattice } - - open JoinSemilattice joinSemilattice public using (preorder; poset) - ------------------------------------------------------------------------- --- Meet semilattices - -record MeetSemilattice c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where - infix 4 _≈_ _≤_ - infixr 7 _∧_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ₁ -- The underlying equality. - _≤_ : Rel Carrier ℓ₂ -- The partial order. - _∧_ : Op₂ Carrier -- The meet operation. - isMeetSemilattice : IsMeetSemilattice _≈_ _≤_ _∧_ - - open IsMeetSemilattice isMeetSemilattice public - - poset : Poset c ℓ₁ ℓ₂ - poset = record { isPartialOrder = isPartialOrder } - - open Poset poset public using (preorder) - -record BoundedMeetSemilattice c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where - infix 4 _≈_ _≤_ - infixr 7 _∧_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ₁ -- The underlying equality. - _≤_ : Rel Carrier ℓ₂ -- The partial order. - _∧_ : Op₂ Carrier -- The join operation. - ⊤ : Carrier -- The maximum. - isBoundedMeetSemilattice : IsBoundedMeetSemilattice _≈_ _≤_ _∧_ ⊤ - - open IsBoundedMeetSemilattice isBoundedMeetSemilattice public - - meetSemilattice : MeetSemilattice c ℓ₁ ℓ₂ - meetSemilattice = record { isMeetSemilattice = isMeetSemilattice } - - open MeetSemilattice meetSemilattice public using (preorder; poset) - ------------------------------------------------------------------------- --- Lattices - -record Lattice c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where - infix 4 _≈_ _≤_ - infixr 6 _∨_ - infixr 7 _∧_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ₁ -- The underlying equality. - _≤_ : Rel Carrier ℓ₂ -- The partial order. - _∨_ : Op₂ Carrier -- The join operation. - _∧_ : Op₂ Carrier -- The meet operation. - isLattice : IsLattice _≈_ _≤_ _∨_ _∧_ - - open IsLattice isLattice public - - setoid : Setoid c ℓ₁ - setoid = record { isEquivalence = isEquivalence } - - joinSemilattice : JoinSemilattice c ℓ₁ ℓ₂ - joinSemilattice = record { isJoinSemilattice = isJoinSemilattice } - - meetSemilattice : MeetSemilattice c ℓ₁ ℓ₂ - meetSemilattice = record { isMeetSemilattice = isMeetSemilattice } - - open JoinSemilattice joinSemilattice public using (poset; preorder) - -record DistributiveLattice c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where - infix 4 _≈_ _≤_ - infixr 6 _∨_ - infixr 7 _∧_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ₁ -- The underlying equality. - _≤_ : Rel Carrier ℓ₂ -- The partial order. - _∨_ : Op₂ Carrier -- The join operation. - _∧_ : Op₂ Carrier -- The meet operation. - isDistributiveLattice : IsDistributiveLattice _≈_ _≤_ _∨_ _∧_ - - open IsDistributiveLattice isDistributiveLattice using (∧-distribˡ-∨) public - open IsDistributiveLattice isDistributiveLattice using (isLattice) - - lattice : Lattice c ℓ₁ ℓ₂ - lattice = record { isLattice = isLattice } - - open Lattice lattice hiding (Carrier; _≈_; _≤_; _∨_; _∧_) public - -record BoundedLattice c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where - infix 4 _≈_ _≤_ - infixr 6 _∨_ - infixr 7 _∧_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ₁ -- The underlying equality. - _≤_ : Rel Carrier ℓ₂ -- The partial order. - _∨_ : Op₂ Carrier -- The join operation. - _∧_ : Op₂ Carrier -- The meet operation. - ⊤ : Carrier -- The maximum. - ⊥ : Carrier -- The minimum. - isBoundedLattice : IsBoundedLattice _≈_ _≤_ _∨_ _∧_ ⊤ ⊥ - - open IsBoundedLattice isBoundedLattice public - - boundedJoinSemilattice : BoundedJoinSemilattice c ℓ₁ ℓ₂ - boundedJoinSemilattice = record - { isBoundedJoinSemilattice = isBoundedJoinSemilattice } - - boundedMeetSemilattice : BoundedMeetSemilattice c ℓ₁ ℓ₂ - boundedMeetSemilattice = record - { isBoundedMeetSemilattice = isBoundedMeetSemilattice } - - lattice : Lattice c ℓ₁ ℓ₂ - lattice = record { isLattice = isLattice } - - open Lattice lattice public - using (joinSemilattice; meetSemilattice; poset; preorder; setoid) - ------------------------------------------------------------------------- --- Heyting algebras (a bounded lattice with exponential operator) - -record HeytingAlgebra c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where - infix 4 _≈_ _≤_ - infixr 5 _⇨_ - infixr 6 _∨_ - infixr 7 _∧_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ₁ -- The underlying equality. - _≤_ : Rel Carrier ℓ₂ -- The partial order. - _∨_ : Op₂ Carrier -- The join operation. - _∧_ : Op₂ Carrier -- The meet operation. - _⇨_ : Op₂ Carrier -- The exponential operation. - ⊤ : Carrier -- The maximum. - ⊥ : Carrier -- The minimum. - isHeytingAlgebra : IsHeytingAlgebra _≈_ _≤_ _∨_ _∧_ _⇨_ ⊤ ⊥ - - boundedLattice : BoundedLattice c ℓ₁ ℓ₂ - boundedLattice = record - { isBoundedLattice = IsHeytingAlgebra.isBoundedLattice isHeytingAlgebra } - - open IsHeytingAlgebra isHeytingAlgebra - using (exponential; transpose-⇨; transpose-∧) public - open BoundedLattice boundedLattice - hiding (Carrier; _≈_; _≤_; _∨_; _∧_; ⊤; ⊥) public - ------------------------------------------------------------------------- --- Boolean algebras (a specialized Heyting algebra) - -record BooleanAlgebra c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where - infix 4 _≈_ _≤_ - infixr 6 _∨_ - infixr 7 _∧_ - infix 8 ¬_ - field - Carrier : Set c - _≈_ : Rel Carrier ℓ₁ -- The underlying equality. - _≤_ : Rel Carrier ℓ₂ -- The partial order. - _∨_ : Op₂ Carrier -- The join operation. - _∧_ : Op₂ Carrier -- The meet operation. - ¬_ : Op₁ Carrier -- The negation operation. - ⊤ : Carrier -- The maximum. - ⊥ : Carrier -- The minimum. - isBooleanAlgebra : IsBooleanAlgebra _≈_ _≤_ _∨_ _∧_ ¬_ ⊤ ⊥ - - open IsBooleanAlgebra isBooleanAlgebra using (isHeytingAlgebra) - - heytingAlgebra : HeytingAlgebra c ℓ₁ ℓ₂ - heytingAlgebra = record { isHeytingAlgebra = isHeytingAlgebra } - - open HeytingAlgebra heytingAlgebra public - hiding (Carrier; _≈_; _≤_; _∨_; _∧_; ⊤; ⊥) +record JoinSemilattice c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _≤_ + infixr 6 _∨_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ₁ -- The underlying equality. + _≤_ : Rel Carrier ℓ₂ -- The partial order. + _∨_ : Op₂ Carrier -- The join operation. + isJoinSemilattice : IsJoinSemilattice _≈_ _≤_ _∨_ + + open IsJoinSemilattice isJoinSemilattice public + + poset : Poset c ℓ₁ ℓ₂ + poset = record { isPartialOrder = isPartialOrder } + + open Poset poset public using (preorder) + + +record BoundedJoinSemilattice c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _≤_ + infixr 6 _∨_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ₁ -- The underlying equality. + _≤_ : Rel Carrier ℓ₂ -- The partial order. + _∨_ : Op₂ Carrier -- The join operation. + ⊥ : Carrier -- The minimum. + isBoundedJoinSemilattice : IsBoundedJoinSemilattice _≈_ _≤_ _∨_ ⊥ + + open IsBoundedJoinSemilattice isBoundedJoinSemilattice public + + joinSemilattice : JoinSemilattice c ℓ₁ ℓ₂ + joinSemilattice = record { isJoinSemilattice = isJoinSemilattice } + + open JoinSemilattice joinSemilattice public using (preorder; poset) + +------------------------------------------------------------------------ +-- Meet semilattices + +record MeetSemilattice c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _≤_ + infixr 7 _∧_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ₁ -- The underlying equality. + _≤_ : Rel Carrier ℓ₂ -- The partial order. + _∧_ : Op₂ Carrier -- The meet operation. + isMeetSemilattice : IsMeetSemilattice _≈_ _≤_ _∧_ + + open IsMeetSemilattice isMeetSemilattice public + + poset : Poset c ℓ₁ ℓ₂ + poset = record { isPartialOrder = isPartialOrder } + + open Poset poset public using (preorder) + +record BoundedMeetSemilattice c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _≤_ + infixr 7 _∧_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ₁ -- The underlying equality. + _≤_ : Rel Carrier ℓ₂ -- The partial order. + _∧_ : Op₂ Carrier -- The join operation. + ⊤ : Carrier -- The maximum. + isBoundedMeetSemilattice : IsBoundedMeetSemilattice _≈_ _≤_ _∧_ ⊤ + + open IsBoundedMeetSemilattice isBoundedMeetSemilattice public + + meetSemilattice : MeetSemilattice c ℓ₁ ℓ₂ + meetSemilattice = record { isMeetSemilattice = isMeetSemilattice } + + open MeetSemilattice meetSemilattice public using (preorder; poset) + +------------------------------------------------------------------------ +-- Lattices + +record Lattice c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _≤_ + infixr 6 _∨_ + infixr 7 _∧_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ₁ -- The underlying equality. + _≤_ : Rel Carrier ℓ₂ -- The partial order. + _∨_ : Op₂ Carrier -- The join operation. + _∧_ : Op₂ Carrier -- The meet operation. + isLattice : IsLattice _≈_ _≤_ _∨_ _∧_ + + open IsLattice isLattice public + + setoid : Setoid c ℓ₁ + setoid = record { isEquivalence = isEquivalence } + + joinSemilattice : JoinSemilattice c ℓ₁ ℓ₂ + joinSemilattice = record { isJoinSemilattice = isJoinSemilattice } + + meetSemilattice : MeetSemilattice c ℓ₁ ℓ₂ + meetSemilattice = record { isMeetSemilattice = isMeetSemilattice } + + open JoinSemilattice joinSemilattice public using (poset; preorder) + +record DistributiveLattice c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _≤_ + infixr 6 _∨_ + infixr 7 _∧_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ₁ -- The underlying equality. + _≤_ : Rel Carrier ℓ₂ -- The partial order. + _∨_ : Op₂ Carrier -- The join operation. + _∧_ : Op₂ Carrier -- The meet operation. + isDistributiveLattice : IsDistributiveLattice _≈_ _≤_ _∨_ _∧_ + + open IsDistributiveLattice isDistributiveLattice using (∧-distribˡ-∨) public + open IsDistributiveLattice isDistributiveLattice using (isLattice) + + lattice : Lattice c ℓ₁ ℓ₂ + lattice = record { isLattice = isLattice } + + open Lattice lattice hiding (Carrier; _≈_; _≤_; _∨_; _∧_) public + +record BoundedLattice c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _≤_ + infixr 6 _∨_ + infixr 7 _∧_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ₁ -- The underlying equality. + _≤_ : Rel Carrier ℓ₂ -- The partial order. + _∨_ : Op₂ Carrier -- The join operation. + _∧_ : Op₂ Carrier -- The meet operation. + ⊤ : Carrier -- The maximum. + ⊥ : Carrier -- The minimum. + isBoundedLattice : IsBoundedLattice _≈_ _≤_ _∨_ _∧_ ⊤ ⊥ + + open IsBoundedLattice isBoundedLattice public + + boundedJoinSemilattice : BoundedJoinSemilattice c ℓ₁ ℓ₂ + boundedJoinSemilattice = record + { isBoundedJoinSemilattice = isBoundedJoinSemilattice } + + boundedMeetSemilattice : BoundedMeetSemilattice c ℓ₁ ℓ₂ + boundedMeetSemilattice = record + { isBoundedMeetSemilattice = isBoundedMeetSemilattice } + + lattice : Lattice c ℓ₁ ℓ₂ + lattice = record { isLattice = isLattice } + + open Lattice lattice public + using (joinSemilattice; meetSemilattice; poset; preorder; setoid) + +------------------------------------------------------------------------ +-- Heyting algebras (a bounded lattice with exponential operator) + +record HeytingAlgebra c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _≤_ + infixr 5 _⇨_ + infixr 6 _∨_ + infixr 7 _∧_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ₁ -- The underlying equality. + _≤_ : Rel Carrier ℓ₂ -- The partial order. + _∨_ : Op₂ Carrier -- The join operation. + _∧_ : Op₂ Carrier -- The meet operation. + _⇨_ : Op₂ Carrier -- The exponential operation. + ⊤ : Carrier -- The maximum. + ⊥ : Carrier -- The minimum. + isHeytingAlgebra : IsHeytingAlgebra _≈_ _≤_ _∨_ _∧_ _⇨_ ⊤ ⊥ + + boundedLattice : BoundedLattice c ℓ₁ ℓ₂ + boundedLattice = record + { isBoundedLattice = IsHeytingAlgebra.isBoundedLattice isHeytingAlgebra } + + open IsHeytingAlgebra isHeytingAlgebra + using (exponential; transpose-⇨; transpose-∧) public + open BoundedLattice boundedLattice + hiding (Carrier; _≈_; _≤_; _∨_; _∧_; ⊤; ⊥) public + +------------------------------------------------------------------------ +-- Boolean algebras (a specialized Heyting algebra) + +record BooleanAlgebra c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where + infix 4 _≈_ _≤_ + infixr 6 _∨_ + infixr 7 _∧_ + infix 8 ¬_ + field + Carrier : Set c + _≈_ : Rel Carrier ℓ₁ -- The underlying equality. + _≤_ : Rel Carrier ℓ₂ -- The partial order. + _∨_ : Op₂ Carrier -- The join operation. + _∧_ : Op₂ Carrier -- The meet operation. + ¬_ : Op₁ Carrier -- The negation operation. + ⊤ : Carrier -- The maximum. + ⊥ : Carrier -- The minimum. + isBooleanAlgebra : IsBooleanAlgebra _≈_ _≤_ _∨_ _∧_ ¬_ ⊤ ⊥ + + open IsBooleanAlgebra isBooleanAlgebra using (isHeytingAlgebra) + + heytingAlgebra : HeytingAlgebra c ℓ₁ ℓ₂ + heytingAlgebra = record { isHeytingAlgebra = isHeytingAlgebra } + + open HeytingAlgebra heytingAlgebra public + hiding (Carrier; _≈_; _≤_; _∨_; _∧_; ⊤; ⊥) \ No newline at end of file diff --git a/Relation.Binary.Lattice.Definitions.html b/Relation.Binary.Lattice.Definitions.html index b5e3cd5b..53078c1b 100644 --- a/Relation.Binary.Lattice.Definitions.html +++ b/Relation.Binary.Lattice.Definitions.html @@ -13,27 +13,27 @@ module Relation.Binary.Lattice.Definitions where open import Algebra.Core -open import Data.Product using (_×_; _,_) -open import Function.Base using (flip) -open import Relation.Binary -open import Level +open import Data.Product.Base using (_×_; _,_) +open import Function.Base using (flip) +open import Relation.Binary.Core using (Rel) +open import Level using (Level) -private - variable - a ℓ : Level - A : Set a +private + variable + a ℓ : Level + A : Set a ------------------------------------------------------------------------- --- Relationships between orders and operators +------------------------------------------------------------------------ +-- Relationships between orders and operators -Supremum : Rel A ℓ → Op₂ A → Set _ -Supremum _≤_ _∨_ = - ∀ x y → x ≤ (x ∨ y) × y ≤ (x ∨ y) × ∀ z → x ≤ z → y ≤ z → (x ∨ y) ≤ z +Supremum : Rel A ℓ → Op₂ A → Set _ +Supremum _≤_ _∨_ = + ∀ x y → x ≤ (x ∨ y) × y ≤ (x ∨ y) × ∀ z → x ≤ z → y ≤ z → (x ∨ y) ≤ z -Infimum : Rel A ℓ → Op₂ A → Set _ -Infimum _≤_ = Supremum (flip _≤_) +Infimum : Rel A ℓ → Op₂ A → Set _ +Infimum _≤_ = Supremum (flip _≤_) -Exponential : Rel A ℓ → Op₂ A → Op₂ A → Set _ -Exponential _≤_ _∧_ _⇨_ = - ∀ w x y → ((w ∧ x) ≤ y → w ≤ (x ⇨ y)) × (w ≤ (x ⇨ y) → (w ∧ x) ≤ y) +Exponential : Rel A ℓ → Op₂ A → Op₂ A → Set _ +Exponential _≤_ _∧_ _⇨_ = + ∀ w x y → ((w ∧ x) ≤ y → w ≤ (x ⇨ y)) × (w ≤ (x ⇨ y) → (w ∧ x) ≤ y) \ No newline at end of file diff --git a/Relation.Binary.Lattice.Structures.html b/Relation.Binary.Lattice.Structures.html index cdf9ee61..b6e631e3 100644 --- a/Relation.Binary.Lattice.Structures.html +++ b/Relation.Binary.Lattice.Structures.html @@ -10,177 +10,179 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary - -module Relation.Binary.Lattice.Structures - {a ℓ₁ ℓ₂} {A : Set a} - (_≈_ : Rel A ℓ₁) -- The underlying equality. - (_≤_ : Rel A ℓ₂) -- The partial order. - where - -open import Algebra.Core -open import Algebra.Definitions -open import Data.Product using (_×_; _,_) -open import Level using (suc; _⊔_) - -open import Relation.Binary.Lattice.Definitions - ------------------------------------------------------------------------- --- Join semilattices - -record IsJoinSemilattice (_∨_ : Op₂ A) -- The join operation. - : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isPartialOrder : IsPartialOrder _≈_ _≤_ - supremum : Supremum _≤_ _∨_ - - x≤x∨y : ∀ x y → x ≤ (x ∨ y) - x≤x∨y x y = let pf , _ , _ = supremum x y in pf - - y≤x∨y : ∀ x y → y ≤ (x ∨ y) - y≤x∨y x y = let _ , pf , _ = supremum x y in pf - - ∨-least : ∀ {x y z} → x ≤ z → y ≤ z → (x ∨ y) ≤ z - ∨-least {x} {y} {z} = let _ , _ , pf = supremum x y in pf z - - open IsPartialOrder isPartialOrder public - -record IsBoundedJoinSemilattice (_∨_ : Op₂ A) -- The join operation. - (⊥ : A) -- The minimum. - : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isJoinSemilattice : IsJoinSemilattice _∨_ - minimum : Minimum _≤_ ⊥ - - open IsJoinSemilattice isJoinSemilattice public - ------------------------------------------------------------------------- --- Meet semilattices - -record IsMeetSemilattice (_∧_ : Op₂ A) -- The meet operation. - : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isPartialOrder : IsPartialOrder _≈_ _≤_ - infimum : Infimum _≤_ _∧_ - - x∧y≤x : ∀ x y → (x ∧ y) ≤ x - x∧y≤x x y = let pf , _ , _ = infimum x y in pf - - x∧y≤y : ∀ x y → (x ∧ y) ≤ y - x∧y≤y x y = let _ , pf , _ = infimum x y in pf - - ∧-greatest : ∀ {x y z} → x ≤ y → x ≤ z → x ≤ (y ∧ z) - ∧-greatest {x} {y} {z} = let _ , _ , pf = infimum y z in pf x - - open IsPartialOrder isPartialOrder public - -record IsBoundedMeetSemilattice (_∧_ : Op₂ A) -- The join operation. - (⊤ : A) -- The maximum. - : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isMeetSemilattice : IsMeetSemilattice _∧_ - maximum : Maximum _≤_ ⊤ - - open IsMeetSemilattice isMeetSemilattice public - ------------------------------------------------------------------------- --- Lattices - -record IsLattice (_∨_ : Op₂ A) -- The join operation. - (_∧_ : Op₂ A) -- The meet operation. - : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isPartialOrder : IsPartialOrder _≈_ _≤_ - supremum : Supremum _≤_ _∨_ - infimum : Infimum _≤_ _∧_ - - isJoinSemilattice : IsJoinSemilattice _∨_ - isJoinSemilattice = record - { isPartialOrder = isPartialOrder - ; supremum = supremum - } - - isMeetSemilattice : IsMeetSemilattice _∧_ - isMeetSemilattice = record - { isPartialOrder = isPartialOrder - ; infimum = infimum - } - - open IsJoinSemilattice isJoinSemilattice public - using (x≤x∨y; y≤x∨y; ∨-least) - open IsMeetSemilattice isMeetSemilattice public - using (x∧y≤x; x∧y≤y; ∧-greatest) - open IsPartialOrder isPartialOrder public - -record IsDistributiveLattice (_∨_ : Op₂ A) -- The join operation. - (_∧_ : Op₂ A) -- The meet operation. - : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isLattice : IsLattice _∨_ _∧_ - ∧-distribˡ-∨ : _DistributesOverˡ_ _≈_ _∧_ _∨_ - - open IsLattice isLattice public - -record IsBoundedLattice (_∨_ : Op₂ A) -- The join operation. - (_∧_ : Op₂ A) -- The meet operation. - (⊤ : A) -- The maximum. - (⊥ : A) -- The minimum. - : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isLattice : IsLattice _∨_ _∧_ - maximum : Maximum _≤_ ⊤ - minimum : Minimum _≤_ ⊥ - - open IsLattice isLattice public - - isBoundedJoinSemilattice : IsBoundedJoinSemilattice _∨_ ⊥ - isBoundedJoinSemilattice = record - { isJoinSemilattice = isJoinSemilattice - ; minimum = minimum - } - - isBoundedMeetSemilattice : IsBoundedMeetSemilattice _∧_ ⊤ - isBoundedMeetSemilattice = record - { isMeetSemilattice = isMeetSemilattice - ; maximum = maximum - } - ------------------------------------------------------------------------- --- Heyting algebras (a bounded lattice with exponential operator) - -record IsHeytingAlgebra (_∨_ : Op₂ A) -- The join operation. - (_∧_ : Op₂ A) -- The meet operation. - (_⇨_ : Op₂ A) -- The exponential operation. - (⊤ : A) -- The maximum. - (⊥ : A) -- The minimum. - : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isBoundedLattice : IsBoundedLattice _∨_ _∧_ ⊤ ⊥ - exponential : Exponential _≤_ _∧_ _⇨_ - - transpose-⇨ : ∀ {w x y} → (w ∧ x) ≤ y → w ≤ (x ⇨ y) - transpose-⇨ {w} {x} {y} = let pf , _ = exponential w x y in pf - - transpose-∧ : ∀ {w x y} → w ≤ (x ⇨ y) → (w ∧ x) ≤ y - transpose-∧ {w} {x} {y} = let _ , pf = exponential w x y in pf - - open IsBoundedLattice isBoundedLattice public - ------------------------------------------------------------------------- --- Boolean algebras (a specialized Heyting algebra) - -record IsBooleanAlgebra (_∨_ : Op₂ A) -- The join operation. - (_∧_ : Op₂ A) -- The meet operation. - (¬_ : Op₁ A) -- The negation operation. - (⊤ : A) -- The maximum. - (⊥ : A) -- The minimum. - : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - infixr 5 _⇨_ - _⇨_ : Op₂ A - x ⇨ y = (¬ x) ∨ y - - field - isHeytingAlgebra : IsHeytingAlgebra _∨_ _∧_ _⇨_ ⊤ ⊥ - - open IsHeytingAlgebra isHeytingAlgebra public +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Structures using (IsPartialOrder) +open import Relation.Binary.Definitions using (Minimum; Maximum) + +module Relation.Binary.Lattice.Structures + {a ℓ₁ ℓ₂} {A : Set a} + (_≈_ : Rel A ℓ₁) -- The underlying equality. + (_≤_ : Rel A ℓ₂) -- The partial order. + where + +open import Algebra.Core +open import Algebra.Definitions +open import Data.Product.Base using (_×_; _,_) +open import Level using (suc; _⊔_) + +open import Relation.Binary.Lattice.Definitions + +------------------------------------------------------------------------ +-- Join semilattices + +record IsJoinSemilattice (_∨_ : Op₂ A) -- The join operation. + : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isPartialOrder : IsPartialOrder _≈_ _≤_ + supremum : Supremum _≤_ _∨_ + + x≤x∨y : ∀ x y → x ≤ (x ∨ y) + x≤x∨y x y = let pf , _ , _ = supremum x y in pf + + y≤x∨y : ∀ x y → y ≤ (x ∨ y) + y≤x∨y x y = let _ , pf , _ = supremum x y in pf + + ∨-least : ∀ {x y z} → x ≤ z → y ≤ z → (x ∨ y) ≤ z + ∨-least {x} {y} {z} = let _ , _ , pf = supremum x y in pf z + + open IsPartialOrder isPartialOrder public + +record IsBoundedJoinSemilattice (_∨_ : Op₂ A) -- The join operation. + (⊥ : A) -- The minimum. + : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isJoinSemilattice : IsJoinSemilattice _∨_ + minimum : Minimum _≤_ ⊥ + + open IsJoinSemilattice isJoinSemilattice public + +------------------------------------------------------------------------ +-- Meet semilattices + +record IsMeetSemilattice (_∧_ : Op₂ A) -- The meet operation. + : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isPartialOrder : IsPartialOrder _≈_ _≤_ + infimum : Infimum _≤_ _∧_ + + x∧y≤x : ∀ x y → (x ∧ y) ≤ x + x∧y≤x x y = let pf , _ , _ = infimum x y in pf + + x∧y≤y : ∀ x y → (x ∧ y) ≤ y + x∧y≤y x y = let _ , pf , _ = infimum x y in pf + + ∧-greatest : ∀ {x y z} → x ≤ y → x ≤ z → x ≤ (y ∧ z) + ∧-greatest {x} {y} {z} = let _ , _ , pf = infimum y z in pf x + + open IsPartialOrder isPartialOrder public + +record IsBoundedMeetSemilattice (_∧_ : Op₂ A) -- The join operation. + (⊤ : A) -- The maximum. + : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isMeetSemilattice : IsMeetSemilattice _∧_ + maximum : Maximum _≤_ ⊤ + + open IsMeetSemilattice isMeetSemilattice public + +------------------------------------------------------------------------ +-- Lattices + +record IsLattice (_∨_ : Op₂ A) -- The join operation. + (_∧_ : Op₂ A) -- The meet operation. + : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isPartialOrder : IsPartialOrder _≈_ _≤_ + supremum : Supremum _≤_ _∨_ + infimum : Infimum _≤_ _∧_ + + isJoinSemilattice : IsJoinSemilattice _∨_ + isJoinSemilattice = record + { isPartialOrder = isPartialOrder + ; supremum = supremum + } + + isMeetSemilattice : IsMeetSemilattice _∧_ + isMeetSemilattice = record + { isPartialOrder = isPartialOrder + ; infimum = infimum + } + + open IsJoinSemilattice isJoinSemilattice public + using (x≤x∨y; y≤x∨y; ∨-least) + open IsMeetSemilattice isMeetSemilattice public + using (x∧y≤x; x∧y≤y; ∧-greatest) + open IsPartialOrder isPartialOrder public + +record IsDistributiveLattice (_∨_ : Op₂ A) -- The join operation. + (_∧_ : Op₂ A) -- The meet operation. + : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isLattice : IsLattice _∨_ _∧_ + ∧-distribˡ-∨ : _DistributesOverˡ_ _≈_ _∧_ _∨_ + + open IsLattice isLattice public + +record IsBoundedLattice (_∨_ : Op₂ A) -- The join operation. + (_∧_ : Op₂ A) -- The meet operation. + (⊤ : A) -- The maximum. + (⊥ : A) -- The minimum. + : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isLattice : IsLattice _∨_ _∧_ + maximum : Maximum _≤_ ⊤ + minimum : Minimum _≤_ ⊥ + + open IsLattice isLattice public + + isBoundedJoinSemilattice : IsBoundedJoinSemilattice _∨_ ⊥ + isBoundedJoinSemilattice = record + { isJoinSemilattice = isJoinSemilattice + ; minimum = minimum + } + + isBoundedMeetSemilattice : IsBoundedMeetSemilattice _∧_ ⊤ + isBoundedMeetSemilattice = record + { isMeetSemilattice = isMeetSemilattice + ; maximum = maximum + } + +------------------------------------------------------------------------ +-- Heyting algebras (a bounded lattice with exponential operator) + +record IsHeytingAlgebra (_∨_ : Op₂ A) -- The join operation. + (_∧_ : Op₂ A) -- The meet operation. + (_⇨_ : Op₂ A) -- The exponential operation. + (⊤ : A) -- The maximum. + (⊥ : A) -- The minimum. + : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isBoundedLattice : IsBoundedLattice _∨_ _∧_ ⊤ ⊥ + exponential : Exponential _≤_ _∧_ _⇨_ + + transpose-⇨ : ∀ {w x y} → (w ∧ x) ≤ y → w ≤ (x ⇨ y) + transpose-⇨ {w} {x} {y} = let pf , _ = exponential w x y in pf + + transpose-∧ : ∀ {w x y} → w ≤ (x ⇨ y) → (w ∧ x) ≤ y + transpose-∧ {w} {x} {y} = let _ , pf = exponential w x y in pf + + open IsBoundedLattice isBoundedLattice public + +------------------------------------------------------------------------ +-- Boolean algebras (a specialized Heyting algebra) + +record IsBooleanAlgebra (_∨_ : Op₂ A) -- The join operation. + (_∧_ : Op₂ A) -- The meet operation. + (¬_ : Op₁ A) -- The negation operation. + (⊤ : A) -- The maximum. + (⊥ : A) -- The minimum. + : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + infixr 5 _⇨_ + _⇨_ : Op₂ A + x ⇨ y = (¬ x) ∨ y + + field + isHeytingAlgebra : IsHeytingAlgebra _∨_ _∧_ _⇨_ ⊤ ⊥ + + open IsHeytingAlgebra isHeytingAlgebra public \ No newline at end of file diff --git a/Relation.Binary.Morphism.Bundles.html b/Relation.Binary.Morphism.Bundles.html index bc9013bf..e3ccfce4 100644 --- a/Relation.Binary.Morphism.Bundles.html +++ b/Relation.Binary.Morphism.Bundles.html @@ -8,10 +8,10 @@ {-# OPTIONS --cubical-compatible --safe #-} open import Level -open import Relation.Binary.Core using (_Preserves_⟶_) +open import Relation.Binary.Core using (_Preserves_⟶_) open import Relation.Binary.Bundles open import Relation.Binary.Morphism.Structures -open import Relation.Binary.Consequences using (mono⇒cong) +open import Relation.Binary.Consequences using (mono⇒cong) module Relation.Binary.Morphism.Bundles where @@ -23,39 +23,39 @@ -- Setoids ------------------------------------------------------------------------ -module _ (S₁ : Setoid ℓ₁ ℓ₂) (S₂ : Setoid ℓ₃ ℓ₄) where +module _ (S₁ : Setoid ℓ₁ ℓ₂) (S₂ : Setoid ℓ₃ ℓ₄) where record SetoidHomomorphism : Set (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) where - open Setoid + open Setoid field - ⟦_⟧ : Carrier S₁ → Carrier S₂ - isRelHomomorphism : IsRelHomomorphism (_≈_ S₁) (_≈_ S₂) ⟦_⟧ + ⟦_⟧ : Carrier S₁ → Carrier S₂ + isRelHomomorphism : IsRelHomomorphism (_≈_ S₁) (_≈_ S₂) ⟦_⟧ - open IsRelHomomorphism isRelHomomorphism public + open IsRelHomomorphism isRelHomomorphism public record SetoidMonomorphism : Set (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) where - open Setoid + open Setoid field - ⟦_⟧ : Carrier S₁ → Carrier S₂ - isRelMonomorphism : IsRelMonomorphism (_≈_ S₁) (_≈_ S₂) ⟦_⟧ + ⟦_⟧ : Carrier S₁ → Carrier S₂ + isRelMonomorphism : IsRelMonomorphism (_≈_ S₁) (_≈_ S₂) ⟦_⟧ - open IsRelMonomorphism isRelMonomorphism public + open IsRelMonomorphism isRelMonomorphism public homomorphism : SetoidHomomorphism - homomorphism = record { isRelHomomorphism = isHomomorphism } + homomorphism = record { isRelHomomorphism = isHomomorphism } record SetoidIsomorphism : Set (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) where - open Setoid + open Setoid field - ⟦_⟧ : Carrier S₁ → Carrier S₂ - isRelIsomorphism : IsRelIsomorphism (_≈_ S₁) (_≈_ S₂) ⟦_⟧ + ⟦_⟧ : Carrier S₁ → Carrier S₂ + isRelIsomorphism : IsRelIsomorphism (_≈_ S₁) (_≈_ S₂) ⟦_⟧ - open IsRelIsomorphism isRelIsomorphism public + open IsRelIsomorphism isRelIsomorphism public monomorphism : SetoidMonomorphism - monomorphism = record { isRelMonomorphism = isMonomorphism } + monomorphism = record { isRelMonomorphism = isMonomorphism } open SetoidMonomorphism monomorphism public using (homomorphism) @@ -65,42 +65,42 @@ -- Preorders ------------------------------------------------------------------------ -record PreorderHomomorphism (S₁ : Preorder ℓ₁ ℓ₂ ℓ₃) - (S₂ : Preorder ℓ₄ ℓ₅ ℓ₆) +record PreorderHomomorphism (S₁ : Preorder ℓ₁ ℓ₂ ℓ₃) + (S₂ : Preorder ℓ₄ ℓ₅ ℓ₆) : Set (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄ ⊔ ℓ₅ ⊔ ℓ₆) where - open Preorder + open Preorder field - ⟦_⟧ : Carrier S₁ → Carrier S₂ - isOrderHomomorphism : IsOrderHomomorphism (_≈_ S₁) (_≈_ S₂) (_∼_ S₁) (_∼_ S₂) ⟦_⟧ + ⟦_⟧ : Carrier S₁ → Carrier S₂ + isOrderHomomorphism : IsOrderHomomorphism (_≈_ S₁) (_≈_ S₂) (_≲_ S₁) (_≲_ S₂) ⟦_⟧ - open IsOrderHomomorphism isOrderHomomorphism public + open IsOrderHomomorphism isOrderHomomorphism public ------------------------------------------------------------------------ -- Posets ------------------------------------------------------------------------ -module _ (P : Poset ℓ₁ ℓ₂ ℓ₃) (Q : Poset ℓ₄ ℓ₅ ℓ₆) where +module _ (P : Poset ℓ₁ ℓ₂ ℓ₃) (Q : Poset ℓ₄ ℓ₅ ℓ₆) where private - module P = Poset P - module Q = Poset Q + module P = Poset P + module Q = Poset Q record PosetHomomorphism : Set (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄ ⊔ ℓ₅ ⊔ ℓ₆) where field - ⟦_⟧ : P.Carrier → Q.Carrier - isOrderHomomorphism : IsOrderHomomorphism P._≈_ Q._≈_ P._≤_ Q._≤_ ⟦_⟧ + ⟦_⟧ : P.Carrier → Q.Carrier + isOrderHomomorphism : IsOrderHomomorphism P._≈_ Q._≈_ P._≤_ Q._≤_ ⟦_⟧ - open IsOrderHomomorphism isOrderHomomorphism public + open IsOrderHomomorphism isOrderHomomorphism public - -- Smart constructor that automatically constructs the congruence proof - -- from the monotonicity proof - mkPosetHomo : ∀ f → f Preserves P._≤_ ⟶ Q._≤_ → PosetHomomorphism + -- Smart constructor that automatically constructs the congruence + -- proof from the monotonicity proof + mkPosetHomo : ∀ f → f Preserves P._≤_ ⟶ Q._≤_ → PosetHomomorphism mkPosetHomo f mono = record { ⟦_⟧ = f ; isOrderHomomorphism = record - { cong = mono⇒cong P._≈_ Q._≈_ P.Eq.sym P.reflexive Q.antisym mono - ; mono = mono + { cong = mono⇒cong P._≈_ Q._≈_ P.Eq.sym P.reflexive Q.antisym mono + ; mono = mono } } \ No newline at end of file diff --git a/Relation.Binary.Morphism.Definitions.html b/Relation.Binary.Morphism.Definitions.html index ef2d9884..8a777760 100644 --- a/Relation.Binary.Morphism.Definitions.html +++ b/Relation.Binary.Morphism.Definitions.html @@ -29,6 +29,6 @@ ------------------------------------------------------------------------ -- Basic definitions -Homomorphic₂ : Rel A ℓ₁ → Rel B ℓ₂ → (A → B) → Set _ +Homomorphic₂ : Rel A ℓ₁ → Rel B ℓ₂ → (A → B) → Set _ Homomorphic₂ _∼₁_ _∼₂_ ⟦_⟧ = ∀ {x y} → x ∼₁ y → ⟦ x ⟧ ∼₂ ⟦ y ⟧ \ No newline at end of file diff --git a/Relation.Binary.Morphism.OrderMonomorphism.html b/Relation.Binary.Morphism.OrderMonomorphism.html index 57a980a2..464e779f 100644 --- a/Relation.Binary.Morphism.OrderMonomorphism.html +++ b/Relation.Binary.Morphism.OrderMonomorphism.html @@ -12,98 +12,101 @@ open import Algebra.Morphism.Definitions open import Function.Base -open import Data.Product using (_,_; map) -open import Relation.Binary -open import Relation.Binary.Morphism -import Relation.Binary.Morphism.RelMonomorphism as RawRelation - -module Relation.Binary.Morphism.OrderMonomorphism - {a b ℓ₁ ℓ₂ ℓ₃ ℓ₄} {A : Set a} {B : Set b} - {_≈₁_ : Rel A ℓ₁} {_≈₂_ : Rel B ℓ₃} - {_∼₁_ : Rel A ℓ₂} {_∼₂_ : Rel B ℓ₄} - {⟦_⟧ : A → B} - (isOrderMonomorphism : IsOrderMonomorphism _≈₁_ _≈₂_ _∼₁_ _∼₂_ ⟦_⟧) - where - -open IsOrderMonomorphism isOrderMonomorphism - ------------------------------------------------------------------------- --- Re-export equivalence proofs - -module EqM = RawRelation Eq.isRelMonomorphism - -open RawRelation isRelMonomorphism public - ------------------------------------------------------------------------- --- Properties - -reflexive : _≈₂_ ⇒ _∼₂_ → _≈₁_ ⇒ _∼₁_ -reflexive refl x≈y = cancel (refl (cong x≈y)) - -irrefl : Irreflexive _≈₂_ _∼₂_ → Irreflexive _≈₁_ _∼₁_ -irrefl irrefl x≈y x∼y = irrefl (cong x≈y) (mono x∼y) - -antisym : Antisymmetric _≈₂_ _∼₂_ → Antisymmetric _≈₁_ _∼₁_ -antisym antisym x∼y y∼x = injective (antisym (mono x∼y) (mono y∼x)) - -compare : Trichotomous _≈₂_ _∼₂_ → Trichotomous _≈₁_ _∼₁_ -compare compare x y with compare ⟦ x ⟧ ⟦ y ⟧ -... | tri< a ¬b ¬c = tri< (cancel a) (¬b ∘ cong) (¬c ∘ mono) -... | tri≈ ¬a b ¬c = tri≈ (¬a ∘ mono) (injective b) (¬c ∘ mono) -... | tri> ¬a ¬b c = tri> (¬a ∘ mono) (¬b ∘ cong) (cancel c) - -respˡ : _∼₂_ Respectsˡ _≈₂_ → _∼₁_ Respectsˡ _≈₁_ -respˡ resp x≈y x∼z = cancel (resp (cong x≈y) (mono x∼z)) - -respʳ : _∼₂_ Respectsʳ _≈₂_ → _∼₁_ Respectsʳ _≈₁_ -respʳ resp x≈y y∼z = cancel (resp (cong x≈y) (mono y∼z)) - -resp : _∼₂_ Respects₂ _≈₂_ → _∼₁_ Respects₂ _≈₁_ -resp = map respʳ respˡ - ------------------------------------------------------------------------- --- Structures - -isPreorder : IsPreorder _≈₂_ _∼₂_ → IsPreorder _≈₁_ _∼₁_ -isPreorder O = record - { isEquivalence = EqM.isEquivalence O.isEquivalence - ; reflexive = reflexive O.reflexive - ; trans = trans O.trans - } where module O = IsPreorder O - -isPartialOrder : IsPartialOrder _≈₂_ _∼₂_ → IsPartialOrder _≈₁_ _∼₁_ -isPartialOrder O = record - { isPreorder = isPreorder O.isPreorder - ; antisym = antisym O.antisym - } where module O = IsPartialOrder O - -isTotalOrder : IsTotalOrder _≈₂_ _∼₂_ → IsTotalOrder _≈₁_ _∼₁_ -isTotalOrder O = record - { isPartialOrder = isPartialOrder O.isPartialOrder - ; total = total O.total - } where module O = IsTotalOrder O - -isDecTotalOrder : IsDecTotalOrder _≈₂_ _∼₂_ → IsDecTotalOrder _≈₁_ _∼₁_ -isDecTotalOrder O = record - { isTotalOrder = isTotalOrder O.isTotalOrder - ; _≟_ = EqM.dec O._≟_ - ; _≤?_ = dec O._≤?_ - } where module O = IsDecTotalOrder O - -isStrictPartialOrder : IsStrictPartialOrder _≈₂_ _∼₂_ → - IsStrictPartialOrder _≈₁_ _∼₁_ -isStrictPartialOrder O = record - { isEquivalence = EqM.isEquivalence O.isEquivalence - ; irrefl = irrefl O.irrefl - ; trans = trans O.trans - ; <-resp-≈ = resp O.<-resp-≈ - } where module O = IsStrictPartialOrder O - -isStrictTotalOrder : IsStrictTotalOrder _≈₂_ _∼₂_ → - IsStrictTotalOrder _≈₁_ _∼₁_ -isStrictTotalOrder O = record - { isEquivalence = EqM.isEquivalence O.isEquivalence - ; trans = trans O.trans - ; compare = compare O.compare - } where module O = IsStrictTotalOrder O +open import Data.Product.Base using (_,_; map) +open import Relation.Binary.Core using (Rel; _⇒_) +open import Relation.Binary.Structures + using (IsPreorder; IsPartialOrder; IsTotalOrder; IsDecTotalOrder; IsStrictPartialOrder; IsStrictTotalOrder) +open import Relation.Binary.Definitions + using (Irreflexive; Antisymmetric; Trichotomous; tri<; tri≈; tri>; _Respectsˡ_; _Respectsʳ_; _Respects₂_) +open import Relation.Binary.Morphism +import Relation.Binary.Morphism.RelMonomorphism as RawRelation + +module Relation.Binary.Morphism.OrderMonomorphism + {a b ℓ₁ ℓ₂ ℓ₃ ℓ₄} {A : Set a} {B : Set b} + {_≈₁_ : Rel A ℓ₁} {_≈₂_ : Rel B ℓ₃} + {_≲₁_ : Rel A ℓ₂} {_≲₂_ : Rel B ℓ₄} + {⟦_⟧ : A → B} + (isOrderMonomorphism : IsOrderMonomorphism _≈₁_ _≈₂_ _≲₁_ _≲₂_ ⟦_⟧) + where + +open IsOrderMonomorphism isOrderMonomorphism + +------------------------------------------------------------------------ +-- Re-export equivalence proofs + +module EqM = RawRelation Eq.isRelMonomorphism + +open RawRelation isRelMonomorphism public + +------------------------------------------------------------------------ +-- Properties + +reflexive : _≈₂_ ⇒ _≲₂_ → _≈₁_ ⇒ _≲₁_ +reflexive refl x≈y = cancel (refl (cong x≈y)) + +irrefl : Irreflexive _≈₂_ _≲₂_ → Irreflexive _≈₁_ _≲₁_ +irrefl irrefl x≈y x∼y = irrefl (cong x≈y) (mono x∼y) + +antisym : Antisymmetric _≈₂_ _≲₂_ → Antisymmetric _≈₁_ _≲₁_ +antisym antisym x∼y y∼x = injective (antisym (mono x∼y) (mono y∼x)) + +compare : Trichotomous _≈₂_ _≲₂_ → Trichotomous _≈₁_ _≲₁_ +compare compare x y with compare ⟦ x ⟧ ⟦ y ⟧ +... | tri< a ¬b ¬c = tri< (cancel a) (¬b ∘ cong) (¬c ∘ mono) +... | tri≈ ¬a b ¬c = tri≈ (¬a ∘ mono) (injective b) (¬c ∘ mono) +... | tri> ¬a ¬b c = tri> (¬a ∘ mono) (¬b ∘ cong) (cancel c) + +respˡ : _≲₂_ Respectsˡ _≈₂_ → _≲₁_ Respectsˡ _≈₁_ +respˡ resp x≈y x∼z = cancel (resp (cong x≈y) (mono x∼z)) + +respʳ : _≲₂_ Respectsʳ _≈₂_ → _≲₁_ Respectsʳ _≈₁_ +respʳ resp x≈y y∼z = cancel (resp (cong x≈y) (mono y∼z)) + +resp : _≲₂_ Respects₂ _≈₂_ → _≲₁_ Respects₂ _≈₁_ +resp = map respʳ respˡ + +------------------------------------------------------------------------ +-- Structures + +isPreorder : IsPreorder _≈₂_ _≲₂_ → IsPreorder _≈₁_ _≲₁_ +isPreorder O = record + { isEquivalence = EqM.isEquivalence O.isEquivalence + ; reflexive = reflexive O.reflexive + ; trans = trans O.trans + } where module O = IsPreorder O + +isPartialOrder : IsPartialOrder _≈₂_ _≲₂_ → IsPartialOrder _≈₁_ _≲₁_ +isPartialOrder O = record + { isPreorder = isPreorder O.isPreorder + ; antisym = antisym O.antisym + } where module O = IsPartialOrder O + +isTotalOrder : IsTotalOrder _≈₂_ _≲₂_ → IsTotalOrder _≈₁_ _≲₁_ +isTotalOrder O = record + { isPartialOrder = isPartialOrder O.isPartialOrder + ; total = total O.total + } where module O = IsTotalOrder O + +isDecTotalOrder : IsDecTotalOrder _≈₂_ _≲₂_ → IsDecTotalOrder _≈₁_ _≲₁_ +isDecTotalOrder O = record + { isTotalOrder = isTotalOrder O.isTotalOrder + ; _≟_ = EqM.dec O._≟_ + ; _≤?_ = dec O._≤?_ + } where module O = IsDecTotalOrder O + +isStrictPartialOrder : IsStrictPartialOrder _≈₂_ _≲₂_ → + IsStrictPartialOrder _≈₁_ _≲₁_ +isStrictPartialOrder O = record + { isEquivalence = EqM.isEquivalence O.isEquivalence + ; irrefl = irrefl O.irrefl + ; trans = trans O.trans + ; <-resp-≈ = resp O.<-resp-≈ + } where module O = IsStrictPartialOrder O + +isStrictTotalOrder : IsStrictTotalOrder _≈₂_ _≲₂_ → + IsStrictTotalOrder _≈₁_ _≲₁_ +isStrictTotalOrder O = record + { isStrictPartialOrder = isStrictPartialOrder O.isStrictPartialOrder + ; compare = compare O.compare + } where module O = IsStrictTotalOrder O \ No newline at end of file diff --git a/Relation.Binary.Morphism.RelMonomorphism.html b/Relation.Binary.Morphism.RelMonomorphism.html index 2b4f2a7c..89c7358f 100644 --- a/Relation.Binary.Morphism.RelMonomorphism.html +++ b/Relation.Binary.Morphism.RelMonomorphism.html @@ -11,55 +11,58 @@ {-# OPTIONS --cubical-compatible --safe #-} open import Function.Base -open import Relation.Binary -open import Relation.Binary.Morphism +open import Relation.Binary.Core using (Rel) +open import Relation.Binary.Structures using (IsEquivalence; IsDecEquivalence) +open import Relation.Binary.Definitions + using (Reflexive; Symmetric; Transitive; Total; Asymmetric; Decidable) +open import Relation.Binary.Morphism -module Relation.Binary.Morphism.RelMonomorphism - {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b} - {_∼₁_ : Rel A ℓ₁} {_∼₂_ : Rel B ℓ₂} - {⟦_⟧ : A → B} (isMonomorphism : IsRelMonomorphism _∼₁_ _∼₂_ ⟦_⟧) - where +module Relation.Binary.Morphism.RelMonomorphism + {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b} + {_∼₁_ : Rel A ℓ₁} {_∼₂_ : Rel B ℓ₂} + {⟦_⟧ : A → B} (isMonomorphism : IsRelMonomorphism _∼₁_ _∼₂_ ⟦_⟧) + where -open import Data.Sum.Base as Sum -open import Relation.Nullary.Decidable using (yes; no) -open import Relation.Nullary.Decidable +open import Data.Sum.Base as Sum +open import Relation.Nullary.Decidable using (yes; no) +open import Relation.Nullary.Decidable -open IsRelMonomorphism isMonomorphism +open IsRelMonomorphism isMonomorphism ------------------------------------------------------------------------- --- Properties +------------------------------------------------------------------------ +-- Properties -refl : Reflexive _∼₂_ → Reflexive _∼₁_ -refl refl = injective refl +refl : Reflexive _∼₂_ → Reflexive _∼₁_ +refl refl = injective refl -sym : Symmetric _∼₂_ → Symmetric _∼₁_ -sym sym x∼y = injective (sym (cong x∼y)) +sym : Symmetric _∼₂_ → Symmetric _∼₁_ +sym sym x∼y = injective (sym (cong x∼y)) -trans : Transitive _∼₂_ → Transitive _∼₁_ -trans trans x∼y y∼z = injective (trans (cong x∼y) (cong y∼z)) +trans : Transitive _∼₂_ → Transitive _∼₁_ +trans trans x∼y y∼z = injective (trans (cong x∼y) (cong y∼z)) -total : Total _∼₂_ → Total _∼₁_ -total total x y = Sum.map injective injective (total ⟦ x ⟧ ⟦ y ⟧) +total : Total _∼₂_ → Total _∼₁_ +total total x y = Sum.map injective injective (total ⟦ x ⟧ ⟦ y ⟧) -asym : Asymmetric _∼₂_ → Asymmetric _∼₁_ -asym asym x∼y y∼x = asym (cong x∼y) (cong y∼x) +asym : Asymmetric _∼₂_ → Asymmetric _∼₁_ +asym asym x∼y y∼x = asym (cong x∼y) (cong y∼x) -dec : Decidable _∼₂_ → Decidable _∼₁_ -dec _∼?_ x y = map′ injective cong (⟦ x ⟧ ∼? ⟦ y ⟧) +dec : Decidable _∼₂_ → Decidable _∼₁_ +dec _∼?_ x y = map′ injective cong (⟦ x ⟧ ∼? ⟦ y ⟧) ------------------------------------------------------------------------- --- Structures +------------------------------------------------------------------------ +-- Structures -isEquivalence : IsEquivalence _∼₂_ → IsEquivalence _∼₁_ -isEquivalence isEq = record - { refl = refl E.refl - ; sym = sym E.sym - ; trans = trans E.trans - } where module E = IsEquivalence isEq +isEquivalence : IsEquivalence _∼₂_ → IsEquivalence _∼₁_ +isEquivalence isEq = record + { refl = refl E.refl + ; sym = sym E.sym + ; trans = trans E.trans + } where module E = IsEquivalence isEq -isDecEquivalence : IsDecEquivalence _∼₂_ → IsDecEquivalence _∼₁_ -isDecEquivalence isDecEq = record - { isEquivalence = isEquivalence E.isEquivalence - ; _≟_ = dec E._≟_ - } where module E = IsDecEquivalence isDecEq +isDecEquivalence : IsDecEquivalence _∼₂_ → IsDecEquivalence _∼₁_ +isDecEquivalence isDecEq = record + { isEquivalence = isEquivalence E.isEquivalence + ; _≟_ = dec E._≟_ + } where module E = IsDecEquivalence isDecEq \ No newline at end of file diff --git a/Relation.Binary.Morphism.Structures.html b/Relation.Binary.Morphism.Structures.html index 58976b78..b450f981 100644 --- a/Relation.Binary.Morphism.Structures.html +++ b/Relation.Binary.Morphism.Structures.html @@ -7,113 +7,113 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary.Core +open import Relation.Binary.Core using (Rel) -module Relation.Binary.Morphism.Structures - {a b} {A : Set a} {B : Set b} - where +module Relation.Binary.Morphism.Structures + {a b} {A : Set a} {B : Set b} + where -open import Data.Product using (_,_) -open import Function.Definitions -open import Level -open import Relation.Binary.Morphism.Definitions A B - -private - variable - ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Level - ------------------------------------------------------------------------- --- Relations ------------------------------------------------------------------------- - -record IsRelHomomorphism (_∼₁_ : Rel A ℓ₁) (_∼₂_ : Rel B ℓ₂) - (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - cong : Homomorphic₂ _∼₁_ _∼₂_ ⟦_⟧ - - -record IsRelMonomorphism (_∼₁_ : Rel A ℓ₁) (_∼₂_ : Rel B ℓ₂) - (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - field - isHomomorphism : IsRelHomomorphism _∼₁_ _∼₂_ ⟦_⟧ - injective : Injective _∼₁_ _∼₂_ ⟦_⟧ - - open IsRelHomomorphism isHomomorphism public - - -record IsRelIsomorphism (_∼₁_ : Rel A ℓ₁) (_∼₂_ : Rel B ℓ₂) - (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where - field - isMonomorphism : IsRelMonomorphism _∼₁_ _∼₂_ ⟦_⟧ - surjective : Surjective _∼₁_ _∼₂_ ⟦_⟧ - - open IsRelMonomorphism isMonomorphism public - - bijective : Bijective _∼₁_ _∼₂_ ⟦_⟧ - bijective = injective , surjective - - ------------------------------------------------------------------------- --- Orders ------------------------------------------------------------------------- - -record IsOrderHomomorphism (_≈₁_ : Rel A ℓ₁) (_≈₂_ : Rel B ℓ₂) - (_∼₁_ : Rel A ℓ₃) (_∼₂_ : Rel B ℓ₄) - (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) - where - field - cong : Homomorphic₂ _≈₁_ _≈₂_ ⟦_⟧ - mono : Homomorphic₂ _∼₁_ _∼₂_ ⟦_⟧ - - module Eq where - isRelHomomorphism : IsRelHomomorphism _≈₁_ _≈₂_ ⟦_⟧ - isRelHomomorphism = record { cong = cong } - - isRelHomomorphism : IsRelHomomorphism _∼₁_ _∼₂_ ⟦_⟧ - isRelHomomorphism = record { cong = mono } - - -record IsOrderMonomorphism (_≈₁_ : Rel A ℓ₁) (_≈₂_ : Rel B ℓ₂) - (_∼₁_ : Rel A ℓ₃) (_∼₂_ : Rel B ℓ₄) - (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) - where - field - isOrderHomomorphism : IsOrderHomomorphism _≈₁_ _≈₂_ _∼₁_ _∼₂_ ⟦_⟧ - injective : Injective _≈₁_ _≈₂_ ⟦_⟧ - cancel : Injective _∼₁_ _∼₂_ ⟦_⟧ - - open IsOrderHomomorphism isOrderHomomorphism public - hiding (module Eq) - - module Eq where - isRelMonomorphism : IsRelMonomorphism _≈₁_ _≈₂_ ⟦_⟧ - isRelMonomorphism = record - { isHomomorphism = IsOrderHomomorphism.Eq.isRelHomomorphism isOrderHomomorphism - ; injective = injective - } - - isRelMonomorphism : IsRelMonomorphism _∼₁_ _∼₂_ ⟦_⟧ - isRelMonomorphism = record - { isHomomorphism = isRelHomomorphism - ; injective = cancel - } - - -record IsOrderIsomorphism (_≈₁_ : Rel A ℓ₁) (_≈₂_ : Rel B ℓ₂) - (_∼₁_ : Rel A ℓ₃) (_∼₂_ : Rel B ℓ₄) - (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) - where - field - isOrderMonomorphism : IsOrderMonomorphism _≈₁_ _≈₂_ _∼₁_ _∼₂_ ⟦_⟧ - surjective : Surjective _≈₁_ _≈₂_ ⟦_⟧ - - open IsOrderMonomorphism isOrderMonomorphism public - hiding (module Eq) - - module Eq where - isRelIsomorphism : IsRelIsomorphism _≈₁_ _≈₂_ ⟦_⟧ - isRelIsomorphism = record - { isMonomorphism = IsOrderMonomorphism.Eq.isRelMonomorphism isOrderMonomorphism - ; surjective = surjective - } +open import Data.Product.Base using (_,_) +open import Function.Definitions +open import Level using (Level; _⊔_) +open import Relation.Binary.Morphism.Definitions A B + +private + variable + ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Level + +------------------------------------------------------------------------ +-- Relations +------------------------------------------------------------------------ + +record IsRelHomomorphism (_∼₁_ : Rel A ℓ₁) (_∼₂_ : Rel B ℓ₂) + (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + cong : Homomorphic₂ _∼₁_ _∼₂_ ⟦_⟧ + + +record IsRelMonomorphism (_∼₁_ : Rel A ℓ₁) (_∼₂_ : Rel B ℓ₂) + (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + field + isHomomorphism : IsRelHomomorphism _∼₁_ _∼₂_ ⟦_⟧ + injective : Injective _∼₁_ _∼₂_ ⟦_⟧ + + open IsRelHomomorphism isHomomorphism public + + +record IsRelIsomorphism (_∼₁_ : Rel A ℓ₁) (_∼₂_ : Rel B ℓ₂) + (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where + field + isMonomorphism : IsRelMonomorphism _∼₁_ _∼₂_ ⟦_⟧ + surjective : Surjective _∼₁_ _∼₂_ ⟦_⟧ + + open IsRelMonomorphism isMonomorphism public + + bijective : Bijective _∼₁_ _∼₂_ ⟦_⟧ + bijective = injective , surjective + + +------------------------------------------------------------------------ +-- Orders +------------------------------------------------------------------------ + +record IsOrderHomomorphism (_≈₁_ : Rel A ℓ₁) (_≈₂_ : Rel B ℓ₂) + (_≲₁_ : Rel A ℓ₃) (_≲₂_ : Rel B ℓ₄) + (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) + where + field + cong : Homomorphic₂ _≈₁_ _≈₂_ ⟦_⟧ + mono : Homomorphic₂ _≲₁_ _≲₂_ ⟦_⟧ + + module Eq where + isRelHomomorphism : IsRelHomomorphism _≈₁_ _≈₂_ ⟦_⟧ + isRelHomomorphism = record { cong = cong } + + isRelHomomorphism : IsRelHomomorphism _≲₁_ _≲₂_ ⟦_⟧ + isRelHomomorphism = record { cong = mono } + + +record IsOrderMonomorphism (_≈₁_ : Rel A ℓ₁) (_≈₂_ : Rel B ℓ₂) + (_≲₁_ : Rel A ℓ₃) (_≲₂_ : Rel B ℓ₄) + (⟦_⟧ : A → B) : Set (a ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) + where + field + isOrderHomomorphism : IsOrderHomomorphism _≈₁_ _≈₂_ _≲₁_ _≲₂_ ⟦_⟧ + injective : Injective _≈₁_ _≈₂_ ⟦_⟧ + cancel : Injective _≲₁_ _≲₂_ ⟦_⟧ + + open IsOrderHomomorphism isOrderHomomorphism public + hiding (module Eq) + + module Eq where + isRelMonomorphism : IsRelMonomorphism _≈₁_ _≈₂_ ⟦_⟧ + isRelMonomorphism = record + { isHomomorphism = IsOrderHomomorphism.Eq.isRelHomomorphism isOrderHomomorphism + ; injective = injective + } + + isRelMonomorphism : IsRelMonomorphism _≲₁_ _≲₂_ ⟦_⟧ + isRelMonomorphism = record + { isHomomorphism = isRelHomomorphism + ; injective = cancel + } + + +record IsOrderIsomorphism (_≈₁_ : Rel A ℓ₁) (_≈₂_ : Rel B ℓ₂) + (_≲₁_ : Rel A ℓ₃) (_≲₂_ : Rel B ℓ₄) + (⟦_⟧ : A → B) : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) + where + field + isOrderMonomorphism : IsOrderMonomorphism _≈₁_ _≈₂_ _≲₁_ _≲₂_ ⟦_⟧ + surjective : Surjective _≈₁_ _≈₂_ ⟦_⟧ + + open IsOrderMonomorphism isOrderMonomorphism public + hiding (module Eq) + + module Eq where + isRelIsomorphism : IsRelIsomorphism _≈₁_ _≈₂_ ⟦_⟧ + isRelIsomorphism = record + { isMonomorphism = IsOrderMonomorphism.Eq.isRelMonomorphism isOrderMonomorphism + ; surjective = surjective + } \ No newline at end of file diff --git a/Relation.Binary.Properties.ApartnessRelation.html b/Relation.Binary.Properties.ApartnessRelation.html new file mode 100644 index 00000000..2fed99e9 --- /dev/null +++ b/Relation.Binary.Properties.ApartnessRelation.html @@ -0,0 +1,31 @@ + +Relation.Binary.Properties.ApartnessRelation
------------------------------------------------------------------------
+-- The Agda standard library
+--
+-- Apartness properties
+------------------------------------------------------------------------
+
+{-# OPTIONS --cubical-compatible --safe #-}
+
+open import Relation.Binary.Core using (Rel)
+
+module Relation.Binary.Properties.ApartnessRelation
+  {a ℓ₁ ℓ₂} {A : Set a}
+  {_≈_ : Rel A ℓ₁}
+  {_#_ : Rel A ℓ₂}
+  where
+
+open import Function.Base using (_∘₂_)
+open import Relation.Binary.Definitions using (Reflexive)
+open import Relation.Binary.Consequences using (sym⇒¬-sym; cotrans⇒¬-trans)
+open import Relation.Binary.Structures using (IsEquivalence; IsApartnessRelation)
+open import Relation.Nullary.Negation using (¬_)
+
+¬#-isEquivalence : Reflexive _≈_ → IsApartnessRelation _≈_ _#_ →
+                   IsEquivalence (¬_ ∘₂ _#_)
+¬#-isEquivalence re apart = record
+  { refl = irrefl re
+  ; sym = λ {a} {b} → sym⇒¬-sym sym {a} {b}
+  ; trans = cotrans⇒¬-trans cotrans
+  } where open IsApartnessRelation apart
+
\ No newline at end of file diff --git a/Relation.Binary.Properties.DecTotalOrder.html b/Relation.Binary.Properties.DecTotalOrder.html index 95dbc8cd..40745114 100644 --- a/Relation.Binary.Properties.DecTotalOrder.html +++ b/Relation.Binary.Properties.DecTotalOrder.html @@ -7,91 +7,92 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary - -module Relation.Binary.Properties.DecTotalOrder - {d₁ d₂ d₃} (DT : DecTotalOrder d₁ d₂ d₃) where - -open DecTotalOrder DT hiding (trans) - -import Relation.Binary.Construct.Converse as Converse -import Relation.Binary.Construct.NonStrictToStrict _≈_ _≤_ as ToStrict -import Relation.Binary.Properties.TotalOrder totalOrder as TotalOrderProperties -open import Relation.Nullary.Negation using (¬_) - ------------------------------------------------------------------------- --- _≥_ - the flipped relation is also a total order - -open TotalOrderProperties public - using - ( _≥_ - ; ≥-refl - ; ≥-reflexive - ; ≥-trans - ; ≥-antisym - ; ≥-total - ; ≥-isPreorder - ; ≥-isPartialOrder - ; ≥-isTotalOrder - ; ≥-preorder - ; ≥-poset - ; ≥-totalOrder - ) - -≥-isDecTotalOrder : IsDecTotalOrder _≈_ _≥_ -≥-isDecTotalOrder = Converse.isDecTotalOrder isDecTotalOrder - -≥-decTotalOrder : DecTotalOrder _ _ _ -≥-decTotalOrder = record - { isDecTotalOrder = ≥-isDecTotalOrder - } - -open DecTotalOrder ≥-decTotalOrder public - using () renaming (_≤?_ to _≥?_) - ------------------------------------------------------------------------- --- _<_ - the strict version is a strict total order - -open TotalOrderProperties public - using - ( _<_ - ; <-resp-≈ - ; <-respʳ-≈ - ; <-respˡ-≈ - ; <-irrefl - ; <-asym - ; <-trans - ; <-isStrictPartialOrder - ; <-strictPartialOrder - ; <⇒≉ - ; ≤∧≉⇒< - ; <⇒≱ - ; ≤⇒≯ - ) - -<-isStrictTotalOrder : IsStrictTotalOrder _≈_ _<_ -<-isStrictTotalOrder = ToStrict.<-isStrictTotalOrder₂ isDecTotalOrder - -<-strictTotalOrder : StrictTotalOrder _ _ _ -<-strictTotalOrder = record - { isStrictTotalOrder = <-isStrictTotalOrder - } - -open StrictTotalOrder <-strictTotalOrder public - using () renaming (compare to <-compare) - ------------------------------------------------------------------------- --- _≰_ - the negated order - -open TotalOrderProperties public - using - ( _≰_ - ; ≰-respʳ-≈ - ; ≰-respˡ-≈ - ; ≰⇒> - ; ≰⇒≥ - ) - -≮⇒≥ : ∀ {x y} → ¬ (x < y) → y ≤ x -≮⇒≥ = ToStrict.≮⇒≥ Eq.sym _≟_ reflexive total +open import Relation.Binary.Structures + using (IsDecTotalOrder; IsStrictTotalOrder) +open import Relation.Binary.Bundles + using (DecTotalOrder; StrictTotalOrder) + +module Relation.Binary.Properties.DecTotalOrder + {d₁ d₂ d₃} (DTO : DecTotalOrder d₁ d₂ d₃) where + +open DecTotalOrder DTO hiding (trans) + +import Relation.Binary.Construct.Flip.EqAndOrd as EqAndOrd +import Relation.Binary.Construct.NonStrictToStrict _≈_ _≤_ as ToStrict +import Relation.Binary.Properties.TotalOrder totalOrder as TotalOrderProperties +open import Relation.Nullary.Negation using (¬_) + +------------------------------------------------------------------------ +-- _≥_ - the flipped relation is also a total order + +open TotalOrderProperties public + using + ( ≥-refl + ; ≥-reflexive + ; ≥-trans + ; ≥-antisym + ; ≥-total + ; ≥-isPreorder + ; ≥-isPartialOrder + ; ≥-isTotalOrder + ; ≥-preorder + ; ≥-poset + ; ≥-totalOrder + ) + +≥-isDecTotalOrder : IsDecTotalOrder _≈_ _≥_ +≥-isDecTotalOrder = EqAndOrd.isDecTotalOrder isDecTotalOrder + +≥-decTotalOrder : DecTotalOrder _ _ _ +≥-decTotalOrder = record + { isDecTotalOrder = ≥-isDecTotalOrder + } + +open DecTotalOrder ≥-decTotalOrder public + using () renaming (_≤?_ to _≥?_) + +------------------------------------------------------------------------ +-- _<_ - the strict version is a strict total order + +open TotalOrderProperties public + using + ( _<_ + ; <-resp-≈ + ; <-respʳ-≈ + ; <-respˡ-≈ + ; <-irrefl + ; <-asym + ; <-trans + ; <-isStrictPartialOrder + ; <-strictPartialOrder + ; <⇒≉ + ; ≤∧≉⇒< + ; <⇒≱ + ; ≤⇒≯ + ) + +<-isStrictTotalOrder : IsStrictTotalOrder _≈_ _<_ +<-isStrictTotalOrder = ToStrict.<-isStrictTotalOrder₂ isDecTotalOrder + +<-strictTotalOrder : StrictTotalOrder _ _ _ +<-strictTotalOrder = record + { isStrictTotalOrder = <-isStrictTotalOrder + } + +open StrictTotalOrder <-strictTotalOrder public + using (_≮_) renaming (compare to <-compare) + +------------------------------------------------------------------------ +-- _≰_ - the negated order + +open TotalOrderProperties public + using + ( ≰-respʳ-≈ + ; ≰-respˡ-≈ + ; ≰⇒> + ; ≰⇒≥ + ) + +≮⇒≥ : ∀ {x y} → x ≮ y → y ≤ x +≮⇒≥ = ToStrict.≮⇒≥ Eq.sym _≟_ reflexive total \ No newline at end of file diff --git a/Relation.Binary.Properties.Poset.html b/Relation.Binary.Properties.Poset.html index c9c60305..ce7002da 100644 --- a/Relation.Binary.Properties.Poset.html +++ b/Relation.Binary.Properties.Poset.html @@ -7,126 +7,122 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Function.Base using (flip; _∘_) -open import Relation.Binary -import Relation.Binary.Consequences as Consequences -open import Relation.Nullary using (¬_; yes; no) -open import Relation.Nullary.Negation using (contradiction) +open import Data.Product.Base using (_,_) +open import Function.Base using (flip; _∘_) +open import Relation.Binary.Core using (Rel; _Preserves_⟶_) +open import Relation.Binary.Bundles using (Poset; StrictPartialOrder) +open import Relation.Binary.Structures + using (IsPartialOrder; IsStrictPartialOrder; IsDecPartialOrder) +open import Relation.Binary.Definitions + using (_Respectsˡ_; _Respectsʳ_; Decidable) +import Relation.Binary.Consequences as Consequences +open import Relation.Nullary using (¬_; yes; no) +open import Relation.Nullary.Negation using (contradiction) + +module Relation.Binary.Properties.Poset + {p₁ p₂ p₃} (P : Poset p₁ p₂ p₃) where + +open Poset P renaming (Carrier to A) + +import Relation.Binary.Construct.NonStrictToStrict _≈_ _≤_ as ToStrict +import Relation.Binary.Properties.Preorder preorder as PreorderProperties +open Eq using (_≉_) + +------------------------------------------------------------------------ +-- The _≥_ relation is also a poset. + +open PreorderProperties public + using () renaming + ( converse-isPreorder to ≥-isPreorder + ; converse-preorder to ≥-preorder + ) + +≥-isPartialOrder : IsPartialOrder _≈_ _≥_ +≥-isPartialOrder = record + { isPreorder = ≥-isPreorder + ; antisym = flip antisym + } + +≥-poset : Poset p₁ p₂ p₃ +≥-poset = record + { isPartialOrder = ≥-isPartialOrder + } + +open Poset ≥-poset public + using () renaming + ( refl to ≥-refl + ; reflexive to ≥-reflexive + ; trans to ≥-trans + ; antisym to ≥-antisym + ) + +------------------------------------------------------------------------ +-- Negated order + +≰-respˡ-≈ : _≰_ Respectsˡ _≈_ +≰-respˡ-≈ x≈y = _∘ ≤-respˡ-≈ (Eq.sym x≈y) + +≰-respʳ-≈ : _≰_ Respectsʳ _≈_ +≰-respʳ-≈ x≈y = _∘ ≤-respʳ-≈ (Eq.sym x≈y) + +------------------------------------------------------------------------ +-- Partial orders can be turned into strict partial orders + +infix 4 _<_ + +_<_ : Rel A _ +_<_ = ToStrict._<_ + +<-isStrictPartialOrder : IsStrictPartialOrder _≈_ _<_ +<-isStrictPartialOrder = ToStrict.<-isStrictPartialOrder isPartialOrder + +<-strictPartialOrder : StrictPartialOrder _ _ _ +<-strictPartialOrder = record + { isStrictPartialOrder = <-isStrictPartialOrder + } + +open StrictPartialOrder <-strictPartialOrder public + using (_≮_; <-resp-≈; <-respʳ-≈; <-respˡ-≈) + renaming + ( irrefl to <-irrefl + ; asym to <-asym + ; trans to <-trans + ) + +<⇒≉ : ∀ {x y} → x < y → x ≉ y +<⇒≉ = ToStrict.<⇒≉ + +≤∧≉⇒< : ∀ {x y} → x ≤ y → x ≉ y → x < y +≤∧≉⇒< = ToStrict.≤∧≉⇒< + +<⇒≱ : ∀ {x y} → x < y → y ≰ x +<⇒≱ = ToStrict.<⇒≱ antisym + +≤⇒≯ : ∀ {x y} → x ≤ y → y ≮ x +≤⇒≯ = ToStrict.≤⇒≯ antisym + +------------------------------------------------------------------------ +-- If ≤ is decidable then so is ≈ + +≤-dec⇒≈-dec : Decidable _≤_ → Decidable _≈_ +≤-dec⇒≈-dec _≤?_ x y with x ≤? y | y ≤? x +... | yes x≤y | yes y≤x = yes (antisym x≤y y≤x) +... | yes x≤y | no y≰x = no λ x≈y → contradiction (reflexive (Eq.sym x≈y)) y≰x +... | no x≰y | _ = no λ x≈y → contradiction (reflexive x≈y) x≰y + +≤-dec⇒isDecPartialOrder : Decidable _≤_ → IsDecPartialOrder _≈_ _≤_ +≤-dec⇒isDecPartialOrder _≤?_ = record + { isPartialOrder = isPartialOrder + ; _≟_ = ≤-dec⇒≈-dec _≤?_ + ; _≤?_ = _≤?_ + } -module Relation.Binary.Properties.Poset - {p₁ p₂ p₃} (P : Poset p₁ p₂ p₃) where +------------------------------------------------------------------------ +-- Other properties -open Poset P renaming (Carrier to A) +mono⇒cong : ∀ {f} → f Preserves _≤_ ⟶ _≤_ → f Preserves _≈_ ⟶ _≈_ +mono⇒cong = Consequences.mono⇒cong _≈_ _≈_ Eq.sym reflexive antisym -import Relation.Binary.Construct.NonStrictToStrict _≈_ _≤_ as ToStrict -import Relation.Binary.Properties.Preorder preorder as PreorderProperties -open Eq using (_≉_) - ------------------------------------------------------------------------- --- The _≥_ relation is also a poset. - -infix 4 _≥_ - -_≥_ : Rel A p₃ -x ≥ y = y ≤ x - -open PreorderProperties public - using () renaming - ( converse-isPreorder to ≥-isPreorder - ; converse-preorder to ≥-preorder - ) - -≥-isPartialOrder : IsPartialOrder _≈_ _≥_ -≥-isPartialOrder = record - { isPreorder = ≥-isPreorder - ; antisym = flip antisym - } - -≥-poset : Poset p₁ p₂ p₃ -≥-poset = record - { isPartialOrder = ≥-isPartialOrder - } - -open Poset ≥-poset public - using () renaming - ( refl to ≥-refl - ; reflexive to ≥-reflexive - ; trans to ≥-trans - ; antisym to ≥-antisym - ) - ------------------------------------------------------------------------- --- Negated order - -infix 4 _≰_ - -_≰_ : Rel A p₃ -x ≰ y = ¬ (x ≤ y) - -≰-respˡ-≈ : _≰_ Respectsˡ _≈_ -≰-respˡ-≈ x≈y = _∘ ≤-respˡ-≈ (Eq.sym x≈y) - -≰-respʳ-≈ : _≰_ Respectsʳ _≈_ -≰-respʳ-≈ x≈y = _∘ ≤-respʳ-≈ (Eq.sym x≈y) - ------------------------------------------------------------------------- --- Partial orders can be turned into strict partial orders - -infix 4 _<_ - -_<_ : Rel A _ -_<_ = ToStrict._<_ - -<-isStrictPartialOrder : IsStrictPartialOrder _≈_ _<_ -<-isStrictPartialOrder = ToStrict.<-isStrictPartialOrder isPartialOrder - -<-strictPartialOrder : StrictPartialOrder _ _ _ -<-strictPartialOrder = record - { isStrictPartialOrder = <-isStrictPartialOrder - } - -open StrictPartialOrder <-strictPartialOrder public - using ( <-resp-≈; <-respʳ-≈; <-respˡ-≈) - renaming - ( irrefl to <-irrefl - ; asym to <-asym - ; trans to <-trans - ) - -<⇒≉ : ∀ {x y} → x < y → x ≉ y -<⇒≉ = ToStrict.<⇒≉ - -≤∧≉⇒< : ∀ {x y} → x ≤ y → x ≉ y → x < y -≤∧≉⇒< = ToStrict.≤∧≉⇒< - -<⇒≱ : ∀ {x y} → x < y → ¬ (y ≤ x) -<⇒≱ = ToStrict.<⇒≱ antisym - -≤⇒≯ : ∀ {x y} → x ≤ y → ¬ (y < x) -≤⇒≯ = ToStrict.≤⇒≯ antisym - ------------------------------------------------------------------------- --- If ≤ is decidable then so is ≈ - -≤-dec⇒≈-dec : Decidable _≤_ → Decidable _≈_ -≤-dec⇒≈-dec _≤?_ x y with x ≤? y | y ≤? x -... | yes x≤y | yes y≤x = yes (antisym x≤y y≤x) -... | yes x≤y | no y≰x = no λ x≈y → contradiction (reflexive (Eq.sym x≈y)) y≰x -... | no x≰y | _ = no λ x≈y → contradiction (reflexive x≈y) x≰y - -≤-dec⇒isDecPartialOrder : Decidable _≤_ → IsDecPartialOrder _≈_ _≤_ -≤-dec⇒isDecPartialOrder _≤?_ = record - { isPartialOrder = isPartialOrder - ; _≟_ = ≤-dec⇒≈-dec _≤?_ - ; _≤?_ = _≤?_ - } - ------------------------------------------------------------------------- --- Other properties - -mono⇒cong : ∀ {f} → f Preserves _≤_ ⟶ _≤_ → f Preserves _≈_ ⟶ _≈_ -mono⇒cong = Consequences.mono⇒cong _≈_ _≈_ Eq.sym reflexive antisym - -antimono⇒cong : ∀ {f} → f Preserves _≤_ ⟶ _≥_ → f Preserves _≈_ ⟶ _≈_ -antimono⇒cong = Consequences.antimono⇒cong _≈_ _≈_ Eq.sym reflexive antisym +antimono⇒cong : ∀ {f} → f Preserves _≤_ ⟶ _≥_ → f Preserves _≈_ ⟶ _≈_ +antimono⇒cong = Consequences.antimono⇒cong _≈_ _≈_ Eq.sym reflexive antisym \ No newline at end of file diff --git a/Relation.Binary.Properties.Preorder.html b/Relation.Binary.Properties.Preorder.html index b1e67475..df186897 100644 --- a/Relation.Binary.Properties.Preorder.html +++ b/Relation.Binary.Properties.Preorder.html @@ -7,57 +7,59 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary +open import Relation.Binary.Bundles using (Preorder; Setoid) +open import Relation.Binary.Structures using (IsPreorder) -module Relation.Binary.Properties.Preorder - {p₁ p₂ p₃} (P : Preorder p₁ p₂ p₃) where +module Relation.Binary.Properties.Preorder + {p₁ p₂ p₃} (P : Preorder p₁ p₂ p₃) where -open import Function.Base -open import Data.Product as Prod -import Relation.Binary.Construct.Converse as Converse +open import Function.Base using (flip) +open import Data.Product.Base as Prod using (_×_; _,_; swap) +import Relation.Binary.Construct.Flip.EqAndOrd as EqAndOrd -open Preorder P +open Preorder P ------------------------------------------------------------------------- --- The inverse relation is also a preorder. -converse-isPreorder : IsPreorder _≈_ (flip _∼_) -converse-isPreorder = Converse.isPreorder isPreorder +------------------------------------------------------------------------ +-- The converse relation is also a preorder. -converse-preorder : Preorder p₁ p₂ p₃ -converse-preorder = Converse.preorder P +converse-isPreorder : IsPreorder _≈_ _≳_ +converse-isPreorder = EqAndOrd.isPreorder isPreorder ------------------------------------------------------------------------- --- For every preorder there is an induced equivalence +converse-preorder : Preorder p₁ p₂ p₃ +converse-preorder = EqAndOrd.preorder P -InducedEquivalence : Setoid _ _ -InducedEquivalence = record - { _≈_ = λ x y → x ∼ y × y ∼ x - ; isEquivalence = record - { refl = (refl , refl) - ; sym = swap - ; trans = Prod.zip trans (flip trans) - } - } +------------------------------------------------------------------------ +-- For every preorder there is an induced equivalence +InducedEquivalence : Setoid _ _ +InducedEquivalence = record + { _≈_ = λ x y → x ≲ y × x ≳ y + ; isEquivalence = record + { refl = (refl , refl) + ; sym = swap + ; trans = Prod.zip trans (flip trans) + } + } ------------------------------------------------------------------------- --- DEPRECATED NAMES ------------------------------------------------------------------------- --- Please use the new names as continuing support for the old names is --- not guaranteed. --- Version 2.0 +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. -invIsPreorder = converse-isPreorder -{-# WARNING_ON_USAGE invIsPreorder -"Warning: invIsPreorder was deprecated in v2.0. +-- Version 2.0 + +invIsPreorder = converse-isPreorder +{-# WARNING_ON_USAGE invIsPreorder +"Warning: invIsPreorder was deprecated in v2.0. Please use converse-isPreorder instead." -#-} -invPreorder = converse-preorder -{-# WARNING_ON_USAGE invPreorder -"Warning: invPreorder was deprecated in v2.0. +#-} +invPreorder = converse-preorder +{-# WARNING_ON_USAGE invPreorder +"Warning: invPreorder was deprecated in v2.0. Please use converse-preorder instead." -#-} +#-} \ No newline at end of file diff --git a/Relation.Binary.Properties.Setoid.html b/Relation.Binary.Properties.Setoid.html index 32ea5734..5dbe58a4 100644 --- a/Relation.Binary.Properties.Setoid.html +++ b/Relation.Binary.Properties.Setoid.html @@ -1,87 +1,89 @@ -Relation.Binary.Properties.Setoid
------------------------------------------------------------------------------
--- The Agda standard library
---
--- Additional properties for setoids
-------------------------------------------------------------------------------
-
-{-# OPTIONS --cubical-compatible --safe #-}
-
-open import Data.Product using (_,_)
-open import Function.Base using (_∘_; id; _$_; flip)
-open import Relation.Nullary.Negation using (¬_)
-open import Relation.Binary.PropositionalEquality.Core as P using (_≡_)
-open import Relation.Binary
-
-module Relation.Binary.Properties.Setoid {a ℓ} (S : Setoid a ℓ) where
-
-open Setoid S
-
-
-------------------------------------------------------------------------------
--- Every setoid is a preorder and partial order with respect to propositional
--- equality
-
-isPreorder : IsPreorder _≡_ _≈_
-isPreorder = record
-  { isEquivalence = record
-    { refl  = P.refl
-    ; sym   = P.sym
-    ; trans = P.trans
-    }
-  ; reflexive     = reflexive
-  ; trans         = trans
-  }
-
-≈-isPreorder : IsPreorder _≈_ _≈_
-≈-isPreorder = record
-  { isEquivalence = isEquivalence
-  ; reflexive     = id
-  ; trans         = trans
-  }
-
-≈-isPartialOrder : IsPartialOrder _≈_ _≈_
-≈-isPartialOrder = record
-  { isPreorder = ≈-isPreorder
-  ; antisym    = λ i≈j _ → i≈j
-  }
-
-preorder : Preorder a a ℓ
-preorder = record
-  { isPreorder = isPreorder
-  }
-
-≈-preorder : Preorder a ℓ ℓ
-≈-preorder = record
-  { isPreorder = ≈-isPreorder
-  }
-
-≈-poset : Poset a ℓ ℓ
-≈-poset = record
-  { isPartialOrder = ≈-isPartialOrder
-  }
-
-------------------------------------------------------------------------------
--- Properties of _≉_
-
-≉-sym :  Symmetric _≉_
-≉-sym x≉y =  x≉y ∘ sym
-
-≉-respˡ : _≉_ Respectsˡ _≈_
-≉-respˡ x≈x′ x≉y = x≉y ∘ trans x≈x′
-
-≉-respʳ : _≉_ Respectsʳ _≈_
-≉-respʳ y≈y′ x≉y x≈y′ = x≉y $ trans x≈y′ (sym y≈y′)
-
-≉-resp₂ : _≉_ Respects₂ _≈_
-≉-resp₂ = ≉-respʳ , ≉-respˡ
-
-------------------------------------------------------------------------------
--- Other properties
-
-respʳ-flip : _≈_ Respectsʳ (flip _≈_)
-respʳ-flip y≈z x≈z = trans x≈z (sym y≈z)
-
-respˡ-flip : _≈_ Respectsˡ (flip _≈_)
-respˡ-flip = trans
+Relation.Binary.Properties.Setoid
------------------------------------------------------------------------
+-- The Agda standard library
+--
+-- Additional properties for setoids
+------------------------------------------------------------------------
+
+{-# OPTIONS --cubical-compatible --safe #-}
+
+open import Data.Product.Base using (_,_)
+open import Function.Base using (_∘_; id; _$_; flip)
+open import Relation.Nullary.Negation.Core using (¬_)
+open import Relation.Binary.PropositionalEquality.Core as P using (_≡_)
+open import Relation.Binary.Bundles using (Setoid; Preorder; Poset)
+open import Relation.Binary.Definitions
+  using (Symmetric; _Respectsˡ_; _Respectsʳ_; _Respects₂_)
+open import Relation.Binary.Structures using (IsPreorder; IsPartialOrder)
+
+module Relation.Binary.Properties.Setoid {a ℓ} (S : Setoid a ℓ) where
+
+open Setoid S
+
+------------------------------------------------------------------------
+-- Every setoid is a preorder and partial order with respect to
+-- propositional equality
+
+isPreorder : IsPreorder _≡_ _≈_
+isPreorder = record
+  { isEquivalence = record
+    { refl  = P.refl
+    ; sym   = P.sym
+    ; trans = P.trans
+    }
+  ; reflexive     = reflexive
+  ; trans         = trans
+  }
+
+≈-isPreorder : IsPreorder _≈_ _≈_
+≈-isPreorder = record
+  { isEquivalence = isEquivalence
+  ; reflexive     = id
+  ; trans         = trans
+  }
+
+≈-isPartialOrder : IsPartialOrder _≈_ _≈_
+≈-isPartialOrder = record
+  { isPreorder = ≈-isPreorder
+  ; antisym    = λ i≈j _ → i≈j
+  }
+
+preorder : Preorder a a ℓ
+preorder = record
+  { isPreorder = isPreorder
+  }
+
+≈-preorder : Preorder a ℓ ℓ
+≈-preorder = record
+  { isPreorder = ≈-isPreorder
+  }
+
+≈-poset : Poset a ℓ ℓ
+≈-poset = record
+  { isPartialOrder = ≈-isPartialOrder
+  }
+
+------------------------------------------------------------------------
+-- Properties of _≉_
+
+≉-sym :  Symmetric _≉_
+≉-sym x≉y =  x≉y ∘ sym
+
+≉-respˡ : _≉_ Respectsˡ _≈_
+≉-respˡ x≈x′ x≉y = x≉y ∘ trans x≈x′
+
+≉-respʳ : _≉_ Respectsʳ _≈_
+≉-respʳ y≈y′ x≉y x≈y′ = x≉y $ trans x≈y′ (sym y≈y′)
+
+≉-resp₂ : _≉_ Respects₂ _≈_
+≉-resp₂ = ≉-respʳ , ≉-respˡ
+
+------------------------------------------------------------------------
+-- Other properties
+
+respʳ-flip : _≈_ Respectsʳ (flip _≈_)
+respʳ-flip y≈z x≈z = trans x≈z (sym y≈z)
+
+respˡ-flip : _≈_ Respectsˡ (flip _≈_)
+respˡ-flip = trans
 

\ No newline at end of file
diff --git a/Relation.Binary.Properties.TotalOrder.html b/Relation.Binary.Properties.TotalOrder.html
index 8fb4f425..c7d90e6b 100644
--- a/Relation.Binary.Properties.TotalOrder.html
+++ b/Relation.Binary.Properties.TotalOrder.html
@@ -7,98 +7,96 @@
 
 {-# OPTIONS --cubical-compatible --safe #-}
 
-open import Relation.Binary
-
-module Relation.Binary.Properties.TotalOrder
-  {t₁ t₂ t₃} (T : TotalOrder t₁ t₂ t₃) where
-
-open TotalOrder T
-
-open import Data.Product using (proj₁)
-open import Data.Sum.Base using (inj₁; inj₂)
-import Relation.Binary.Construct.Converse as Converse
-import Relation.Binary.Construct.NonStrictToStrict _≈_ _≤_ as ToStrict
-import Relation.Binary.Properties.Poset poset as PosetProperties
-open import Relation.Binary.Consequences
-open import Relation.Nullary.Negation using (¬_)
-open import Relation.Nullary.Negation using (contradiction)
-
-------------------------------------------------------------------------
--- Total orders are almost decidable total orders
-
-decTotalOrder : Decidable _≈_ → DecTotalOrder _ _ _
-decTotalOrder ≟ = record
-  { isDecTotalOrder = record
-    { isTotalOrder = isTotalOrder
-    ; _≟_          = ≟
-    ; _≤?_         = total∧dec⇒dec reflexive antisym total ≟
-    }
-  }
-
-------------------------------------------------------------------------
--- _≥_ - the flipped relation is also a total order
-
-open PosetProperties public
-  using
-  ( _≥_
-  ; ≥-refl
-  ; ≥-reflexive
-  ; ≥-trans
-  ; ≥-antisym
-  ; ≥-isPreorder
-  ; ≥-isPartialOrder
-  ; ≥-preorder
-  ; ≥-poset
-  )
-
-≥-isTotalOrder : IsTotalOrder _≈_ _≥_
-≥-isTotalOrder = Converse.isTotalOrder isTotalOrder
-
-≥-totalOrder : TotalOrder _ _ _
-≥-totalOrder = record
-  { isTotalOrder = ≥-isTotalOrder
-  }
-
-open TotalOrder ≥-totalOrder public
-  using () renaming (total to ≥-total)
-
-------------------------------------------------------------------------
--- _<_ - the strict version is a strict partial order
-
--- Note that total orders can NOT be turned into strict total orders as
--- in order to distinguish between the _≤_ and _<_ cases we must have
--- decidable equality _≈_.
-
-open PosetProperties public
-  using
-  ( _<_
-  ; <-resp-≈
-  ; <-respʳ-≈
-  ; <-respˡ-≈
-  ; <-irrefl
-  ; <-asym
-  ; <-trans
-  ; <-isStrictPartialOrder
-  ; <-strictPartialOrder
-  ; <⇒≉
-  ; ≤∧≉⇒<
-  ; <⇒≱
-  ; ≤⇒≯
-  )
-
-------------------------------------------------------------------------
--- _≰_ - the negated order
-
-open PosetProperties public
-  using
-  ( _≰_
-  ; ≰-respʳ-≈
-  ; ≰-respˡ-≈
-  )
-
-≰⇒> : ∀ {x y} → x ≰ y → y < x
-≰⇒> = ToStrict.≰⇒> Eq.sym reflexive total
-
-≰⇒≥ : ∀ {x y} → x ≰ y → y ≤ x
-≰⇒≥ x≰y = proj₁ (≰⇒> x≰y)
+open import Relation.Binary.Bundles using (TotalOrder; DecTotalOrder)
+open import Relation.Binary.Definitions using (Decidable)
+open import Relation.Binary.Structures using (IsTotalOrder)
+
+module Relation.Binary.Properties.TotalOrder
+  {t₁ t₂ t₃} (T : TotalOrder t₁ t₂ t₃) where
+
+open TotalOrder T
+
+open import Data.Product.Base using (proj₁)
+open import Data.Sum.Base using (inj₁; inj₂)
+import Relation.Binary.Construct.Flip.EqAndOrd as EqAndOrd
+import Relation.Binary.Construct.NonStrictToStrict _≈_ _≤_ as ToStrict
+import Relation.Binary.Properties.Poset poset as PosetProperties
+open import Relation.Binary.Consequences
+
+------------------------------------------------------------------------
+-- Total orders are almost decidable total orders
+
+decTotalOrder : Decidable _≈_ → DecTotalOrder _ _ _
+decTotalOrder ≟ = record
+  { isDecTotalOrder = record
+    { isTotalOrder = isTotalOrder
+    ; _≟_          = ≟
+    ; _≤?_         = total∧dec⇒dec reflexive antisym total ≟
+    }
+  }
+
+------------------------------------------------------------------------
+-- _≥_ - the flipped relation is also a total order
+
+open PosetProperties public
+  using
+  ( ≥-refl
+  ; ≥-reflexive
+  ; ≥-trans
+  ; ≥-antisym
+  ; ≥-isPreorder
+  ; ≥-isPartialOrder
+  ; ≥-preorder
+  ; ≥-poset
+  )
+
+≥-isTotalOrder : IsTotalOrder _≈_ _≥_
+≥-isTotalOrder = EqAndOrd.isTotalOrder isTotalOrder
+
+≥-totalOrder : TotalOrder _ _ _
+≥-totalOrder = record
+  { isTotalOrder = ≥-isTotalOrder
+  }
+
+open TotalOrder ≥-totalOrder public
+  using () renaming (total to ≥-total)
+
+------------------------------------------------------------------------
+-- _<_ - the strict version is a strict partial order
+
+-- Note that total orders can NOT be turned into strict total orders as
+-- in order to distinguish between the _≤_ and _<_ cases we must have
+-- decidable equality _≈_.
+
+open PosetProperties public
+  using
+  ( _<_
+  ; <-resp-≈
+  ; <-respʳ-≈
+  ; <-respˡ-≈
+  ; <-irrefl
+  ; <-asym
+  ; <-trans
+  ; <-isStrictPartialOrder
+  ; <-strictPartialOrder
+  ; <⇒≉
+  ; ≤∧≉⇒<
+  ; <⇒≱
+  ; ≤⇒≯
+  )
+
+------------------------------------------------------------------------
+-- _≰_ - the negated order
+
+open PosetProperties public
+  using
+  ( ≰-respʳ-≈
+  ; ≰-respˡ-≈
+  )
+
+≰⇒> : ∀ {x y} → x ≰ y → y < x
+≰⇒> = ToStrict.≰⇒> Eq.sym reflexive total
+
+≰⇒≥ : ∀ {x y} → x ≰ y → y ≤ x
+≰⇒≥ x≰y = proj₁ (≰⇒> x≰y)
\ No newline at end of file diff --git a/Relation.Binary.PropositionalEquality.Algebra.html b/Relation.Binary.PropositionalEquality.Algebra.html index 9a8abe15..94134aea 100644 --- a/Relation.Binary.PropositionalEquality.Algebra.html +++ b/Relation.Binary.PropositionalEquality.Algebra.html @@ -22,14 +22,14 @@ ------------------------------------------------------------------------ -- Any operation forms a magma over _≡_ -isMagma : (_∙_ : Op₂ A) → IsMagma _≡_ _∙_ +isMagma : (_∙_ : Op₂ A) → IsMagma _≡_ _∙_ isMagma _∙_ = record - { isEquivalence = isEquivalence - ; ∙-cong = cong₂ _∙_ + { isEquivalence = isEquivalence + ; ∙-cong = cong₂ _∙_ } -magma : (_∙_ : Op₂ A) → Magma _ _ +magma : (_∙_ : Op₂ A) → Magma _ _ magma _∙_ = record - { isMagma = isMagma _∙_ + { isMagma = isMagma _∙_ } \ No newline at end of file diff --git a/Relation.Binary.PropositionalEquality.Core.html b/Relation.Binary.PropositionalEquality.Core.html index c496cff8..cddaa8f9 100644 --- a/Relation.Binary.PropositionalEquality.Core.html +++ b/Relation.Binary.PropositionalEquality.Core.html @@ -12,116 +12,84 @@ module Relation.Binary.PropositionalEquality.Core where -open import Data.Product using (_,_) -open import Function.Base using (_∘_) -open import Level -open import Relation.Binary.Core -open import Relation.Binary.Definitions -open import Relation.Nullary.Negation.Core using (¬_) +open import Data.Product.Base using (_,_) +open import Function.Base using (_∘_) +open import Level +open import Relation.Binary.Core +open import Relation.Binary.Definitions +open import Relation.Nullary.Negation.Core using (¬_) -private - variable - a b ℓ : Level - A B C : Set a +private + variable + a b ℓ : Level + A B C : Set a ------------------------------------------------------------------------- --- Propositional equality +------------------------------------------------------------------------ +-- Propositional equality -open import Agda.Builtin.Equality public +open import Agda.Builtin.Equality public -infix 4 _≢_ -_≢_ : {A : Set a} → Rel A a -x ≢ y = ¬ x ≡ y +infix 4 _≢_ +_≢_ : {A : Set a} → Rel A a +x ≢ y = ¬ x ≡ y ------------------------------------------------------------------------- --- A variant of `refl` where the argument is explicit +------------------------------------------------------------------------ +-- A variant of `refl` where the argument is explicit -pattern erefl x = refl {x = x} +pattern erefl x = refl {x = x} ------------------------------------------------------------------------- --- Congruence lemmas +------------------------------------------------------------------------ +-- Congruence lemmas -cong : ∀ (f : A → B) {x y} → x ≡ y → f x ≡ f y -cong f refl = refl +cong : ∀ (f : A → B) {x y} → x ≡ y → f x ≡ f y +cong f refl = refl -cong′ : ∀ {f : A → B} x → f x ≡ f x -cong′ _ = refl +cong′ : ∀ {f : A → B} x → f x ≡ f x +cong′ _ = refl -icong : ∀ {f : A → B} {x y} → x ≡ y → f x ≡ f y -icong = cong _ +icong : ∀ {f : A → B} {x y} → x ≡ y → f x ≡ f y +icong = cong _ -icong′ : ∀ {f : A → B} x → f x ≡ f x -icong′ _ = refl +icong′ : ∀ {f : A → B} x → f x ≡ f x +icong′ _ = refl -cong₂ : ∀ (f : A → B → C) {x y u v} → x ≡ y → u ≡ v → f x u ≡ f y v -cong₂ f refl refl = refl +cong₂ : ∀ (f : A → B → C) {x y u v} → x ≡ y → u ≡ v → f x u ≡ f y v +cong₂ f refl refl = refl -cong-app : ∀ {A : Set a} {B : A → Set b} {f g : (x : A) → B x} → - f ≡ g → (x : A) → f x ≡ g x -cong-app refl x = refl +cong-app : ∀ {A : Set a} {B : A → Set b} {f g : (x : A) → B x} → + f ≡ g → (x : A) → f x ≡ g x +cong-app refl x = refl ------------------------------------------------------------------------- --- Properties of _≡_ +------------------------------------------------------------------------ +-- Properties of _≡_ -sym : Symmetric {A = A} _≡_ -sym refl = refl +sym : Symmetric {A = A} _≡_ +sym refl = refl -trans : Transitive {A = A} _≡_ -trans refl eq = eq +trans : Transitive {A = A} _≡_ +trans refl eq = eq -subst : Substitutive {A = A} _≡_ ℓ -subst P refl p = p +subst : Substitutive {A = A} _≡_ ℓ +subst P refl p = p -subst₂ : ∀ (_∼_ : REL A B ℓ) {x y u v} → x ≡ y → u ≡ v → x ∼ u → y ∼ v -subst₂ _ refl refl p = p +subst₂ : ∀ (_∼_ : REL A B ℓ) {x y u v} → x ≡ y → u ≡ v → x ∼ u → y ∼ v +subst₂ _ refl refl p = p -resp : ∀ (P : A → Set ℓ) → P Respects _≡_ -resp P refl p = p +resp : ∀ (P : A → Set ℓ) → P Respects _≡_ +resp P refl p = p -respˡ : ∀ (∼ : Rel A ℓ) → ∼ Respectsˡ _≡_ -respˡ _∼_ refl x∼y = x∼y +respˡ : ∀ (∼ : Rel A ℓ) → ∼ Respectsˡ _≡_ +respˡ _∼_ refl x∼y = x∼y -respʳ : ∀ (∼ : Rel A ℓ) → ∼ Respectsʳ _≡_ -respʳ _∼_ refl x∼y = x∼y +respʳ : ∀ (∼ : Rel A ℓ) → ∼ Respectsʳ _≡_ +respʳ _∼_ refl x∼y = x∼y -resp₂ : ∀ (∼ : Rel A ℓ) → ∼ Respects₂ _≡_ -resp₂ _∼_ = respʳ _∼_ , respˡ _∼_ +resp₂ : ∀ (∼ : Rel A ℓ) → ∼ Respects₂ _≡_ +resp₂ _∼_ = respʳ _∼_ , respˡ _∼_ ------------------------------------------------------------------------- --- Properties of _≢_ +------------------------------------------------------------------------ +-- Properties of _≢_ -≢-sym : Symmetric {A = A} _≢_ -≢-sym x≢y = x≢y ∘ sym - ------------------------------------------------------------------------- --- Convenient syntax for equational reasoning - --- This is a special instance of `Relation.Binary.Reasoning.Setoid`. --- Rather than instantiating the latter with (setoid A), we reimplement --- equation chains from scratch since then goals are printed much more --- readably. - -module ≡-Reasoning {A : Set a} where - - infix 3 _∎ - infixr 2 _≡⟨⟩_ step-≡ step-≡˘ - infix 1 begin_ - - begin_ : ∀{x y : A} → x ≡ y → x ≡ y - begin_ x≡y = x≡y - - _≡⟨⟩_ : ∀ (x {y} : A) → x ≡ y → x ≡ y - _ ≡⟨⟩ x≡y = x≡y - - step-≡ : ∀ (x {y z} : A) → y ≡ z → x ≡ y → x ≡ z - step-≡ _ y≡z x≡y = trans x≡y y≡z - - step-≡˘ : ∀ (x {y z} : A) → y ≡ z → y ≡ x → x ≡ z - step-≡˘ _ y≡z y≡x = trans (sym y≡x) y≡z - - _∎ : ∀ (x : A) → x ≡ x - _∎ _ = refl - - syntax step-≡ x y≡z x≡y = x ≡⟨ x≡y ⟩ y≡z - syntax step-≡˘ x y≡z y≡x = x ≡˘⟨ y≡x ⟩ y≡z +≢-sym : Symmetric {A = A} _≢_ +≢-sym x≢y = x≢y ∘ sym \ No newline at end of file diff --git a/Relation.Binary.PropositionalEquality.Properties.html b/Relation.Binary.PropositionalEquality.Properties.html index 1fd45a36..c127ebaa 100644 --- a/Relation.Binary.PropositionalEquality.Properties.html +++ b/Relation.Binary.PropositionalEquality.Properties.html @@ -4,9 +4,9 @@ -- -- Propositional equality -- --- This file contains some core properies of propositional equality which --- are re-exported by Relation.Binary.PropositionalEquality. They are --- ``equality rearrangement'' lemmas. +-- This file contains some core properies of propositional equality +-- which are re-exported by Relation.Binary.PropositionalEquality. They +-- are ``equality rearrangement'' lemmas. ------------------------------------------------------------------------ {-# OPTIONS --cubical-compatible --safe #-} @@ -14,174 +14,194 @@ module Relation.Binary.PropositionalEquality.Properties where open import Function.Base using (id; _∘_) -open import Level -open import Relation.Binary -import Relation.Binary.Properties.Setoid as Setoid -open import Relation.Binary.PropositionalEquality.Core -open import Relation.Unary using (Pred) +open import Level using (Level) +open import Relation.Binary.Bundles + using (Setoid; DecSetoid; Preorder; Poset) +open import Relation.Binary.Structures + using (IsEquivalence; IsDecEquivalence; IsPreorder; IsPartialOrder) +open import Relation.Binary.Definitions + using (Decidable; DecidableEquality) +import Relation.Binary.Properties.Setoid as Setoid +open import Relation.Binary.PropositionalEquality.Core +open import Relation.Unary using (Pred) +open import Relation.Binary.Reasoning.Syntax + -private - variable - a b c p : Level - A B C : Set a +private + variable + a b c p : Level + A B C : Set a ------------------------------------------------------------------------- --- Standard eliminator for the propositional equality type - -J : {A : Set a} {x : A} (B : (y : A) → x ≡ y → Set b) - {y : A} (p : x ≡ y) → B x refl → B y p -J B refl b = b - ------------------------------------------------------------------------- --- Binary and/or dependent versions of standard operations on equality - -dcong : ∀ {A : Set a} {B : A → Set b} (f : (x : A) → B x) {x y} - → (p : x ≡ y) → subst B p (f x) ≡ f y -dcong f refl = refl - -dcong₂ : ∀ {A : Set a} {B : A → Set b} {C : Set c} - (f : (x : A) → B x → C) {x₁ x₂ y₁ y₂} - → (p : x₁ ≡ x₂) → subst B p y₁ ≡ y₂ - → f x₁ y₁ ≡ f x₂ y₂ -dcong₂ f refl refl = refl - -dsubst₂ : ∀ {A : Set a} {B : A → Set b} (C : (x : A) → B x → Set c) - {x₁ x₂ y₁ y₂} (p : x₁ ≡ x₂) → subst B p y₁ ≡ y₂ - → C x₁ y₁ → C x₂ y₂ -dsubst₂ C refl refl c = c - -ddcong₂ : ∀ {A : Set a} {B : A → Set b} {C : (x : A) → B x → Set c} - (f : (x : A) (y : B x) → C x y) {x₁ x₂ y₁ y₂} - (p : x₁ ≡ x₂) (q : subst B p y₁ ≡ y₂) - → dsubst₂ C p q (f x₁ y₁) ≡ f x₂ y₂ -ddcong₂ f refl refl = refl - ------------------------------------------------------------------------- --- Various equality rearrangement lemmas - -trans-reflʳ : ∀ {x y : A} (p : x ≡ y) → trans p refl ≡ p -trans-reflʳ refl = refl - -trans-assoc : ∀ {x y z u : A} (p : x ≡ y) {q : y ≡ z} {r : z ≡ u} → - trans (trans p q) r ≡ trans p (trans q r) -trans-assoc refl = refl - -trans-symˡ : ∀ {x y : A} (p : x ≡ y) → trans (sym p) p ≡ refl -trans-symˡ refl = refl - -trans-symʳ : ∀ {x y : A} (p : x ≡ y) → trans p (sym p) ≡ refl -trans-symʳ refl = refl - -trans-injectiveˡ : ∀ {x y z : A} {p₁ p₂ : x ≡ y} (q : y ≡ z) → - trans p₁ q ≡ trans p₂ q → p₁ ≡ p₂ -trans-injectiveˡ refl = subst₂ _≡_ (trans-reflʳ _) (trans-reflʳ _) - -trans-injectiveʳ : ∀ {x y z : A} (p : x ≡ y) {q₁ q₂ : y ≡ z} → - trans p q₁ ≡ trans p q₂ → q₁ ≡ q₂ -trans-injectiveʳ refl eq = eq - -cong-id : ∀ {x y : A} (p : x ≡ y) → cong id p ≡ p -cong-id refl = refl - -cong-∘ : ∀ {x y : A} {f : B → C} {g : A → B} (p : x ≡ y) → - cong (f ∘ g) p ≡ cong f (cong g p) -cong-∘ refl = refl - -sym-cong : ∀ {x y : A} {f : A → B} (p : x ≡ y) → sym (cong f p) ≡ cong f (sym p) -sym-cong refl = refl - -trans-cong : ∀ {x y z : A} {f : A → B} (p : x ≡ y) {q : y ≡ z} → - trans (cong f p) (cong f q) ≡ cong f (trans p q) -trans-cong refl = refl - -cong₂-reflˡ : ∀ {_∙_ : A → B → C} {x u v} → (p : u ≡ v) → - cong₂ _∙_ refl p ≡ cong (x ∙_) p -cong₂-reflˡ refl = refl - -cong₂-reflʳ : ∀ {_∙_ : A → B → C} {x y u} → (p : x ≡ y) → - cong₂ _∙_ p refl ≡ cong (_∙ u) p -cong₂-reflʳ refl = refl - -module _ {P : Pred A p} {x y : A} where - - subst-injective : ∀ (x≡y : x ≡ y) {p q : P x} → - subst P x≡y p ≡ subst P x≡y q → p ≡ q - subst-injective refl p≡q = p≡q - - subst-subst : ∀ {z} (x≡y : x ≡ y) {y≡z : y ≡ z} {p : P x} → - subst P y≡z (subst P x≡y p) ≡ subst P (trans x≡y y≡z) p - subst-subst refl = refl - - subst-subst-sym : (x≡y : x ≡ y) {p : P y} → - subst P x≡y (subst P (sym x≡y) p) ≡ p - subst-subst-sym refl = refl - - subst-sym-subst : (x≡y : x ≡ y) {p : P x} → - subst P (sym x≡y) (subst P x≡y p) ≡ p - subst-sym-subst refl = refl - -subst-∘ : ∀ {x y : A} {P : Pred B p} {f : A → B} - (x≡y : x ≡ y) {p : P (f x)} → - subst (P ∘ f) x≡y p ≡ subst P (cong f x≡y) p -subst-∘ refl = refl - --- Lemma 2.3.11 in the HoTT book, and `transport_map` in the UniMath --- library -subst-application′ : ∀ {a b₁ b₂} {A : Set a} - (B₁ : A → Set b₁) {B₂ : A → Set b₂} - {x₁ x₂ : A} {y : B₁ x₁} - (g : ∀ x → B₁ x → B₂ x) (eq : x₁ ≡ x₂) → - subst B₂ eq (g x₁ y) ≡ g x₂ (subst B₁ eq y) -subst-application′ _ _ refl = refl - -subst-application : ∀ {a₁ a₂ b₁ b₂} {A₁ : Set a₁} {A₂ : Set a₂} - (B₁ : A₁ → Set b₁) {B₂ : A₂ → Set b₂} - {f : A₂ → A₁} {x₁ x₂ : A₂} {y : B₁ (f x₁)} - (g : ∀ x → B₁ (f x) → B₂ x) (eq : x₁ ≡ x₂) → - subst B₂ eq (g x₁ y) ≡ g x₂ (subst B₁ (cong f eq) y) -subst-application _ _ refl = refl - ------------------------------------------------------------------------- --- Structure of equality as a binary relation - -isEquivalence : IsEquivalence {A = A} _≡_ -isEquivalence = record - { refl = refl - ; sym = sym - ; trans = trans - } - -isDecEquivalence : Decidable _≡_ → IsDecEquivalence {A = A} _≡_ -isDecEquivalence _≟_ = record - { isEquivalence = isEquivalence - ; _≟_ = _≟_ - } - -setoid : Set a → Setoid _ _ -setoid A = record - { Carrier = A - ; _≈_ = _≡_ - ; isEquivalence = isEquivalence - } - -decSetoid : DecidableEquality A → DecSetoid _ _ -decSetoid _≟_ = record - { _≈_ = _≡_ - ; isDecEquivalence = isDecEquivalence _≟_ - } - ------------------------------------------------------------------------- --- Bundles for equality as a binary relation - -isPreorder : IsPreorder {A = A} _≡_ _≡_ -isPreorder = Setoid.≈-isPreorder (setoid _) - -isPartialOrder : IsPartialOrder {A = A} _≡_ _≡_ -isPartialOrder = Setoid.≈-isPartialOrder (setoid _) - -preorder : Set a → Preorder _ _ _ -preorder A = Setoid.≈-preorder (setoid A) - -poset : Set a → Poset _ _ _ -poset A = Setoid.≈-poset (setoid A) +------------------------------------------------------------------------ +-- Standard eliminator for the propositional equality type + +J : {A : Set a} {x : A} (B : (y : A) → x ≡ y → Set b) + {y : A} (p : x ≡ y) → B x refl → B y p +J B refl b = b + +------------------------------------------------------------------------ +-- Binary and/or dependent versions of standard operations on equality + +dcong : ∀ {A : Set a} {B : A → Set b} (f : (x : A) → B x) {x y} + → (p : x ≡ y) → subst B p (f x) ≡ f y +dcong f refl = refl + +dcong₂ : ∀ {A : Set a} {B : A → Set b} {C : Set c} + (f : (x : A) → B x → C) {x₁ x₂ y₁ y₂} + → (p : x₁ ≡ x₂) → subst B p y₁ ≡ y₂ + → f x₁ y₁ ≡ f x₂ y₂ +dcong₂ f refl refl = refl + +dsubst₂ : ∀ {A : Set a} {B : A → Set b} (C : (x : A) → B x → Set c) + {x₁ x₂ y₁ y₂} (p : x₁ ≡ x₂) → subst B p y₁ ≡ y₂ + → C x₁ y₁ → C x₂ y₂ +dsubst₂ C refl refl c = c + +ddcong₂ : ∀ {A : Set a} {B : A → Set b} {C : (x : A) → B x → Set c} + (f : (x : A) (y : B x) → C x y) {x₁ x₂ y₁ y₂} + (p : x₁ ≡ x₂) (q : subst B p y₁ ≡ y₂) + → dsubst₂ C p q (f x₁ y₁) ≡ f x₂ y₂ +ddcong₂ f refl refl = refl + +------------------------------------------------------------------------ +-- Various equality rearrangement lemmas + +trans-reflʳ : ∀ {x y : A} (p : x ≡ y) → trans p refl ≡ p +trans-reflʳ refl = refl + +trans-assoc : ∀ {x y z u : A} (p : x ≡ y) {q : y ≡ z} {r : z ≡ u} → + trans (trans p q) r ≡ trans p (trans q r) +trans-assoc refl = refl + +trans-symˡ : ∀ {x y : A} (p : x ≡ y) → trans (sym p) p ≡ refl +trans-symˡ refl = refl + +trans-symʳ : ∀ {x y : A} (p : x ≡ y) → trans p (sym p) ≡ refl +trans-symʳ refl = refl + +trans-injectiveˡ : ∀ {x y z : A} {p₁ p₂ : x ≡ y} (q : y ≡ z) → + trans p₁ q ≡ trans p₂ q → p₁ ≡ p₂ +trans-injectiveˡ refl = subst₂ _≡_ (trans-reflʳ _) (trans-reflʳ _) + +trans-injectiveʳ : ∀ {x y z : A} (p : x ≡ y) {q₁ q₂ : y ≡ z} → + trans p q₁ ≡ trans p q₂ → q₁ ≡ q₂ +trans-injectiveʳ refl eq = eq + +cong-id : ∀ {x y : A} (p : x ≡ y) → cong id p ≡ p +cong-id refl = refl + +cong-∘ : ∀ {x y : A} {f : B → C} {g : A → B} (p : x ≡ y) → + cong (f ∘ g) p ≡ cong f (cong g p) +cong-∘ refl = refl + +sym-cong : ∀ {x y : A} {f : A → B} (p : x ≡ y) → sym (cong f p) ≡ cong f (sym p) +sym-cong refl = refl + +trans-cong : ∀ {x y z : A} {f : A → B} (p : x ≡ y) {q : y ≡ z} → + trans (cong f p) (cong f q) ≡ cong f (trans p q) +trans-cong refl = refl + +cong₂-reflˡ : ∀ {_∙_ : A → B → C} {x u v} → (p : u ≡ v) → + cong₂ _∙_ refl p ≡ cong (x ∙_) p +cong₂-reflˡ refl = refl + +cong₂-reflʳ : ∀ {_∙_ : A → B → C} {x y u} → (p : x ≡ y) → + cong₂ _∙_ p refl ≡ cong (_∙ u) p +cong₂-reflʳ refl = refl + +module _ {P : Pred A p} {x y : A} where + + subst-injective : ∀ (x≡y : x ≡ y) {p q : P x} → + subst P x≡y p ≡ subst P x≡y q → p ≡ q + subst-injective refl p≡q = p≡q + + subst-subst : ∀ {z} (x≡y : x ≡ y) {y≡z : y ≡ z} {p : P x} → + subst P y≡z (subst P x≡y p) ≡ subst P (trans x≡y y≡z) p + subst-subst refl = refl + + subst-subst-sym : (x≡y : x ≡ y) {p : P y} → + subst P x≡y (subst P (sym x≡y) p) ≡ p + subst-subst-sym refl = refl + + subst-sym-subst : (x≡y : x ≡ y) {p : P x} → + subst P (sym x≡y) (subst P x≡y p) ≡ p + subst-sym-subst refl = refl + +subst-∘ : ∀ {x y : A} {P : Pred B p} {f : A → B} + (x≡y : x ≡ y) {p : P (f x)} → + subst (P ∘ f) x≡y p ≡ subst P (cong f x≡y) p +subst-∘ refl = refl + +-- Lemma 2.3.11 in the HoTT book, and `transport_map` in the UniMath +-- library +subst-application′ : ∀ {a b₁ b₂} {A : Set a} + (B₁ : A → Set b₁) {B₂ : A → Set b₂} + {x₁ x₂ : A} {y : B₁ x₁} + (g : ∀ x → B₁ x → B₂ x) (eq : x₁ ≡ x₂) → + subst B₂ eq (g x₁ y) ≡ g x₂ (subst B₁ eq y) +subst-application′ _ _ refl = refl + +subst-application : ∀ {a₁ a₂ b₁ b₂} {A₁ : Set a₁} {A₂ : Set a₂} + (B₁ : A₁ → Set b₁) {B₂ : A₂ → Set b₂} + {f : A₂ → A₁} {x₁ x₂ : A₂} {y : B₁ (f x₁)} + (g : ∀ x → B₁ (f x) → B₂ x) (eq : x₁ ≡ x₂) → + subst B₂ eq (g x₁ y) ≡ g x₂ (subst B₁ (cong f eq) y) +subst-application _ _ refl = refl + +------------------------------------------------------------------------ +-- Structure of equality as a binary relation + +isEquivalence : IsEquivalence {A = A} _≡_ +isEquivalence = record + { refl = refl + ; sym = sym + ; trans = trans + } + +isDecEquivalence : Decidable _≡_ → IsDecEquivalence {A = A} _≡_ +isDecEquivalence _≟_ = record + { isEquivalence = isEquivalence + ; _≟_ = _≟_ + } + +setoid : Set a → Setoid _ _ +setoid A = record + { Carrier = A + ; _≈_ = _≡_ + ; isEquivalence = isEquivalence + } + +decSetoid : DecidableEquality A → DecSetoid _ _ +decSetoid _≟_ = record + { _≈_ = _≡_ + ; isDecEquivalence = isDecEquivalence _≟_ + } + +------------------------------------------------------------------------ +-- Bundles for equality as a binary relation + +isPreorder : IsPreorder {A = A} _≡_ _≡_ +isPreorder = Setoid.≈-isPreorder (setoid _) + +isPartialOrder : IsPartialOrder {A = A} _≡_ _≡_ +isPartialOrder = Setoid.≈-isPartialOrder (setoid _) + +preorder : Set a → Preorder _ _ _ +preorder A = Setoid.≈-preorder (setoid A) + +poset : Set a → Poset _ _ _ +poset A = Setoid.≈-poset (setoid A) + +------------------------------------------------------------------------ +-- Reasoning + +-- This is a special instance of `Relation.Binary.Reasoning.Setoid`. +-- Rather than instantiating the latter with (setoid A), we reimplement +-- equation chains from scratch since then goals are printed much more +-- readably. +module ≡-Reasoning {a} {A : Set a} where + + open begin-syntax {A = A} _≡_ id public + open ≡-syntax {A = A} _≡_ trans public + open end-syntax {A = A} _≡_ refl public \ No newline at end of file diff --git a/Relation.Binary.PropositionalEquality.html b/Relation.Binary.PropositionalEquality.html index d6f7aa09..3b5d898e 100644 --- a/Relation.Binary.PropositionalEquality.html +++ b/Relation.Binary.PropositionalEquality.html @@ -9,116 +9,131 @@ module Relation.Binary.PropositionalEquality where -import Axiom.Extensionality.Propositional as Ext -open import Axiom.UniquenessOfIdentityProofs -open import Function.Base using (id; _∘_) -open import Function.Equality using (Π; _⟶_; ≡-setoid) -open import Level using (Level; _⊔_) -open import Data.Product using (∃) - -open import Relation.Nullary.Decidable using (yes; no) -open import Relation.Nullary.Decidable -open import Relation.Binary -open import Relation.Binary.Indexed.Heterogeneous - using (IndexedSetoid) -import Relation.Binary.Indexed.Heterogeneous.Construct.Trivial - as Trivial - -private - variable - a b c ℓ p : Level - A : Set a - B : Set b - C : Set c - ------------------------------------------------------------------------- --- Re-export contents modules that make up the parts - -open import Relation.Binary.PropositionalEquality.Core public -open import Relation.Binary.PropositionalEquality.Properties public -open import Relation.Binary.PropositionalEquality.Algebra public - ------------------------------------------------------------------------- --- Pointwise equality - -infix 4 _≗_ - -_→-setoid_ : ∀ (A : Set a) (B : Set b) → Setoid _ _ -A →-setoid B = ≡-setoid A (Trivial.indexedSetoid (setoid B)) - -_≗_ : (f g : A → B) → Set _ -_≗_ {A = A} {B = B} = Setoid._≈_ (A →-setoid B) - -:→-to-Π : ∀ {A : Set a} {B : IndexedSetoid A b ℓ} → - ((x : A) → IndexedSetoid.Carrier B x) → Π (setoid A) B -:→-to-Π {B = B} f = record - { _⟨$⟩_ = f - ; cong = λ { refl → IndexedSetoid.refl B } - } - where open IndexedSetoid B using (_≈_) - -→-to-⟶ : ∀ {A : Set a} {B : Setoid b ℓ} → - (A → Setoid.Carrier B) → setoid A ⟶ B -→-to-⟶ = :→-to-Π - ------------------------------------------------------------------------- --- Inspect - --- Inspect can be used when you want to pattern match on the result r --- of some expression e, and you also need to "remember" that r ≡ e. - --- See README.Inspect for an explanation of how/why to use this. - -record Reveal_·_is_ {A : Set a} {B : A → Set b} - (f : (x : A) → B x) (x : A) (y : B x) : - Set (a ⊔ b) where - constructor [_] - field eq : f x ≡ y - -inspect : ∀ {A : Set a} {B : A → Set b} - (f : (x : A) → B x) (x : A) → Reveal f · x is f x -inspect f x = [ refl ] - ------------------------------------------------------------------------- --- Propositionality - -isPropositional : Set a → Set a -isPropositional A = (a b : A) → a ≡ b - ------------------------------------------------------------------------- --- More complex rearrangement lemmas - --- A lemma that is very similar to Lemma 2.4.3 from the HoTT book. - -naturality : ∀ {x y} {x≡y : x ≡ y} {f g : A → B} - (f≡g : ∀ x → f x ≡ g x) → - trans (cong f x≡y) (f≡g y) ≡ trans (f≡g x) (cong g x≡y) -naturality {x = x} {x≡y = refl} f≡g = - f≡g x ≡⟨ sym (trans-reflʳ _) ⟩ - trans (f≡g x) refl ∎ - where open ≡-Reasoning - --- A lemma that is very similar to Corollary 2.4.4 from the HoTT book. - -cong-≡id : ∀ {f : A → A} {x : A} (f≡id : ∀ x → f x ≡ x) → - cong f (f≡id x) ≡ f≡id (f x) -cong-≡id {f = f} {x} f≡id = begin - cong f fx≡x ≡⟨ sym (trans-reflʳ _) ⟩ - trans (cong f fx≡x) refl ≡⟨ cong (trans _) (sym (trans-symʳ fx≡x)) ⟩ - trans (cong f fx≡x) (trans fx≡x (sym fx≡x)) ≡⟨ sym (trans-assoc (cong f fx≡x)) ⟩ - trans (trans (cong f fx≡x) fx≡x) (sym fx≡x) ≡⟨ cong (λ p → trans p (sym _)) (naturality f≡id) ⟩ - trans (trans f²x≡x (cong id fx≡x)) (sym fx≡x) ≡⟨ cong (λ p → trans (trans f²x≡x p) (sym fx≡x)) (cong-id _) ⟩ - trans (trans f²x≡x fx≡x) (sym fx≡x) ≡⟨ trans-assoc f²x≡x ⟩ - trans f²x≡x (trans fx≡x (sym fx≡x)) ≡⟨ cong (trans _) (trans-symʳ fx≡x) ⟩ - trans f²x≡x refl ≡⟨ trans-reflʳ _ ⟩ - f≡id (f x) ∎ - where open ≡-Reasoning; fx≡x = f≡id x; f²x≡x = f≡id (f x) - -module _ (_≟_ : DecidableEquality A) {x y : A} where - - ≡-≟-identity : (eq : x ≡ y) → x ≟ y ≡ yes eq - ≡-≟-identity eq = dec-yes-irr (x ≟ y) (Decidable⇒UIP.≡-irrelevant _≟_) eq - - ≢-≟-identity : (x≢y : x ≢ y) → x ≟ y ≡ no x≢y - ≢-≟-identity = dec-no (x ≟ y) +open import Axiom.UniquenessOfIdentityProofs +open import Function.Base using (id; _∘_) +import Function.Dependent.Bundles as Dependent +open import Function.Indexed.Relation.Binary.Equality using (≡-setoid) +open import Level using (Level; _⊔_) +open import Relation.Nullary using (Irrelevant) +open import Relation.Nullary.Decidable using (yes; no; dec-yes-irr; dec-no) +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Binary.Definitions using (DecidableEquality) +open import Relation.Binary.Indexed.Heterogeneous + using (IndexedSetoid) +import Relation.Binary.Indexed.Heterogeneous.Construct.Trivial + as Trivial + +private + variable + a b c ℓ p : Level + A B C : Set a + +------------------------------------------------------------------------ +-- Re-export contents modules that make up the parts + +open import Relation.Binary.PropositionalEquality.Core public +open import Relation.Binary.PropositionalEquality.Properties public +open import Relation.Binary.PropositionalEquality.Algebra public + +------------------------------------------------------------------------ +-- Pointwise equality + +infix 4 _≗_ + +_→-setoid_ : ∀ (A : Set a) (B : Set b) → Setoid _ _ +A →-setoid B = ≡-setoid A (Trivial.indexedSetoid (setoid B)) + +_≗_ : (f g : A → B) → Set _ +_≗_ {A = A} {B = B} = Setoid._≈_ (A →-setoid B) + +:→-to-Π : ∀ {A : Set a} {B : IndexedSetoid A b ℓ} → + ((x : A) → IndexedSetoid.Carrier B x) → + Dependent.Func (setoid A) B +:→-to-Π {B = B} f = record + { to = f + ; cong = λ { refl → IndexedSetoid.refl B } + } + +→-to-⟶ : ∀ {A : Set a} {B : Setoid b ℓ} → + (A → Setoid.Carrier B) → + Dependent.Func (setoid A) (Trivial.indexedSetoid B) +→-to-⟶ = :→-to-Π + +------------------------------------------------------------------------ +-- More complex rearrangement lemmas + +-- A lemma that is very similar to Lemma 2.4.3 from the HoTT book. + +naturality : ∀ {x y} {x≡y : x ≡ y} {f g : A → B} + (f≡g : ∀ x → f x ≡ g x) → + trans (cong f x≡y) (f≡g y) ≡ trans (f≡g x) (cong g x≡y) +naturality {x = x} {x≡y = refl} f≡g = + f≡g x ≡⟨ sym (trans-reflʳ _) ⟩ + trans (f≡g x) refl ∎ + where open ≡-Reasoning + +-- A lemma that is very similar to Corollary 2.4.4 from the HoTT book. + +cong-≡id : ∀ {f : A → A} {x : A} (f≡id : ∀ x → f x ≡ x) → + cong f (f≡id x) ≡ f≡id (f x) +cong-≡id {f = f} {x} f≡id = begin + cong f fx≡x ≡⟨ sym (trans-reflʳ _) ⟩ + trans (cong f fx≡x) refl ≡⟨ cong (trans _) (sym (trans-symʳ fx≡x)) ⟩ + trans (cong f fx≡x) (trans fx≡x (sym fx≡x)) ≡⟨ sym (trans-assoc (cong f fx≡x)) ⟩ + trans (trans (cong f fx≡x) fx≡x) (sym fx≡x) ≡⟨ cong (λ p → trans p (sym _)) (naturality f≡id) ⟩ + trans (trans f²x≡x (cong id fx≡x)) (sym fx≡x) ≡⟨ cong (λ p → trans (trans f²x≡x p) (sym fx≡x)) (cong-id _) ⟩ + trans (trans f²x≡x fx≡x) (sym fx≡x) ≡⟨ trans-assoc f²x≡x ⟩ + trans f²x≡x (trans fx≡x (sym fx≡x)) ≡⟨ cong (trans _) (trans-symʳ fx≡x) ⟩ + trans f²x≡x refl ≡⟨ trans-reflʳ _ ⟩ + f≡id (f x) ∎ + where open ≡-Reasoning; fx≡x = f≡id x; f²x≡x = f≡id (f x) + +module _ (_≟_ : DecidableEquality A) {x y : A} where + + ≡-≟-identity : (eq : x ≡ y) → x ≟ y ≡ yes eq + ≡-≟-identity eq = dec-yes-irr (x ≟ y) (Decidable⇒UIP.≡-irrelevant _≟_) eq + + ≢-≟-identity : (x≢y : x ≢ y) → x ≟ y ≡ no x≢y + ≢-≟-identity = dec-no (x ≟ y) + + +------------------------------------------------------------------------ +-- Inspect + +-- Inspect can be used when you want to pattern match on the result r +-- of some expression e, and you also need to "remember" that r ≡ e. + +-- See README.Inspect for an explanation of how/why to use this. + +-- Normally (but not always) the new `with ... in` syntax described at +-- https://agda.readthedocs.io/en/v2.6.4/language/with-abstraction.html#with-abstraction-equality +-- can be used instead." + +record Reveal_·_is_ {A : Set a} {B : A → Set b} + (f : (x : A) → B x) (x : A) (y : B x) : + Set (a ⊔ b) where + constructor [_] + field eq : f x ≡ y + +inspect : ∀ {A : Set a} {B : A → Set b} + (f : (x : A) → B x) (x : A) → Reveal f · x is f x +inspect f x = [ refl ] + + +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 2.0 + +isPropositional : Set a → Set a +isPropositional = Irrelevant + +{-# WARNING_ON_USAGE isPropositional +"Warning: isPropositional was deprecated in v2.0. +Please use Relation.Nullary.Irrelevant instead. " +#-} + \ No newline at end of file diff --git a/Relation.Binary.Reasoning.Base.Double.html b/Relation.Binary.Reasoning.Base.Double.html index d4fccea6..33c6ce00 100644 --- a/Relation.Binary.Reasoning.Base.Double.html +++ b/Relation.Binary.Reasoning.Base.Double.html @@ -11,107 +11,93 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary +open import Level using (_⊔_) +open import Function using (case_of_) +open import Relation.Nullary.Decidable.Core using (Dec; yes; no) +open import Relation.Binary.Core using (Rel; _⇒_) +open import Relation.Binary.Definitions using (Reflexive; Trans) +open import Relation.Binary.Structures using (IsPreorder) +open import Relation.Binary.PropositionalEquality.Core as P using (_≡_) +open import Relation.Binary.Reasoning.Syntax -module Relation.Binary.Reasoning.Base.Double {a ℓ₁ ℓ₂} {A : Set a} - {_≈_ : Rel A ℓ₁} {_∼_ : Rel A ℓ₂} (isPreorder : IsPreorder _≈_ _∼_) - where -open import Data.Product using (proj₁; proj₂) -open import Level using (Level; _⊔_; Lift; lift) -open import Function.Base using (case_of_; id) -open import Relation.Binary.PropositionalEquality.Core - using (_≡_; refl; sym) -open import Relation.Nullary.Decidable using (Dec; yes; no) -open import Relation.Nullary.Decidable using (True; toWitness) +module Relation.Binary.Reasoning.Base.Double {a ℓ₁ ℓ₂} {A : Set a} + {_≈_ : Rel A ℓ₁} {_≲_ : Rel A ℓ₂} (isPreorder : IsPreorder _≈_ _≲_) + where -open IsPreorder isPreorder +open IsPreorder isPreorder ------------------------------------------------------------------------- --- A datatype to hide the current relation type +------------------------------------------------------------------------ +-- A datatype to hide the current relation type -infix 4 _IsRelatedTo_ +infix 4 _IsRelatedTo_ -data _IsRelatedTo_ (x y : A) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - nonstrict : (x∼y : x ∼ y) → x IsRelatedTo y - equals : (x≈y : x ≈ y) → x IsRelatedTo y +data _IsRelatedTo_ (x y : A) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + nonstrict : (x≲y : x ≲ y) → x IsRelatedTo y + equals : (x≈y : x ≈ y) → x IsRelatedTo y ------------------------------------------------------------------------- --- A record that is used to ensure that the final relation proved by the --- chain of reasoning can be converted into the required relation. +start : _IsRelatedTo_ ⇒ _≲_ +start (equals x≈y) = reflexive x≈y +start (nonstrict x≲y) = x≲y -data IsEquality {x y} : x IsRelatedTo y → Set (a ⊔ ℓ₁ ⊔ ℓ₂) where - isEquality : ∀ x≈y → IsEquality (equals x≈y) +≡-go : Trans _≡_ _IsRelatedTo_ _IsRelatedTo_ +≡-go x≡y (equals y≈z) = equals (case x≡y of λ where P.refl → y≈z) +≡-go x≡y (nonstrict y≤z) = nonstrict (case x≡y of λ where P.refl → y≤z) -IsEquality? : ∀ {x y} (x≲y : x IsRelatedTo y) → Dec (IsEquality x≲y) -IsEquality? (nonstrict _) = no λ() -IsEquality? (equals x≈y) = yes (isEquality x≈y) +≲-go : Trans _≲_ _IsRelatedTo_ _IsRelatedTo_ +≲-go x≲y (equals y≈z) = nonstrict (∼-respʳ-≈ y≈z x≲y) +≲-go x≲y (nonstrict y≲z) = nonstrict (trans x≲y y≲z) -extractEquality : ∀ {x y} {x≲y : x IsRelatedTo y} → IsEquality x≲y → x ≈ y -extractEquality (isEquality x≈y) = x≈y +≈-go : Trans _≈_ _IsRelatedTo_ _IsRelatedTo_ +≈-go x≈y (equals y≈z) = equals (Eq.trans x≈y y≈z) +≈-go x≈y (nonstrict y≲z) = nonstrict (∼-respˡ-≈ (Eq.sym x≈y) y≲z) ------------------------------------------------------------------------- --- Reasoning combinators +stop : Reflexive _IsRelatedTo_ +stop = equals Eq.refl --- See `Relation.Binary.Reasoning.Base.Partial` for the design decisions --- behind these combinators. +------------------------------------------------------------------------ +-- A record that is used to ensure that the final relation proved by the +-- chain of reasoning can be converted into the required relation. -infix 1 begin_ begin-equality_ -infixr 2 step-∼ step-≈ step-≈˘ step-≡ step-≡˘ _≡⟨⟩_ -infix 3 _∎ +data IsEquality {x y} : x IsRelatedTo y → Set (a ⊔ ℓ₁ ⊔ ℓ₂) where + isEquality : ∀ x≈y → IsEquality (equals x≈y) --- Beginnings of various types of proofs +IsEquality? : ∀ {x y} (x≲y : x IsRelatedTo y) → Dec (IsEquality x≲y) +IsEquality? (nonstrict _) = no λ() +IsEquality? (equals x≈y) = yes (isEquality x≈y) -begin_ : ∀ {x y} (r : x IsRelatedTo y) → x ∼ y -begin (nonstrict x∼y) = x∼y -begin (equals x≈y) = reflexive x≈y +extractEquality : ∀ {x y} {x≲y : x IsRelatedTo y} → IsEquality x≲y → x ≈ y +extractEquality (isEquality x≈y) = x≈y -begin-equality_ : ∀ {x y} (r : x IsRelatedTo y) → {s : True (IsEquality? r)} → x ≈ y -begin-equality_ r {s} = extractEquality (toWitness s) +equalitySubRelation : SubRelation _IsRelatedTo_ _ _ +equalitySubRelation = record + { IsS = IsEquality + ; IsS? = IsEquality? + ; extract = extractEquality + } --- Step with the main relation +------------------------------------------------------------------------ +-- Reasoning combinators -step-∼ : ∀ (x : A) {y z} → y IsRelatedTo z → x ∼ y → x IsRelatedTo z -step-∼ x (nonstrict y∼z) x∼y = nonstrict (trans x∼y y∼z) -step-∼ x (equals y≈z) x∼y = nonstrict (∼-respʳ-≈ y≈z x∼y) +open begin-syntax _IsRelatedTo_ start public +open begin-equality-syntax _IsRelatedTo_ equalitySubRelation public +open ≡-syntax _IsRelatedTo_ ≡-go public +open ≈-syntax _IsRelatedTo_ _IsRelatedTo_ ≈-go Eq.sym public +open ≲-syntax _IsRelatedTo_ _IsRelatedTo_ ≲-go public +open end-syntax _IsRelatedTo_ stop public --- Step with the setoid equality -step-≈ : ∀ (x : A) {y z} → y IsRelatedTo z → x ≈ y → x IsRelatedTo z -step-≈ x (nonstrict y∼z) x≈y = nonstrict (∼-respˡ-≈ (Eq.sym x≈y) y∼z) -step-≈ x (equals y≈z) x≈y = equals (Eq.trans x≈y y≈z) +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. --- Flipped step with the setoid equality +-- Version 2.0 -step-≈˘ : ∀ x {y z} → y IsRelatedTo z → y ≈ x → x IsRelatedTo z -step-≈˘ x y∼z x≈y = step-≈ x y∼z (Eq.sym x≈y) - --- Step with non-trivial propositional equality - -step-≡ : ∀ (x : A) {y z} → y IsRelatedTo z → x ≡ y → x IsRelatedTo z -step-≡ x (nonstrict y∼z) x≡y = nonstrict (case x≡y of λ where refl → y∼z) -step-≡ x (equals y≈z) x≡y = equals (case x≡y of λ where refl → y≈z) - --- Flipped step with non-trivial propositional equality - -step-≡˘ : ∀ x {y z} → y IsRelatedTo z → y ≡ x → x IsRelatedTo z -step-≡˘ x y∼z x≡y = step-≡ x y∼z (sym x≡y) - --- Step with trivial propositional equality - -_≡⟨⟩_ : ∀ (x : A) {y} → x IsRelatedTo y → x IsRelatedTo y -x ≡⟨⟩ x≲y = x≲y - --- Termination step - -_∎ : ∀ x → x IsRelatedTo x -x ∎ = equals Eq.refl - --- Syntax declarations - -syntax step-∼ x y∼z x∼y = x ∼⟨ x∼y ⟩ y∼z -syntax step-≈ x y∼z x≈y = x ≈⟨ x≈y ⟩ y∼z -syntax step-≈˘ x y∼z y≈x = x ≈˘⟨ y≈x ⟩ y∼z -syntax step-≡ x y∼z x≡y = x ≡⟨ x≡y ⟩ y∼z -syntax step-≡˘ x y∼z y≡x = x ≡˘⟨ y≡x ⟩ y∼z +open ∼-syntax _IsRelatedTo_ _IsRelatedTo_ ≲-go public +{-# WARNING_ON_USAGE step-∼ +"Warning: step-∼ and _∼⟨_⟩_ syntax was deprecated in v2.0. +Please use step-≲ and _≲⟨_⟩_ instead. " +#-} \ No newline at end of file diff --git a/Relation.Binary.Reasoning.Base.Single.html b/Relation.Binary.Reasoning.Base.Single.html index f19b14ba..342753ae 100644 --- a/Relation.Binary.Reasoning.Base.Single.html +++ b/Relation.Binary.Reasoning.Base.Single.html @@ -7,84 +7,46 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary +open import Level using (_⊔_) +open import Function.Base using (case_of_) +open import Relation.Binary.Core using (Rel; _⇒_) +open import Relation.Binary.Definitions using (Reflexive; Transitive; Trans) +open import Relation.Binary.PropositionalEquality.Core as P using (_≡_) +open import Relation.Binary.Reasoning.Syntax -module Relation.Binary.Reasoning.Base.Single - {a ℓ} {A : Set a} (_∼_ : Rel A ℓ) - (refl : Reflexive _∼_) (trans : Transitive _∼_) - where +module Relation.Binary.Reasoning.Base.Single + {a ℓ} {A : Set a} (_∼_ : Rel A ℓ) + (refl : Reflexive _∼_) (trans : Transitive _∼_) + where --- TODO: the following part is copied from Relation.Binary.Reasoning.Base.Partial --- in order to avoid larger refactors. We will refactor this part later --- so taht we use the same framework as Relation.Binary.Reasoning.Base.Partial. +------------------------------------------------------------------------ +-- Definition of "related to" -open import Level using (_⊔_) -open import Relation.Binary.PropositionalEquality.Core as P - using (_≡_) +-- This seemingly unnecessary type is used to make it possible to +-- infer arguments even if the underlying equality evaluates. -infix 4 _IsRelatedTo_ +infix 4 _IsRelatedTo_ ------------------------------------------------------------------------- --- Definition of "related to" +data _IsRelatedTo_ (x y : A) : Set ℓ where + relTo : (x∼y : x ∼ y) → x IsRelatedTo y --- This seemingly unnecessary type is used to make it possible to --- infer arguments even if the underlying equality evaluates. +start : _IsRelatedTo_ ⇒ _∼_ +start (relTo x∼y) = x∼y -data _IsRelatedTo_ (x y : A) : Set ℓ where - relTo : (x∼y : x ∼ y) → x IsRelatedTo y +∼-go : Trans _∼_ _IsRelatedTo_ _IsRelatedTo_ +∼-go x∼y (relTo y∼z) = relTo (trans x∼y y∼z) ------------------------------------------------------------------------- --- Reasoning combinators +≡-go : Trans _≡_ _IsRelatedTo_ _IsRelatedTo_ +≡-go x≡y (relTo y∼z) = relTo (case x≡y of λ where P.refl → y∼z) --- Note that the arguments to the `step`s are not provided in their --- "natural" order and syntax declarations are later used to re-order --- them. This is because the `step` ordering allows the type-checker to --- better infer the middle argument `y` from the `_IsRelatedTo_` --- argument (see issue 622). --- --- This has two practical benefits. First it speeds up type-checking by --- approximately a factor of 5. Secondly it allows the combinators to be --- used with macros that use reflection, e.g. `Tactic.RingSolver`, where --- they need to be able to extract `y` using reflection. +stop : Reflexive _IsRelatedTo_ +stop = relTo refl -infix 1 begin_ -infixr 2 step-∼ step-≡ step-≡˘ -infixr 2 _≡⟨⟩_ -infix 3 _∎ +------------------------------------------------------------------------ +-- Reasoning combinators --- Beginning of a proof - -begin_ : ∀ {x y} → x IsRelatedTo y → x ∼ y -begin relTo x∼y = x∼y - --- Standard step with the relation - -step-∼ : ∀ x {y z} → y IsRelatedTo z → x ∼ y → x IsRelatedTo z -step-∼ _ (relTo y∼z) x∼y = relTo (trans x∼y y∼z) - --- Step with a non-trivial propositional equality - -step-≡ : ∀ x {y z} → y IsRelatedTo z → x ≡ y → x IsRelatedTo z -step-≡ _ x∼z P.refl = x∼z - --- Step with a flipped non-trivial propositional equality - -step-≡˘ : ∀ x {y z} → y IsRelatedTo z → y ≡ x → x IsRelatedTo z -step-≡˘ _ x∼z P.refl = x∼z - --- Step with a trivial propositional equality - -_≡⟨⟩_ : ∀ x {y} → x IsRelatedTo y → x IsRelatedTo y -_ ≡⟨⟩ x∼y = x∼y - --- Termination - -_∎ : ∀ x → x IsRelatedTo x -x ∎ = relTo refl - --- Syntax declarations - -syntax step-∼ x y∼z x∼y = x ∼⟨ x∼y ⟩ y∼z -syntax step-≡ x y≡z x≡y = x ≡⟨ x≡y ⟩ y≡z -syntax step-≡˘ x y≡z y≡x = x ≡˘⟨ y≡x ⟩ y≡z +open begin-syntax _IsRelatedTo_ start public +open ≡-syntax _IsRelatedTo_ ≡-go public +open ∼-syntax _IsRelatedTo_ _IsRelatedTo_ ∼-go public +open end-syntax _IsRelatedTo_ stop public \ No newline at end of file diff --git a/Relation.Binary.Reasoning.Base.Triple.html b/Relation.Binary.Reasoning.Base.Triple.html index 924a59d1..a6b3c885 100644 --- a/Relation.Binary.Reasoning.Base.Triple.html +++ b/Relation.Binary.Reasoning.Base.Triple.html @@ -11,143 +11,120 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary - -module Relation.Binary.Reasoning.Base.Triple {a ℓ₁ ℓ₂ ℓ₃} {A : Set a} - {_≈_ : Rel A ℓ₁} {_≤_ : Rel A ℓ₂} {_<_ : Rel A ℓ₃} - (isPreorder : IsPreorder _≈_ _≤_) - (<-trans : Transitive _<_) (<-resp-≈ : _<_ Respects₂ _≈_) (<⇒≤ : _<_ ⇒ _≤_) - (<-≤-trans : Trans _<_ _≤_ _<_) (≤-<-trans : Trans _≤_ _<_ _<_) - where - -open import Data.Product using (proj₁; proj₂) -open import Function.Base using (case_of_; id) -open import Level using (Level; _⊔_; Lift; lift) -open import Relation.Binary.PropositionalEquality.Core - using (_≡_; refl; sym) -open import Relation.Nullary.Decidable using (Dec; yes; no) -open import Relation.Nullary.Decidable using (True; toWitness) - -open IsPreorder isPreorder - renaming - ( reflexive to ≤-reflexive - ; trans to ≤-trans - ; ∼-resp-≈ to ≤-resp-≈ - ) - ------------------------------------------------------------------------- --- A datatype to abstract over the current relation - -infix 4 _IsRelatedTo_ - -data _IsRelatedTo_ (x y : A) : Set (a ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃) where - strict : (x<y : x < y) → x IsRelatedTo y - nonstrict : (x≤y : x ≤ y) → x IsRelatedTo y - equals : (x≈y : x ≈ y) → x IsRelatedTo y - ------------------------------------------------------------------------- --- Types that are used to ensure that the final relation proved by the --- chain of reasoning can be converted into the required relation. - -data IsStrict {x y} : x IsRelatedTo y → Set (a ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃) where - isStrict : ∀ x<y → IsStrict (strict x<y) - -IsStrict? : ∀ {x y} (x≲y : x IsRelatedTo y) → Dec (IsStrict x≲y) -IsStrict? (strict x<y) = yes (isStrict x<y) -IsStrict? (nonstrict _) = no λ() -IsStrict? (equals _) = no λ() - -extractStrict : ∀ {x y} {x≲y : x IsRelatedTo y} → IsStrict x≲y → x < y -extractStrict (isStrict x<y) = x<y - -data IsEquality {x y} : x IsRelatedTo y → Set (a ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃) where - isEquality : ∀ x≈y → IsEquality (equals x≈y) - -IsEquality? : ∀ {x y} (x≲y : x IsRelatedTo y) → Dec (IsEquality x≲y) -IsEquality? (strict _) = no λ() -IsEquality? (nonstrict _) = no λ() -IsEquality? (equals x≈y) = yes (isEquality x≈y) - -extractEquality : ∀ {x y} {x≲y : x IsRelatedTo y} → IsEquality x≲y → x ≈ y -extractEquality (isEquality x≈y) = x≈y - ------------------------------------------------------------------------- --- Reasoning combinators - --- See `Relation.Binary.Reasoning.Base.Partial` for the design decisions --- behind these combinators. - -infix 1 begin_ begin-strict_ begin-equality_ -infixr 2 step-< step-≤ step-≈ step-≈˘ step-≡ step-≡˘ _≡⟨⟩_ -infix 3 _∎ - --- Beginnings of various types of proofs - -begin_ : ∀ {x y} → x IsRelatedTo y → x ≤ y -begin (strict x<y) = <⇒≤ x<y -begin (nonstrict x≤y) = x≤y -begin (equals x≈y) = ≤-reflexive x≈y - -begin-strict_ : ∀ {x y} (r : x IsRelatedTo y) → {s : True (IsStrict? r)} → x < y -begin-strict_ r {s} = extractStrict (toWitness s) - -begin-equality_ : ∀ {x y} (r : x IsRelatedTo y) → {s : True (IsEquality? r)} → x ≈ y -begin-equality_ r {s} = extractEquality (toWitness s) - --- Step with the strict relation - -step-< : ∀ (x : A) {y z} → y IsRelatedTo z → x < y → x IsRelatedTo z -step-< x (strict y<z) x<y = strict (<-trans x<y y<z) -step-< x (nonstrict y≤z) x<y = strict (<-≤-trans x<y y≤z) -step-< x (equals y≈z) x<y = strict (proj₁ <-resp-≈ y≈z x<y) - --- Step with the non-strict relation - -step-≤ : ∀ (x : A) {y z} → y IsRelatedTo z → x ≤ y → x IsRelatedTo z -step-≤ x (strict y<z) x≤y = strict (≤-<-trans x≤y y<z) -step-≤ x (nonstrict y≤z) x≤y = nonstrict (≤-trans x≤y y≤z) -step-≤ x (equals y≈z) x≤y = nonstrict (proj₁ ≤-resp-≈ y≈z x≤y) - --- Step with the setoid equality - -step-≈ : ∀ (x : A) {y z} → y IsRelatedTo z → x ≈ y → x IsRelatedTo z -step-≈ x (strict y<z) x≈y = strict (proj₂ <-resp-≈ (Eq.sym x≈y) y<z) -step-≈ x (nonstrict y≤z) x≈y = nonstrict (proj₂ ≤-resp-≈ (Eq.sym x≈y) y≤z) -step-≈ x (equals y≈z) x≈y = equals (Eq.trans x≈y y≈z) - --- Flipped step with the setoid equality - -step-≈˘ : ∀ x {y z} → y IsRelatedTo z → y ≈ x → x IsRelatedTo z -step-≈˘ x y∼z x≈y = step-≈ x y∼z (Eq.sym x≈y) - --- Step with non-trivial propositional equality - -step-≡ : ∀ (x : A) {y z} → y IsRelatedTo z → x ≡ y → x IsRelatedTo z -step-≡ x (strict y<z) x≡y = strict (case x≡y of λ where refl → y<z) -step-≡ x (nonstrict y≤z) x≡y = nonstrict (case x≡y of λ where refl → y≤z) -step-≡ x (equals y≈z) x≡y = equals (case x≡y of λ where refl → y≈z) - --- Flipped step with non-trivial propositional equality - -step-≡˘ : ∀ x {y z} → y IsRelatedTo z → y ≡ x → x IsRelatedTo z -step-≡˘ x y∼z x≡y = step-≡ x y∼z (sym x≡y) - --- Step with trivial propositional equality - -_≡⟨⟩_ : ∀ (x : A) {y} → x IsRelatedTo y → x IsRelatedTo y -x ≡⟨⟩ x≲y = x≲y - --- Termination step - -_∎ : ∀ x → x IsRelatedTo x -x ∎ = equals Eq.refl - --- Syntax declarations - -syntax step-< x y∼z x<y = x <⟨ x<y ⟩ y∼z -syntax step-≤ x y∼z x≤y = x ≤⟨ x≤y ⟩ y∼z -syntax step-≈ x y∼z x≈y = x ≈⟨ x≈y ⟩ y∼z -syntax step-≈˘ x y∼z y≈x = x ≈˘⟨ y≈x ⟩ y∼z -syntax step-≡ x y∼z x≡y = x ≡⟨ x≡y ⟩ y∼z -syntax step-≡˘ x y∼z y≡x = x ≡˘⟨ y≡x ⟩ y∼z +open import Data.Product.Base using (proj₁; proj₂) +open import Level using (_⊔_) +open import Function using (case_of_) +open import Relation.Nullary.Decidable.Core + using (Dec; yes; no) +open import Relation.Binary.Core using (Rel; _⇒_) +open import Relation.Binary.Structures using (IsPreorder) +open import Relation.Binary.Definitions + using (Transitive; _Respects₂_; Reflexive; Trans; Irreflexive; Asymmetric) +open import Relation.Binary.PropositionalEquality.Core as P using (_≡_) +open import Relation.Binary.Reasoning.Syntax + +module Relation.Binary.Reasoning.Base.Triple {a ℓ₁ ℓ₂ ℓ₃} {A : Set a} + {_≈_ : Rel A ℓ₁} {_≤_ : Rel A ℓ₂} {_<_ : Rel A ℓ₃} + (isPreorder : IsPreorder _≈_ _≤_) + (<-asym : Asymmetric _<_) (<-trans : Transitive _<_) (<-resp-≈ : _<_ Respects₂ _≈_) + (<⇒≤ : _<_ ⇒ _≤_) + (<-≤-trans : Trans _<_ _≤_ _<_) (≤-<-trans : Trans _≤_ _<_ _<_) + where + +open IsPreorder isPreorder + +------------------------------------------------------------------------ +-- A datatype to abstract over the current relation + +infix 4 _IsRelatedTo_ + +data _IsRelatedTo_ (x y : A) : Set (a ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃) where + strict : (x<y : x < y) → x IsRelatedTo y + nonstrict : (x≤y : x ≤ y) → x IsRelatedTo y + equals : (x≈y : x ≈ y) → x IsRelatedTo y + +start : _IsRelatedTo_ ⇒ _≤_ +start (equals x≈y) = reflexive x≈y +start (nonstrict x≤y) = x≤y +start (strict x<y) = <⇒≤ x<y + +≡-go : Trans _≡_ _IsRelatedTo_ _IsRelatedTo_ +≡-go x≡y (equals y≈z) = equals (case x≡y of λ where P.refl → y≈z) +≡-go x≡y (nonstrict y≤z) = nonstrict (case x≡y of λ where P.refl → y≤z) +≡-go x≡y (strict y<z) = strict (case x≡y of λ where P.refl → y<z) + +≈-go : Trans _≈_ _IsRelatedTo_ _IsRelatedTo_ +≈-go x≈y (equals y≈z) = equals (Eq.trans x≈y y≈z) +≈-go x≈y (nonstrict y≤z) = nonstrict (∼-respˡ-≈ (Eq.sym x≈y) y≤z) +≈-go x≈y (strict y<z) = strict (proj₂ <-resp-≈ (Eq.sym x≈y) y<z) + +≤-go : Trans _≤_ _IsRelatedTo_ _IsRelatedTo_ +≤-go x≤y (equals y≈z) = nonstrict (∼-respʳ-≈ y≈z x≤y) +≤-go x≤y (nonstrict y≤z) = nonstrict (trans x≤y y≤z) +≤-go x≤y (strict y<z) = strict (≤-<-trans x≤y y<z) + +<-go : Trans _<_ _IsRelatedTo_ _IsRelatedTo_ +<-go x<y (equals y≈z) = strict (proj₁ <-resp-≈ y≈z x<y) +<-go x<y (nonstrict y≤z) = strict (<-≤-trans x<y y≤z) +<-go x<y (strict y<z) = strict (<-trans x<y y<z) + +stop : Reflexive _IsRelatedTo_ +stop = equals Eq.refl + + +------------------------------------------------------------------------ +-- Types that are used to ensure that the final relation proved by the +-- chain of reasoning can be converted into the required relation. + +data IsStrict {x y} : x IsRelatedTo y → Set (a ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃) where + isStrict : ∀ x<y → IsStrict (strict x<y) + +IsStrict? : ∀ {x y} (x≲y : x IsRelatedTo y) → Dec (IsStrict x≲y) +IsStrict? (strict x<y) = yes (isStrict x<y) +IsStrict? (nonstrict _) = no λ() +IsStrict? (equals _) = no λ() + +extractStrict : ∀ {x y} {x≲y : x IsRelatedTo y} → IsStrict x≲y → x < y +extractStrict (isStrict x<y) = x<y + +strictRelation : SubRelation _IsRelatedTo_ _ _ +strictRelation = record + { IsS = IsStrict + ; IsS? = IsStrict? + ; extract = extractStrict + } + +------------------------------------------------------------------------ +-- Equality sub-relation + +data IsEquality {x y} : x IsRelatedTo y → Set (a ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃) where + isEquality : ∀ x≈y → IsEquality (equals x≈y) + +IsEquality? : ∀ {x y} (x≲y : x IsRelatedTo y) → Dec (IsEquality x≲y) +IsEquality? (strict _) = no λ() +IsEquality? (nonstrict _) = no λ() +IsEquality? (equals x≈y) = yes (isEquality x≈y) + +extractEquality : ∀ {x y} {x≲y : x IsRelatedTo y} → IsEquality x≲y → x ≈ y +extractEquality (isEquality x≈y) = x≈y + +eqRelation : SubRelation _IsRelatedTo_ _ _ +eqRelation = record + { IsS = IsEquality + ; IsS? = IsEquality? + ; extract = extractEquality + } + +------------------------------------------------------------------------ +-- Reasoning combinators + +open begin-syntax _IsRelatedTo_ start public +open begin-equality-syntax _IsRelatedTo_ eqRelation public +open begin-strict-syntax _IsRelatedTo_ strictRelation public +open begin-contradiction-syntax _IsRelatedTo_ strictRelation <-asym public +open ≡-syntax _IsRelatedTo_ ≡-go public +open ≈-syntax _IsRelatedTo_ _IsRelatedTo_ ≈-go Eq.sym public +open ≤-syntax _IsRelatedTo_ _IsRelatedTo_ ≤-go public +open <-syntax _IsRelatedTo_ _IsRelatedTo_ <-go public +open end-syntax _IsRelatedTo_ stop public \ No newline at end of file diff --git a/Relation.Binary.Reasoning.Preorder.html b/Relation.Binary.Reasoning.Preorder.html index 41fb8fae..c8adeb7b 100644 --- a/Relation.Binary.Reasoning.Preorder.html +++ b/Relation.Binary.Reasoning.Preorder.html @@ -19,20 +19,20 @@ -- u≈w = begin-equality -- u ≈⟨ u≈v ⟩ -- v ≡⟨ v≡w ⟩ --- w ≡˘⟨ x≡w ⟩ --- x ∎ +-- w ≡⟨ x≡w ⟨ +-- x ∎ -{-# OPTIONS --cubical-compatible --safe #-} +{-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary +open import Relation.Binary.Bundles using (Preorder) -module Relation.Binary.Reasoning.Preorder - {p₁ p₂ p₃} (P : Preorder p₁ p₂ p₃) where +module Relation.Binary.Reasoning.Preorder + {p₁ p₂ p₃} (P : Preorder p₁ p₂ p₃) where -open Preorder P +open Preorder P ------------------------------------------------------------------------- --- Publicly re-export the contents of the base module +------------------------------------------------------------------------ +-- Publicly re-export the contents of the base module -open import Relation.Binary.Reasoning.Base.Double isPreorder public +open import Relation.Binary.Reasoning.Base.Double isPreorder public \ No newline at end of file diff --git a/Relation.Binary.Reasoning.Setoid.html b/Relation.Binary.Reasoning.Setoid.html index b13189f0..7d5551a4 100644 --- a/Relation.Binary.Reasoning.Setoid.html +++ b/Relation.Binary.Reasoning.Setoid.html @@ -16,34 +16,30 @@ -- 0 ∎ -- Module `≡-Reasoning` in `Relation.Binary.PropositionalEquality` --- is recommended for equational reasoning when the underlying equality is --- `_≡_`. +-- is recommended for equational reasoning when the underlying equality +-- is `_≡_`. {-# OPTIONS --cubical-compatible --safe #-} -open import Relation.Binary +open import Relation.Binary.Bundles using (Setoid) +open import Relation.Binary.Reasoning.Syntax -module Relation.Binary.Reasoning.Setoid {s₁ s₂} (S : Setoid s₁ s₂) where +module Relation.Binary.Reasoning.Setoid {s₁ s₂} (S : Setoid s₁ s₂) where -open Setoid S +open Setoid S ------------------------------------------------------------------------- --- Reasoning combinators +import Relation.Binary.Reasoning.Base.Single _≈_ refl trans + as SingleRelReasoning --- open import Relation.Binary.Reasoning.PartialSetoid partialSetoid public -open import Relation.Binary.Reasoning.Base.Single _≈_ refl trans as Base public - hiding (step-∼) +------------------------------------------------------------------------ +-- Reasoning combinators -infixr 2 step-≈ step-≈˘ +-- Export the combinators for single relation reasoning, hiding the +-- single misnamed combinator. +open SingleRelReasoning public + hiding (step-∼) + renaming (∼-go to ≈-go) --- A step using an equality - -step-≈ = Base.step-∼ -syntax step-≈ x y≈z x≈y = x ≈⟨ x≈y ⟩ y≈z - --- A step using a symmetric equality - -step-≈˘ : ∀ x {y z} → y IsRelatedTo z → y ≈ x → x IsRelatedTo z -step-≈˘ x y∼z y≈x = x ≈⟨ sym y≈x ⟩ y∼z -syntax step-≈˘ x y≈z y≈x = x ≈˘⟨ y≈x ⟩ y≈z +-- Re-export the equality-based combinators instead +open ≈-syntax _IsRelatedTo_ _IsRelatedTo_ ≈-go sym public \ No newline at end of file diff --git a/Relation.Binary.Reasoning.Syntax.html b/Relation.Binary.Reasoning.Syntax.html new file mode 100644 index 00000000..adb91af3 --- /dev/null +++ b/Relation.Binary.Reasoning.Syntax.html @@ -0,0 +1,446 @@ + +Relation.Binary.Reasoning.Syntax
------------------------------------------------------------------------
+-- The Agda standard library
+--
+-- Syntax for the building blocks of equational reasoning modules
+------------------------------------------------------------------------
+
+{-# OPTIONS --cubical-compatible --safe #-}
+
+open import Level using (Level; _⊔_; suc)
+open import Relation.Nullary.Decidable.Core
+  using (Dec; True; toWitness)
+open import Relation.Nullary.Negation using (contradiction)
+open import Relation.Binary.Core using (Rel; REL; _⇒_)
+open import Relation.Binary.Definitions
+open import Relation.Binary.PropositionalEquality.Core as P
+  using (_≡_)
+
+-- List of `Reasoning` modules that do not use this framework and so
+-- need to be updated manually if the syntax changes.
+--
+--   Data/Vec/Relation/Binary/Equality/Cast
+--   Relation/Binary/HeterogeneousEquality
+--   Effect/Monad/Partiality
+--   Effect/Monad/Partiality/All
+--   Codata/Guarded/Stream/Relation/Binary/Pointwise
+--   Function/Reasoning
+
+module Relation.Binary.Reasoning.Syntax where
+
+private
+  variable
+    a ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Level
+    A B C : Set a
+    x y z : A
+
+------------------------------------------------------------------------
+-- Syntax for beginning a reasoning chain
+------------------------------------------------------------------------
+
+------------------------------------------------------------------------
+-- Basic begin syntax
+
+module begin-syntax
+  (R : REL A B ℓ₁)
+  {S : REL A B ℓ₂}
+  (reflexive : R ⇒ S)
+  where
+
+  infix 1 begin_
+
+  begin_ : R x y → S x y
+  begin_ = reflexive
+
+------------------------------------------------------------------------
+-- Begin subrelation syntax
+
+-- Sometimes we want to support sub-relations with the
+-- same reasoning operators as the main relations (e.g. perform equality
+-- proofs with non-strict reasoning operators). This record bundles all
+-- the parts needed to extract the sub-relation proofs.
+record SubRelation {A : Set a} (R : Rel A ℓ₁) ℓ₂ ℓ₃ : Set (a ⊔ ℓ₁ ⊔ suc ℓ₂ ⊔ suc ℓ₃) where
+  field
+    S : Rel A ℓ₂
+    IsS : R x y → Set ℓ₃
+    IsS? : ∀ (xRy : R x y) → Dec (IsS xRy)
+    extract : ∀ {xRy : R x y} → IsS xRy → S x y
+
+module begin-subrelation-syntax
+  (R : Rel A ℓ₁)
+  (sub : SubRelation R ℓ₂ ℓ₃)
+  where
+  open SubRelation sub
+
+  infix 1 begin_
+
+  begin_ : ∀ {x y} (xRy : R x y) → {s : True (IsS? xRy)} → S x y
+  begin_ r {s} = extract (toWitness s)
+
+-- Begin equality syntax
+module begin-equality-syntax
+  (R : Rel A ℓ₁)
+  (sub : SubRelation R ℓ₂ ℓ₃) where
+
+  open begin-subrelation-syntax R sub public
+    renaming (begin_ to begin-equality_)
+
+-- Begin apartness syntax
+module begin-apartness-syntax
+  (R : Rel A ℓ₁)
+  (sub : SubRelation R ℓ₂ ℓ₃) where
+
+  open begin-subrelation-syntax R sub public
+    renaming (begin_ to begin-apartness_)
+
+-- Begin strict syntax
+module begin-strict-syntax
+  (R : Rel A ℓ₁)
+  (sub : SubRelation R ℓ₂ ℓ₃) where
+
+  open begin-subrelation-syntax R sub public
+    renaming (begin_ to begin-strict_)
+
+------------------------------------------------------------------------
+-- Begin membership syntax
+
+module begin-membership-syntax
+  (R : Rel A ℓ₁)
+  (_∈_ : REL B A ℓ₂)
+  (resp : _∈_ Respectsʳ R) where
+
+  infix  1 step-∈
+
+  step-∈ : ∀ (x : B) {xs ys} → R xs ys → x ∈ xs → x ∈ ys
+  step-∈ x = resp
+
+  syntax step-∈ x  xs⊆ys x∈xs  = x ∈⟨ x∈xs ⟩ xs⊆ys
+
+------------------------------------------------------------------------
+-- Begin contradiction syntax
+
+-- Used with asymmetric subrelations to derive a contradiction from a
+-- proof that an element is related to itself.
+module begin-contradiction-syntax
+  (R : Rel A ℓ₁)
+  (sub : SubRelation R ℓ₂ ℓ₃)
+  (asym : Asymmetric (SubRelation.S sub))
+  where
+
+  open SubRelation sub
+
+  infix 1 begin-contradiction_
+
+  begin-contradiction_ : ∀ (xRx : R x x) {s : True (IsS? xRx)} →
+                         ∀ {b} {B : Set b} → B
+  begin-contradiction_ {x} r {s} = contradiction x<x (asym x<x)
+    where
+    x<x : S x x
+    x<x = extract (toWitness s)
+
+------------------------------------------------------------------------
+-- Syntax for continuing a chain of reasoning steps
+------------------------------------------------------------------------
+
+-- Note that the arguments to the `step`s are not provided in their
+-- "natural" order and syntax declarations are later used to re-order
+-- them. This is because the `step` ordering allows the type-checker to
+-- better infer the middle argument `y` from the `_IsRelatedTo_`
+-- argument (see issue 622).
+--
+-- This has two practical benefits. First it speeds up type-checking by
+-- approximately a factor of 5. Secondly it allows the combinators to be
+-- used with macros that use reflection, e.g. `Tactic.RingSolver`, where
+-- they need to be able to extract `y` using reflection.
+
+------------------------------------------------------------------------
+-- Syntax for unidirectional relations
+
+-- See https://github.com/agda/agda-stdlib/issues/2150 for a possible
+-- simplification.
+
+module _
+  {R : REL A B ℓ₂}
+  (S : REL B C ℓ₁)
+  (T : REL A C ℓ₃)
+  (step : Trans R S T)
+  where
+
+  forward : ∀ (x : A) {y z} → S y z → R x y → T x z
+  forward x yRz x∼y = step {x} x∼y yRz
+
+  -- Arbitrary relation syntax
+  module ∼-syntax where
+    infixr 2 step-∼
+    step-∼ = forward
+    syntax step-∼ x yRz x∼y = x ∼⟨ x∼y ⟩ yRz
+
+
+  -- Preorder syntax
+  module ≲-syntax where
+    infixr 2 step-≲
+    step-≲ = forward
+    syntax step-≲ x yRz x≲y = x ≲⟨ x≲y ⟩ yRz
+
+
+  -- Partial order syntax
+  module ≤-syntax where
+    infixr 2 step-≤
+    step-≤ = forward
+    syntax step-≤ x yRz x≤y = x ≤⟨ x≤y ⟩ yRz
+
+
+  -- Strict partial order syntax
+  module <-syntax where
+    infixr 2 step-<
+    step-< = forward
+    syntax step-< x yRz x<y = x <⟨ x<y ⟩ yRz
+
+
+  -- Subset order syntax
+  module ⊆-syntax where
+    infixr 2 step-⊆
+    step-⊆ = forward
+    syntax step-⊆ x yRz x⊆y = x ⊆⟨ x⊆y ⟩ yRz
+
+
+  -- Strict subset order syntax
+  module ⊂-syntax where
+    infixr 2 step-⊂
+    step-⊂ = forward
+    syntax step-⊂ x yRz x⊂y = x ⊂⟨ x⊂y ⟩ yRz
+
+
+  -- Square subset order syntax
+  module ⊑-syntax where
+    infixr 2 step-⊑
+    step-⊑ = forward
+    syntax step-⊑ x yRz x⊑y = x ⊑⟨ x⊑y ⟩ yRz
+
+
+  -- Strict square subset order syntax
+  module ⊏-syntax where
+    infixr 2 step-⊏
+    step-⊏ = forward
+    syntax step-⊏ x yRz x⊏y = x ⊏⟨ x⊏y ⟩ yRz
+
+
+  -- Divisibility syntax
+  module ∣-syntax where
+    infixr 2 step-∣
+    step-∣ = forward
+    syntax step-∣ x yRz x∣y = x ∣⟨ x∣y ⟩ yRz
+
+
+  -- Single-step syntax
+  module ⟶-syntax where
+    infixr 2 step-⟶
+    step-⟶ = forward
+    syntax step-⟶ x yRz x∣y = x ⟶⟨ x∣y ⟩ yRz
+
+
+  -- Multi-step syntax
+  module ⟶*-syntax where
+    infixr 2 step-⟶*
+    step-⟶* = forward
+    syntax step-⟶* x yRz x∣y = x ⟶*⟨ x∣y ⟩ yRz
+
+
+------------------------------------------------------------------------
+-- Syntax for bidirectional relations
+
+  module _
+    {U : REL B A ℓ₄}
+    (sym : Sym U R)
+    where
+
+    backward : ∀ x {y z} → S y z → U y x → T x z
+    backward x yRz x≈y = forward x yRz (sym x≈y)
+
+    -- Setoid equality syntax
+    module ≈-syntax where
+      infixr 2 step-≈-⟩ step-≈-⟨
+      step-≈-⟩ = forward
+      step-≈-⟨ = backward
+      syntax step-≈-⟩ x yRz x≈y = x ≈⟨ x≈y ⟩ yRz
+      syntax step-≈-⟨ x yRz y≈x = x ≈⟨ y≈x ⟨ yRz
+
+      -- Deprecated
+      infixr 2 step-≈ step-≈˘
+      step-≈ = step-≈-⟩
+      {-# WARNING_ON_USAGE step-≈
+      "Warning: step-≈ was deprecated in v2.0.
+      Please use step-≈-⟩ instead."
+      #-}
+      step-≈˘ = step-≈-⟨
+      {-# WARNING_ON_USAGE step-≈˘
+      "Warning: step-≈˘ and _≈˘⟨_⟩_ was deprecated in v2.0.
+      Please use step-≈-⟨ and _≈⟨_⟨_ instead."
+      #-}
+      syntax step-≈˘ x yRz y≈x = x ≈˘⟨ y≈x ⟩ yRz
+
+
+    -- Container equality syntax
+    module ≋-syntax where
+      infixr 2 step-≋-⟩ step-≋-⟨
+      step-≋-⟩ = forward
+      step-≋-⟨ = backward
+      syntax step-≋-⟩ x yRz x≋y = x ≋⟨ x≋y ⟩ yRz
+      syntax step-≋-⟨ x yRz y≋x = x ≋⟨ y≋x ⟨ yRz
+
+
+      -- Don't remove until https://github.com/agda/agda/issues/5617 fixed.
+      infixr 2 step-≋ step-≋˘
+      step-≋ = step-≋-⟩
+      {-# WARNING_ON_USAGE step-≋
+      "Warning: step-≋ was deprecated in v2.0.
+      Please use step-≋-⟩ instead."
+      #-}
+      step-≋˘ = step-≋-⟨
+      {-# WARNING_ON_USAGE step-≋˘
+      "Warning: step-≋˘ and _≋˘⟨_⟩_ was deprecated in v2.0.
+      Please use step-≋-⟨ and _≋⟨_⟨_ instead."
+      #-}
+      syntax step-≋˘ x yRz y≋x = x ≋˘⟨ y≋x ⟩ yRz
+
+
+    -- Other equality syntax
+    module ≃-syntax where
+      infixr 2 step-≃-⟩ step-≃-⟨
+      step-≃-⟩ = forward
+      step-≃-⟨ = backward
+      syntax step-≃-⟩ x yRz x≃y = x ≃⟨ x≃y ⟩ yRz
+      syntax step-≃-⟨ x yRz y≃x = x ≃⟨ y≃x ⟨ yRz
+
+
+    -- Apartness relation syntax
+    module #-syntax where
+      infixr 2 step-#-⟩ step-#-⟨
+      step-#-⟩ = forward
+      step-#-⟨ = backward
+      syntax step-#-⟩ x yRz x#y = x #⟨ x#y ⟩ yRz
+      syntax step-#-⟨ x yRz y#x = x #⟨ y#x ⟨ yRz
+
+      -- Don't remove until https://github.com/agda/agda/issues/5617 fixed.
+      infixr 2 step-# step-#˘
+      step-# = step-#-⟩
+      {-# WARNING_ON_USAGE step-#
+      "Warning: step-# was deprecated in v2.0.
+      Please use step-#-⟩ instead."
+      #-}
+      step-#˘ = step-#-⟨
+      {-# WARNING_ON_USAGE step-#˘
+      "Warning: step-#˘ and _#˘⟨_⟩_ was deprecated in v2.0.
+      Please use step-#-⟨ and _#⟨_⟨_ instead."
+      #-}
+      syntax step-#˘ x yRz y#x = x #˘⟨ y#x ⟩ yRz
+
+
+    -- Bijection syntax
+    module ⤖-syntax where
+      infixr 2 step-⤖ step-⬻
+      step-⤖ = forward
+      step-⬻ = backward
+      syntax step-⤖ x yRz x⤖y = x ⤖⟨ x⤖y ⟩ yRz
+      syntax step-⬻ x yRz y⤖x = x ⬻⟨ y⤖x ⟩ yRz
+
+
+    -- Inverse syntax
+    module ↔-syntax where
+      infixr 2 step-↔-⟩ step-↔-⟨
+      step-↔-⟩ = forward
+      step-↔-⟨ = backward
+      syntax step-↔-⟩ x yRz x↔y = x ↔⟨ x↔y ⟩ yRz
+      syntax step-↔-⟨ x yRz y↔x = x ↔⟨ y↔x ⟨ yRz
+
+
+    -- Inverse syntax
+    module ↭-syntax where
+      infixr 2 step-↭-⟩ step-↭-⟨
+      step-↭-⟩ = forward
+      step-↭-⟨ = backward
+      syntax step-↭-⟩ x yRz x↭y = x ↭⟨ x↭y ⟩ yRz
+      syntax step-↭-⟨ x yRz y↭x = x ↭⟨ y↭x ⟨ yRz
+
+
+      -- Don't remove until https://github.com/agda/agda/issues/5617 fixed.
+      infixr 2 step-↭ step-↭˘
+      step-↭ = forward
+      {-# WARNING_ON_USAGE step-↭
+      "Warning: step-↭ was deprecated in v2.0.
+      Please use step-↭-⟩ instead."
+      #-}
+      step-↭˘ = backward
+      {-# WARNING_ON_USAGE step-↭˘
+      "Warning: step-↭˘ and _↭˘⟨_⟩_ was deprecated in v2.0.
+      Please use step-↭-⟨ and _↭⟨_⟨_ instead."
+      #-}
+      syntax step-↭˘ x yRz y↭x = x ↭˘⟨ y↭x ⟩ yRz
+
+------------------------------------------------------------------------
+-- Propositional equality
+
+-- Crucially often the step function cannot just be `subst` or pattern
+-- match on `refl` as we often want to compute which constructor the
+-- relation begins with, in order for the implicit subrelation
+-- arguments to resolve. See `≡-noncomputable-syntax` below if this
+-- is not required.
+module ≡-syntax
+  (R : REL A B ℓ₁)
+  (step : Trans _≡_ R R)
+  where
+
+  infixr 2 step-≡-⟩  step-≡-∣ step-≡-⟨
+  step-≡-⟩ = forward R R step
+
+  step-≡-∣ : ∀ x {y} → R x y → R x y
+  step-≡-∣ x xRy = xRy
+
+  step-≡-⟨ = backward R R step P.sym
+
+  syntax step-≡-⟩ x yRz x≡y = x ≡⟨ x≡y ⟩ yRz
+  syntax step-≡-∣ x xRy     = x ≡⟨⟩ xRy
+  syntax step-≡-⟨ x yRz y≡x = x ≡⟨ y≡x ⟨ yRz
+
+
+  -- Don't remove until https://github.com/agda/agda/issues/5617 fixed.
+  infixr 2 step-≡ step-≡˘
+  step-≡ = step-≡-⟩
+  {-# WARNING_ON_USAGE step-≡
+  "Warning: step-≡ was deprecated in v2.0.
+  Please use step-≡-⟩ instead."
+  #-}
+  step-≡˘ = step-≡-⟨
+  {-# WARNING_ON_USAGE step-≡˘
+  "Warning: step-≡˘ and _≡˘⟨_⟩_ was deprecated in v2.0.
+  Please use step-≡-⟨ and _≡⟨_⟨_ instead."
+  #-}
+  syntax step-≡˘ x yRz y≡x = x ≡˘⟨ y≡x ⟩ yRz
+
+
+-- Unlike ≡-syntax above, chains of reasoning using this syntax will not
+-- reduce when proofs of propositional equality which are not definitionally
+-- equal to `refl` are passed.
+module ≡-noncomputing-syntax (R : REL A B ℓ₁) where
+
+  private
+    step : Trans _≡_ R R
+    step P.refl xRy = xRy
+
+  open ≡-syntax R step public
+
+------------------------------------------------------------------------
+-- Syntax for ending a chain of reasoning
+------------------------------------------------------------------------
+
+module end-syntax
+  (R : Rel A ℓ₁)
+  (reflexive : Reflexive R)
+  where
+
+  infix 3 _∎
+
+  _∎ : ∀ x → R x x
+  x ∎ = reflexive
+
+
\ No newline at end of file diff --git a/Relation.Binary.Reflection.html b/Relation.Binary.Reflection.html index a574a8fd..220ea9e7 100644 --- a/Relation.Binary.Reflection.html +++ b/Relation.Binary.Reflection.html @@ -8,98 +8,98 @@ {-# OPTIONS --cubical-compatible --safe #-} -open import Data.Fin.Base -open import Data.Nat.Base -open import Data.Vec.Base as Vec -open import Function.Base -open import Function.Bundles using (module Equivalence) -open import Level -open import Relation.Binary -import Relation.Binary.PropositionalEquality as P - --- Think of the parameters as follows: --- --- * Expr: A representation of code. --- * var: The Expr type should support a notion of variables. --- * ⟦_⟧: Computes the semantics of an expression. Takes an --- environment mapping variables to something. --- * ⟦_⇓⟧: Computes the semantics of the normal form of the --- expression. --- * correct: Normalisation preserves the semantics. --- --- Given these parameters two "tactics" are returned, prove and solve. --- --- For an example of the use of this module, see Algebra.RingSolver. - -module Relation.Binary.Reflection - {e a s} - {Expr : ℕ → Set e} {A : Set a} - (Sem : Setoid a s) - (var : ∀ {n} → Fin n → Expr n) - (⟦_⟧ ⟦_⇓⟧ : ∀ {n} → Expr n → Vec A n → Setoid.Carrier Sem) - (correct : ∀ {n} (e : Expr n) ρ → - ⟦ e ⇓⟧ ρ ⟨ Setoid._≈_ Sem ⟩ ⟦ e ⟧ ρ) - where - -open import Data.Vec.N-ary -open import Data.Product -import Relation.Binary.Reasoning.Setoid as Eq - -open Setoid Sem -open Eq Sem - --- If two normalised expressions are semantically equal, then their --- non-normalised forms are also equal. - -prove : ∀ {n} (ρ : Vec A n) e₁ e₂ → - ⟦ e₁ ⇓⟧ ρ ≈ ⟦ e₂ ⇓⟧ ρ → - ⟦ e₁ ⟧ ρ ≈ ⟦ e₂ ⟧ ρ -prove ρ e₁ e₂ hyp = begin - ⟦ e₁ ⟧ ρ ≈⟨ sym (correct e₁ ρ) ⟩ - ⟦ e₁ ⇓⟧ ρ ≈⟨ hyp ⟩ - ⟦ e₂ ⇓⟧ ρ ≈⟨ correct e₂ ρ ⟩ - ⟦ e₂ ⟧ ρ ∎ - --- Applies the function to all possible "variables". - -close : ∀ {A : Set e} n → N-ary n (Expr n) A → A -close n f = f $ⁿ Vec.map var (allFin n) - --- A variant of prove which should in many cases be easier to use, --- because variables and environments are handled in a less explicit --- way. --- --- If the type signature of solve is a bit daunting, then it may be --- helpful to instantiate n with a small natural number and normalise --- the remainder of the type. - -solve : ∀ n (f : N-ary n (Expr n) (Expr n × Expr n)) → - Eqʰ n _≈_ (curryⁿ ⟦ proj₁ (close n f) ⇓⟧) (curryⁿ ⟦ proj₂ (close n f) ⇓⟧) → - Eq n _≈_ (curryⁿ ⟦ proj₁ (close n f) ⟧) (curryⁿ ⟦ proj₂ (close n f) ⟧) -solve n f hyp = - curryⁿ-cong _≈_ ⟦ proj₁ (close n f) ⟧ ⟦ proj₂ (close n f) ⟧ - (λ ρ → prove ρ (proj₁ (close n f)) (proj₂ (close n f)) - (curryⁿ-cong⁻¹ _≈_ - ⟦ proj₁ (close n f) ⇓⟧ ⟦ proj₂ (close n f) ⇓⟧ - (Eqʰ-to-Eq n _≈_ hyp) ρ)) - --- A variant of solve which does not require that the normal form --- equality is proved for an arbitrary environment. - -solve₁ : ∀ n (f : N-ary n (Expr n) (Expr n × Expr n)) → - ∀ⁿ n (curryⁿ λ ρ → - ⟦ proj₁ (close n f) ⇓⟧ ρ ≈ ⟦ proj₂ (close n f) ⇓⟧ ρ → - ⟦ proj₁ (close n f) ⟧ ρ ≈ ⟦ proj₂ (close n f) ⟧ ρ) -solve₁ n f = - Equivalence.from (uncurry-∀ⁿ n) λ ρ → - P.subst id (P.sym (left-inverse (λ _ → _ ≈ _ → _ ≈ _) ρ)) - (prove ρ (proj₁ (close n f)) (proj₂ (close n f))) - --- A variant of _,_ which is intended to make uses of solve and solve₁ --- look a bit nicer. - -infix 4 _⊜_ - -_⊜_ : ∀ {n} → Expr n → Expr n → Expr n × Expr n -_⊜_ = _,_ +open import Data.Fin.Base using (Fin) +open import Data.Nat.Base using (ℕ) +open import Data.Vec.Base as Vec using (Vec; allFin) +open import Function.Base using (id; _⟨_⟩_) +open import Function.Bundles using (module Equivalence) +open import Level using (Level) +open import Relation.Binary.Bundles using (Setoid) +import Relation.Binary.PropositionalEquality.Core as P + +-- Think of the parameters as follows: +-- +-- * Expr: A representation of code. +-- * var: The Expr type should support a notion of variables. +-- * ⟦_⟧: Computes the semantics of an expression. Takes an +-- environment mapping variables to something. +-- * ⟦_⇓⟧: Computes the semantics of the normal form of the +-- expression. +-- * correct: Normalisation preserves the semantics. +-- +-- Given these parameters two "tactics" are returned, prove and solve. +-- +-- For an example of the use of this module, see Algebra.RingSolver. + +module Relation.Binary.Reflection + {e a s} + {Expr : ℕ → Set e} {A : Set a} + (Sem : Setoid a s) + (var : ∀ {n} → Fin n → Expr n) + (⟦_⟧ ⟦_⇓⟧ : ∀ {n} → Expr n → Vec A n → Setoid.Carrier Sem) + (correct : ∀ {n} (e : Expr n) ρ → + ⟦ e ⇓⟧ ρ ⟨ Setoid._≈_ Sem ⟩ ⟦ e ⟧ ρ) + where + +open import Data.Vec.N-ary +open import Data.Product.Base using (_×_; _,_; proj₁; proj₂) +import Relation.Binary.Reasoning.Setoid as Eq + +open Setoid Sem +open Eq Sem + +-- If two normalised expressions are semantically equal, then their +-- non-normalised forms are also equal. + +prove : ∀ {n} (ρ : Vec A n) e₁ e₂ → + ⟦ e₁ ⇓⟧ ρ ≈ ⟦ e₂ ⇓⟧ ρ → + ⟦ e₁ ⟧ ρ ≈ ⟦ e₂ ⟧ ρ +prove ρ e₁ e₂ hyp = begin + ⟦ e₁ ⟧ ρ ≈⟨ sym (correct e₁ ρ) ⟩ + ⟦ e₁ ⇓⟧ ρ ≈⟨ hyp ⟩ + ⟦ e₂ ⇓⟧ ρ ≈⟨ correct e₂ ρ ⟩ + ⟦ e₂ ⟧ ρ ∎ + +-- Applies the function to all possible "variables". + +close : ∀ {A : Set e} n → N-ary n (Expr n) A → A +close n f = f $ⁿ Vec.map var (allFin n) + +-- A variant of prove which should in many cases be easier to use, +-- because variables and environments are handled in a less explicit +-- way. +-- +-- If the type signature of solve is a bit daunting, then it may be +-- helpful to instantiate n with a small natural number and normalise +-- the remainder of the type. + +solve : ∀ n (f : N-ary n (Expr n) (Expr n × Expr n)) → + Eqʰ n _≈_ (curryⁿ ⟦ proj₁ (close n f) ⇓⟧) (curryⁿ ⟦ proj₂ (close n f) ⇓⟧) → + Eq n _≈_ (curryⁿ ⟦ proj₁ (close n f) ⟧) (curryⁿ ⟦ proj₂ (close n f) ⟧) +solve n f hyp = + curryⁿ-cong _≈_ ⟦ proj₁ (close n f) ⟧ ⟦ proj₂ (close n f) ⟧ + (λ ρ → prove ρ (proj₁ (close n f)) (proj₂ (close n f)) + (curryⁿ-cong⁻¹ _≈_ + ⟦ proj₁ (close n f) ⇓⟧ ⟦ proj₂ (close n f) ⇓⟧ + (Eqʰ-to-Eq n _≈_ hyp) ρ)) + +-- A variant of solve which does not require that the normal form +-- equality is proved for an arbitrary environment. + +solve₁ : ∀ n (f : N-ary n (Expr n) (Expr n × Expr n)) → + ∀ⁿ n (curryⁿ λ ρ → + ⟦ proj₁ (close n f) ⇓⟧ ρ ≈ ⟦ proj₂ (close n f) ⇓⟧ ρ → + ⟦ proj₁ (close n f) ⟧ ρ ≈ ⟦ proj₂ (close n f) ⟧ ρ) +solve₁ n f = + Equivalence.from (uncurry-∀ⁿ n) λ ρ → + P.subst id (P.sym (left-inverse (λ _ → _ ≈ _ → _ ≈ _) ρ)) + (prove ρ (proj₁ (close n f)) (proj₂ (close n f))) + +-- A variant of _,_ which is intended to make uses of solve and solve₁ +-- look a bit nicer. + +infix 4 _⊜_ + +_⊜_ : ∀ {n} → Expr n → Expr n → Expr n × Expr n +_⊜_ = _,_ \ No newline at end of file diff --git a/Relation.Binary.Structures.Biased.html b/Relation.Binary.Structures.Biased.html new file mode 100644 index 00000000..18a4fd0d --- /dev/null +++ b/Relation.Binary.Structures.Biased.html @@ -0,0 +1,51 @@ + +Relation.Binary.Structures.Biased
------------------------------------------------------------------------
+-- The Agda standard library
+--
+-- Ways to give instances of certain structures where some fields can
+-- be given in terms of others
+------------------------------------------------------------------------
+
+-- The contents of this module should be accessed via `Relation.Binary`.
+
+{-# OPTIONS --cubical-compatible --safe #-}
+
+open import Relation.Binary.Core
+
+module Relation.Binary.Structures.Biased
+  {a ℓ} {A : Set a} -- The underlying set
+  (_≈_ : Rel A ℓ)   -- The underlying equality relation
+  where
+
+open import Level using (Level; _⊔_)
+open import Relation.Binary.Consequences
+open import Relation.Binary.Definitions
+open import Relation.Binary.Structures _≈_
+
+private
+  variable
+    ℓ₂ : Level
+
+-- To construct a StrictTotalOrder you only need to prove transitivity and
+-- trichotomy as the current implementation of `Trichotomous` subsumes
+-- irreflexivity and asymmetry.
+record IsStrictTotalOrderᶜ (_<_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where
+  field
+    isEquivalence : IsEquivalence
+    trans         : Transitive _<_
+    compare       : Trichotomous _≈_ _<_
+
+  isStrictTotalOrderᶜ : IsStrictTotalOrder _<_
+  isStrictTotalOrderᶜ = record
+    { isStrictPartialOrder = record
+      { isEquivalence = isEquivalence
+      ; irrefl = tri⇒irr compare
+      ; trans = trans
+      ; <-resp-≈ = trans∧tri⇒resp Eq.sym Eq.trans trans compare
+      }
+    ; compare = compare
+    } where module Eq = IsEquivalence isEquivalence
+
+open IsStrictTotalOrderᶜ public
+  using (isStrictTotalOrderᶜ)
+
\ No newline at end of file diff --git a/Relation.Binary.Structures.html b/Relation.Binary.Structures.html index efef6aff..4a49b538 100644 --- a/Relation.Binary.Structures.html +++ b/Relation.Binary.Structures.html @@ -13,284 +13,308 @@ module Relation.Binary.Structures {a ℓ} {A : Set a} -- The underlying set - (_≈_ : Rel A ℓ) -- The underlying equality relation + (_≈_ : Rel A ℓ) -- The underlying equality relation where -open import Data.Product using (proj₁; proj₂; _,_) -open import Level using (Level; _⊔_) -open import Relation.Nullary.Negation.Core using (¬_) -open import Relation.Binary.PropositionalEquality.Core as P using (_≡_) -open import Relation.Binary.Consequences -open import Relation.Binary.Definitions +open import Data.Product.Base using (proj₁; proj₂; _,_) +open import Level using (Level; _⊔_) +open import Relation.Nullary.Negation.Core using (¬_) +open import Relation.Binary.PropositionalEquality.Core as P using (_≡_) +open import Relation.Binary.Consequences +open import Relation.Binary.Definitions + +private + variable + ℓ₂ : Level + +------------------------------------------------------------------------ +-- Equivalences +------------------------------------------------------------------------ +-- Note all the following equivalences refer to the equality provided +-- as a module parameter at the top of this file. + +record IsPartialEquivalence : Set (a ⊔ ℓ) where + field + sym : Symmetric _≈_ + trans : Transitive _≈_ -private - variable - ℓ₂ : Level +-- The preorders of this library are defined in terms of an underlying +-- equivalence relation, and hence equivalence relations are not +-- defined in terms of preorders. + +-- To preserve backwards compatability, equivalence relations are +-- not defined in terms of their partial counterparts. + +record IsEquivalence : Set (a ⊔ ℓ) where + field + refl : Reflexive _≈_ + sym : Symmetric _≈_ + trans : Transitive _≈_ + + reflexive : _≡_ ⇒ _≈_ + reflexive P.refl = refl + + isPartialEquivalence : IsPartialEquivalence + isPartialEquivalence = record + { sym = sym + ; trans = trans + } ------------------------------------------------------------------------- --- Equivalences ------------------------------------------------------------------------- --- Note all the following equivalences refer to the equality provided --- as a module parameter at the top of this file. -record IsPartialEquivalence : Set (a ⊔ ℓ) where - field - sym : Symmetric _≈_ - trans : Transitive _≈_ +record IsDecEquivalence : Set (a ⊔ ℓ) where + infix 4 _≟_ + field + isEquivalence : IsEquivalence + _≟_ : Decidable _≈_ --- The preorders of this library are defined in terms of an underlying --- equivalence relation, and hence equivalence relations are not --- defined in terms of preorders. + open IsEquivalence isEquivalence public --- To preserve backwards compatability, equivalence relations are --- not defined in terms of their partial counterparts. -record IsEquivalence : Set (a ⊔ ℓ) where - field - refl : Reflexive _≈_ - sym : Symmetric _≈_ - trans : Transitive _≈_ +------------------------------------------------------------------------ +-- Preorders +------------------------------------------------------------------------ - reflexive : _≡_ ⇒ _≈_ - reflexive P.refl = refl +record IsPreorder (_≲_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where + field + isEquivalence : IsEquivalence + -- Reflexivity is expressed in terms of the underlying equality: + reflexive : _≈_ ⇒ _≲_ + trans : Transitive _≲_ - isPartialEquivalence : IsPartialEquivalence - isPartialEquivalence = record - { sym = sym - ; trans = trans - } + module Eq = IsEquivalence isEquivalence + refl : Reflexive _≲_ + refl = reflexive Eq.refl -record IsDecEquivalence : Set (a ⊔ ℓ) where - infix 4 _≟_ - field - isEquivalence : IsEquivalence - _≟_ : Decidable _≈_ + ≲-respˡ-≈ : _≲_ Respectsˡ _≈_ + ≲-respˡ-≈ x≈y x∼z = trans (reflexive (Eq.sym x≈y)) x∼z - open IsEquivalence isEquivalence public + ≲-respʳ-≈ : _≲_ Respectsʳ _≈_ + ≲-respʳ-≈ x≈y z∼x = trans z∼x (reflexive x≈y) + ≲-resp-≈ : _≲_ Respects₂ _≈_ + ≲-resp-≈ = ≲-respʳ-≈ , ≲-respˡ-≈ ------------------------------------------------------------------------- --- Preorders ------------------------------------------------------------------------- + ∼-respˡ-≈ = ≲-respˡ-≈ + {-# WARNING_ON_USAGE ∼-respˡ-≈ + "Warning: ∼-respˡ-≈ was deprecated in v2.0. + Please use ≲-respˡ-≈ instead. " + #-} + ∼-respʳ-≈ = ≲-respʳ-≈ + {-# WARNING_ON_USAGE ∼-respʳ-≈ + "Warning: ∼-respʳ-≈ was deprecated in v2.0. + Please use ≲-respʳ-≈ instead. " + #-} + ∼-resp-≈ = ≲-resp-≈ + {-# WARNING_ON_USAGE ∼-resp-≈ + "Warning: ∼-resp-≈ was deprecated in v2.0. + Please use ≲-resp-≈ instead. " + #-} -record IsPreorder (_∼_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where - field - isEquivalence : IsEquivalence - -- Reflexivity is expressed in terms of the underlying equality: - reflexive : _≈_ ⇒ _∼_ - trans : Transitive _∼_ - module Eq = IsEquivalence isEquivalence +record IsTotalPreorder (_≲_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where + field + isPreorder : IsPreorder _≲_ + total : Total _≲_ - refl : Reflexive _∼_ - refl = reflexive Eq.refl + open IsPreorder isPreorder public - ∼-respˡ-≈ : _∼_ Respectsˡ _≈_ - ∼-respˡ-≈ x≈y x∼z = trans (reflexive (Eq.sym x≈y)) x∼z - ∼-respʳ-≈ : _∼_ Respectsʳ _≈_ - ∼-respʳ-≈ x≈y z∼x = trans z∼x (reflexive x≈y) +------------------------------------------------------------------------ +-- Partial orders +------------------------------------------------------------------------ - ∼-resp-≈ : _∼_ Respects₂ _≈_ - ∼-resp-≈ = ∼-respʳ-≈ , ∼-respˡ-≈ +record IsPartialOrder (_≤_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where + field + isPreorder : IsPreorder _≤_ + antisym : Antisymmetric _≈_ _≤_ + open IsPreorder isPreorder public + renaming + ( ∼-respˡ-≈ to ≤-respˡ-≈ + ; ∼-respʳ-≈ to ≤-respʳ-≈ + ; ∼-resp-≈ to ≤-resp-≈ + ) -record IsTotalPreorder (_≲_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where - field - isPreorder : IsPreorder _≲_ - total : Total _≲_ - open IsPreorder isPreorder public - renaming - ( ∼-respˡ-≈ to ≲-respˡ-≈ - ; ∼-respʳ-≈ to ≲-respʳ-≈ - ; ∼-resp-≈ to ≲-resp-≈ - ) +record IsDecPartialOrder (_≤_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where + infix 4 _≟_ _≤?_ + field + isPartialOrder : IsPartialOrder _≤_ + _≟_ : Decidable _≈_ + _≤?_ : Decidable _≤_ + open IsPartialOrder isPartialOrder public + hiding (module Eq) ------------------------------------------------------------------------- --- Partial orders ------------------------------------------------------------------------- + module Eq where -record IsPartialOrder (_≤_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where - field - isPreorder : IsPreorder _≤_ - antisym : Antisymmetric _≈_ _≤_ + isDecEquivalence : IsDecEquivalence + isDecEquivalence = record + { isEquivalence = isEquivalence + ; _≟_ = _≟_ + } - open IsPreorder isPreorder public - renaming - ( ∼-respˡ-≈ to ≤-respˡ-≈ - ; ∼-respʳ-≈ to ≤-respʳ-≈ - ; ∼-resp-≈ to ≤-resp-≈ - ) + open IsDecEquivalence isDecEquivalence public -record IsDecPartialOrder (_≤_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where - infix 4 _≟_ _≤?_ - field - isPartialOrder : IsPartialOrder _≤_ - _≟_ : Decidable _≈_ - _≤?_ : Decidable _≤_ +record IsStrictPartialOrder (_<_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where + field + isEquivalence : IsEquivalence + irrefl : Irreflexive _≈_ _<_ + trans : Transitive _<_ + <-resp-≈ : _<_ Respects₂ _≈_ - open IsPartialOrder isPartialOrder public - hiding (module Eq) + module Eq = IsEquivalence isEquivalence - module Eq where + asym : Asymmetric _<_ + asym {x} {y} = trans∧irr⇒asym Eq.refl trans irrefl {x = x} {y} - isDecEquivalence : IsDecEquivalence - isDecEquivalence = record - { isEquivalence = isEquivalence - ; _≟_ = _≟_ - } + <-respʳ-≈ : _<_ Respectsʳ _≈_ + <-respʳ-≈ = proj₁ <-resp-≈ - open IsDecEquivalence isDecEquivalence public + <-respˡ-≈ : _<_ Respectsˡ _≈_ + <-respˡ-≈ = proj₂ <-resp-≈ -record IsStrictPartialOrder (_<_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where - field - isEquivalence : IsEquivalence - irrefl : Irreflexive _≈_ _<_ - trans : Transitive _<_ - <-resp-≈ : _<_ Respects₂ _≈_ +record IsDecStrictPartialOrder (_<_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where + infix 4 _≟_ _<?_ + field + isStrictPartialOrder : IsStrictPartialOrder _<_ + _≟_ : Decidable _≈_ + _<?_ : Decidable _<_ - module Eq = IsEquivalence isEquivalence + private + module SPO = IsStrictPartialOrder isStrictPartialOrder - asym : Asymmetric _<_ - asym {x} {y} = trans∧irr⇒asym Eq.refl trans irrefl {x = x} {y} + open SPO public hiding (module Eq) - <-respʳ-≈ : _<_ Respectsʳ _≈_ - <-respʳ-≈ = proj₁ <-resp-≈ + module Eq where - <-respˡ-≈ : _<_ Respectsˡ _≈_ - <-respˡ-≈ = proj₂ <-resp-≈ + isDecEquivalence : IsDecEquivalence + isDecEquivalence = record + { isEquivalence = SPO.isEquivalence + ; _≟_ = _≟_ + } + open IsDecEquivalence isDecEquivalence public -record IsDecStrictPartialOrder (_<_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where - infix 4 _≟_ _<?_ - field - isStrictPartialOrder : IsStrictPartialOrder _<_ - _≟_ : Decidable _≈_ - _<?_ : Decidable _<_ - private - module SPO = IsStrictPartialOrder isStrictPartialOrder +------------------------------------------------------------------------ +-- Total orders +------------------------------------------------------------------------ - open SPO public hiding (module Eq) +record IsTotalOrder (_≤_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where + field + isPartialOrder : IsPartialOrder _≤_ + total : Total _≤_ - module Eq where + open IsPartialOrder isPartialOrder public - isDecEquivalence : IsDecEquivalence - isDecEquivalence = record - { isEquivalence = SPO.isEquivalence - ; _≟_ = _≟_ - } + isTotalPreorder : IsTotalPreorder _≤_ + isTotalPreorder = record + { isPreorder = isPreorder + ; total = total + } - open IsDecEquivalence isDecEquivalence public +record IsDecTotalOrder (_≤_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where + infix 4 _≟_ _≤?_ + field + isTotalOrder : IsTotalOrder _≤_ + _≟_ : Decidable _≈_ + _≤?_ : Decidable _≤_ ------------------------------------------------------------------------- --- Total orders ------------------------------------------------------------------------- + open IsTotalOrder isTotalOrder public + hiding (module Eq) -record IsTotalOrder (_≤_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where - field - isPartialOrder : IsPartialOrder _≤_ - total : Total _≤_ + isDecPartialOrder : IsDecPartialOrder _≤_ + isDecPartialOrder = record + { isPartialOrder = isPartialOrder + ; _≟_ = _≟_ + ; _≤?_ = _≤?_ + } - open IsPartialOrder isPartialOrder public + module Eq where - isTotalPreorder : IsTotalPreorder _≤_ - isTotalPreorder = record - { isPreorder = isPreorder - ; total = total - } + isDecEquivalence : IsDecEquivalence + isDecEquivalence = record + { isEquivalence = isEquivalence + ; _≟_ = _≟_ + } + open IsDecEquivalence isDecEquivalence public -record IsDecTotalOrder (_≤_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where - infix 4 _≟_ _≤?_ - field - isTotalOrder : IsTotalOrder _≤_ - _≟_ : Decidable _≈_ - _≤?_ : Decidable _≤_ - open IsTotalOrder isTotalOrder public - hiding (module Eq) +-- Note that these orders are decidable. The current implementation +-- of `Trichotomous` subsumes irreflexivity and asymmetry. See +-- `Relation.Binary.Structures.Biased` for ways of constructing this +-- record without having to prove `isStrictPartialOrder`. - isDecPartialOrder : IsDecPartialOrder _≤_ - isDecPartialOrder = record - { isPartialOrder = isPartialOrder - ; _≟_ = _≟_ - ; _≤?_ = _≤?_ - } +record IsStrictTotalOrder (_<_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where + field + isStrictPartialOrder : IsStrictPartialOrder _<_ + compare : Trichotomous _≈_ _<_ - module Eq where + open IsStrictPartialOrder isStrictPartialOrder public + hiding (module Eq) - isDecEquivalence : IsDecEquivalence - isDecEquivalence = record - { isEquivalence = isEquivalence - ; _≟_ = _≟_ - } + -- `Trichotomous` necessarily separates out the equality case so + -- it implies decidability. + infix 4 _≟_ _<?_ - open IsDecEquivalence isDecEquivalence public + _≟_ : Decidable _≈_ + _≟_ = tri⇒dec≈ compare + _<?_ : Decidable _<_ + _<?_ = tri⇒dec< compare --- 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. + isDecStrictPartialOrder : IsDecStrictPartialOrder _<_ + isDecStrictPartialOrder = record + { isStrictPartialOrder = isStrictPartialOrder + ; _≟_ = _≟_ + ; _<?_ = _<?_ + } -record IsStrictTotalOrder (_<_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where - field - isEquivalence : IsEquivalence - trans : Transitive _<_ - compare : Trichotomous _≈_ _<_ + -- Redefine the `Eq` module to include decidability proofs + module Eq where - infix 4 _≟_ _<?_ + isDecEquivalence : IsDecEquivalence + isDecEquivalence = record + { isEquivalence = isEquivalence + ; _≟_ = _≟_ + } - _≟_ : Decidable _≈_ - _≟_ = tri⇒dec≈ compare + open IsDecEquivalence isDecEquivalence public - _<?_ : Decidable _<_ - _<?_ = tri⇒dec< compare + isDecEquivalence : IsDecEquivalence + isDecEquivalence = record + { isEquivalence = isEquivalence + ; _≟_ = _≟_ + } + {-# WARNING_ON_USAGE isDecEquivalence + "Warning: isDecEquivalence was deprecated in v2.0. + Please use Eq.isDecEquivalence instead. " + #-} - isDecEquivalence : IsDecEquivalence - isDecEquivalence = record - { isEquivalence = isEquivalence - ; _≟_ = _≟_ - } +record IsDenseLinearOrder (_<_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where + field + isStrictTotalOrder : IsStrictTotalOrder _<_ + dense : Dense _<_ + + open IsStrictTotalOrder isStrictTotalOrder public - module Eq = IsDecEquivalence isDecEquivalence - isStrictPartialOrder : IsStrictPartialOrder _<_ - isStrictPartialOrder = record - { isEquivalence = isEquivalence - ; irrefl = tri⇒irr compare - ; trans = trans - ; <-resp-≈ = trans∧tri⇒resp Eq.sym Eq.trans trans compare - } +------------------------------------------------------------------------ +-- Apartness relations +------------------------------------------------------------------------ + +record IsApartnessRelation (_#_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where + field + irrefl : Irreflexive _≈_ _#_ + sym : Symmetric _#_ + cotrans : Cotransitive _#_ - isDecStrictPartialOrder : IsDecStrictPartialOrder _<_ - isDecStrictPartialOrder = record - { isStrictPartialOrder = isStrictPartialOrder - ; _≟_ = _≟_ - ; _<?_ = _<?_ - } - - open IsStrictPartialOrder isStrictPartialOrder public - using (irrefl; asym; <-respʳ-≈; <-respˡ-≈; <-resp-≈) - - ------------------------------------------------------------------------- --- Apartness relations ------------------------------------------------------------------------- - -record IsApartnessRelation (_#_ : Rel A ℓ₂) : Set (a ⊔ ℓ ⊔ ℓ₂) where - field - irrefl : Irreflexive _≈_ _#_ - sym : Symmetric _#_ - cotrans : Cotransitive _#_ - - _¬#_ : A → A → Set _ - x ¬# y = ¬ (x # y) + _¬#_ : A → A → Set _ + x ¬# y = ¬ (x # y) \ No newline at end of file diff --git a/Relation.Binary.html b/Relation.Binary.html index 8e695974..7eea9d05 100644 --- a/Relation.Binary.html +++ b/Relation.Binary.html @@ -15,5 +15,6 @@ open import Relation.Binary.Core public open import Relation.Binary.Definitions public open import Relation.Binary.Structures public -open import Relation.Binary.Bundles public +open import Relation.Binary.Structures.Biased public +open import Relation.Binary.Bundles public \ No newline at end of file diff --git a/Relation.Nullary.Decidable.Core.html b/Relation.Nullary.Decidable.Core.html index c4128ccf..a0836d95 100644 --- a/Relation.Nullary.Decidable.Core.html +++ b/Relation.Nullary.Decidable.Core.html @@ -13,169 +13,188 @@ module Relation.Nullary.Decidable.Core where open import Level using (Level; Lift) -open import Data.Bool.Base using (Bool; false; true; not; T; _∧_; _∨_) +open import Data.Bool.Base using (Bool; T; false; true; not; _∧_; _∨_) open import Data.Unit.Base using (⊤) open import Data.Empty using (⊥) open import Data.Empty.Irrelevant using (⊥-elim) -open import Data.Product using (_×_) -open import Data.Sum.Base using (_⊎_) -open import Function.Base using (_∘_; const; _$_; flip) -open import Relation.Nullary.Reflects -open import Relation.Nullary.Negation.Core +open import Data.Product.Base using (_×_) +open import Data.Sum.Base using (_⊎_) +open import Function.Base using (_∘_; const; _$_; flip) +open import Relation.Nullary.Reflects +open import Relation.Nullary.Negation.Core -private - variable - p q : Level - P : Set p - Q : Set q +private + variable + a b : Level + A B : Set a ------------------------------------------------------------------------- --- Definition. +------------------------------------------------------------------------ +-- Definition. --- Decidability proofs have two parts: the `does` term which contains --- the boolean result and the `proof` term which contains a proof that --- reflects the boolean result. This definition allows the boolean --- part of the decision procedure to compute independently from the --- proof. This leads to better computational behaviour when we only care --- about the result and not the proof. See README.Decidability for --- further details. +-- Decidability proofs have two parts: the `does` term which contains +-- the boolean result and the `proof` term which contains a proof that +-- reflects the boolean result. This definition allows the boolean +-- part of the decision procedure to compute independently from the +-- proof. This leads to better computational behaviour when we only care +-- about the result and not the proof. See README.Design.Decidability +-- for further details. -infix 2 _because_ +infix 2 _because_ -record Dec {p} (P : Set p) : Set p where - constructor _because_ - field - does : Bool - proof : Reflects P does +record Dec (A : Set a) : Set a where + constructor _because_ + field + does : Bool + proof : Reflects A does -open Dec public +open Dec public -pattern yes p = true because ofʸ p -pattern no ¬p = false because ofⁿ ¬p +pattern yes a = true because ofʸ a +pattern no ¬a = false because ofⁿ ¬a ------------------------------------------------------------------------- --- Recompute +------------------------------------------------------------------------ +-- Flattening --- Given an irrelevant proof of a decidable type, a proof can --- be recomputed and subsequently used in relevant contexts. -recompute : ∀ {a} {A : Set a} → Dec A → .A → A -recompute (yes x) _ = x -recompute (no ¬p) x = ⊥-elim (¬p x) +module _ {A : Set a} where ------------------------------------------------------------------------- --- Interaction with negation, sum, product etc. + From-yes : Dec A → Set a + From-yes (true because _) = A + From-yes (false because _) = Lift a ⊤ -infixr 1 _⊎-dec_ -infixr 2 _×-dec_ _→-dec_ + From-no : Dec A → Set a + From-no (false because _) = ¬ A + From-no (true because _) = Lift a ⊤ -¬? : Dec P → Dec (¬ P) -does (¬? p?) = not (does p?) -proof (¬? p?) = ¬-reflects (proof p?) +------------------------------------------------------------------------ +-- Recompute -_×-dec_ : Dec P → Dec Q → Dec (P × Q) -does (p? ×-dec q?) = does p? ∧ does q? -proof (p? ×-dec q?) = proof p? ×-reflects proof q? +-- Given an irrelevant proof of a decidable type, a proof can +-- be recomputed and subsequently used in relevant contexts. +recompute : Dec A → .A → A +recompute (yes a) _ = a +recompute (no ¬a) a = ⊥-elim (¬a a) -_⊎-dec_ : Dec P → Dec Q → Dec (P ⊎ Q) -does (p? ⊎-dec q?) = does p? ∨ does q? -proof (p? ⊎-dec q?) = proof p? ⊎-reflects proof q? +------------------------------------------------------------------------ +-- Interaction with negation, sum, product etc. -_→-dec_ : Dec P → Dec Q → Dec (P → Q) -does (p? →-dec q?) = not (does p?) ∨ does q? -proof (p? →-dec q?) = proof p? →-reflects proof q? +infixr 1 _⊎-dec_ +infixr 2 _×-dec_ _→-dec_ ------------------------------------------------------------------------- --- Relationship with booleans +T? : ∀ x → Dec (T x) +T? x = x because T-reflects x --- `isYes` is a stricter version of `does`. The lack of computation means that --- we can recover the proposition `P` from `isYes P?` by unification. This is --- useful when we are using the decision procedure for proof automation. +¬? : Dec A → Dec (¬ A) +does (¬? a?) = not (does a?) +proof (¬? a?) = ¬-reflects (proof a?) -isYes : Dec P → Bool -isYes (true because _) = true -isYes (false because _) = false +_×-dec_ : Dec A → Dec B → Dec (A × B) +does (a? ×-dec b?) = does a? ∧ does b? +proof (a? ×-dec b?) = proof a? ×-reflects proof b? -isNo : Dec P → Bool -isNo = not ∘ isYes +_⊎-dec_ : Dec A → Dec B → Dec (A ⊎ B) +does (a? ⊎-dec b?) = does a? ∨ does b? +proof (a? ⊎-dec b?) = proof a? ⊎-reflects proof b? -True : Dec P → Set -True Q = T (isYes Q) +_→-dec_ : Dec A → Dec B → Dec (A → B) +does (a? →-dec b?) = not (does a?) ∨ does b? +proof (a? →-dec b?) = proof a? →-reflects proof b? -False : Dec P → Set -False Q = T (isNo Q) +------------------------------------------------------------------------ +-- Relationship with booleans --- The traditional name for isYes is ⌊_⌋, indicating the stripping of evidence. -⌊_⌋ = isYes +-- `isYes` is a stricter version of `does`. The lack of computation +-- means that we can recover the proposition `P` from `isYes a?` by +-- unification. This is useful when we are using the decision procedure +-- for proof automation. ------------------------------------------------------------------------- --- Witnesses +isYes : Dec A → Bool +isYes (true because _) = true +isYes (false because _) = false --- Gives a witness to the "truth". -toWitness : {Q : Dec P} → True Q → P -toWitness {Q = true because [p]} _ = invert [p] -toWitness {Q = false because _ } () +isNo : Dec A → Bool +isNo = not ∘ isYes --- Establishes a "truth", given a witness. -fromWitness : {Q : Dec P} → P → True Q -fromWitness {Q = true because _ } = const _ -fromWitness {Q = false because [¬p]} = invert [¬p] +True : Dec A → Set +True = T ∘ isYes --- Variants for False. -toWitnessFalse : {Q : Dec P} → False Q → ¬ P -toWitnessFalse {Q = true because _ } () -toWitnessFalse {Q = false because [¬p]} _ = invert [¬p] +False : Dec A → Set +False = T ∘ isNo -fromWitnessFalse : {Q : Dec P} → ¬ P → False Q -fromWitnessFalse {Q = true because [p]} = flip _$_ (invert [p]) -fromWitnessFalse {Q = false because _ } = const _ +-- The traditional name for isYes is ⌊_⌋, indicating the stripping of evidence. +⌊_⌋ = isYes -module _ {p} {P : Set p} where +------------------------------------------------------------------------ +-- Witnesses --- If a decision procedure returns "yes", then we can extract the --- proof using from-yes. +-- Gives a witness to the "truth". +toWitness : {a? : Dec A} → True a? → A +toWitness {a? = true because [a]} _ = invert [a] +toWitness {a? = false because _ } () - From-yes : Dec P → Set p - From-yes (true because _) = P - From-yes (false because _) = Lift p ⊤ +-- Establishes a "truth", given a witness. +fromWitness : {a? : Dec A} → A → True a? +fromWitness {a? = true because _ } = const _ +fromWitness {a? = false because [¬a]} = invert [¬a] - from-yes : (p : Dec P) → From-yes p - from-yes (true because [p]) = invert [p] - from-yes (false because _ ) = _ +-- Variants for False. +toWitnessFalse : {a? : Dec A} → False a? → ¬ A +toWitnessFalse {a? = true because _ } () +toWitnessFalse {a? = false because [¬a]} _ = invert [¬a] --- If a decision procedure returns "no", then we can extract the proof --- using from-no. +fromWitnessFalse : {a? : Dec A} → ¬ A → False a? +fromWitnessFalse {a? = true because [a]} = flip _$_ (invert [a]) +fromWitnessFalse {a? = false because _ } = const _ - From-no : Dec P → Set p - From-no (false because _) = ¬ P - From-no (true because _) = Lift p ⊤ +-- If a decision procedure returns "yes", then we can extract the +-- proof using from-yes. +from-yes : (a? : Dec A) → From-yes a? +from-yes (true because [a]) = invert [a] +from-yes (false because _ ) = _ - from-no : (p : Dec P) → From-no p - from-no (false because [¬p]) = invert [¬p] - from-no (true because _ ) = _ +-- If a decision procedure returns "no", then we can extract the proof +-- using from-no. +from-no : (a? : Dec A) → From-no a? +from-no (false because [¬a]) = invert [¬a] +from-no (true because _ ) = _ ------------------------------------------------------------------------- --- Maps +------------------------------------------------------------------------ +-- Maps -map′ : (P → Q) → (Q → P) → Dec P → Dec Q -does (map′ P→Q Q→P p?) = does p? -proof (map′ P→Q Q→P (true because [p])) = ofʸ (P→Q (invert [p])) -proof (map′ P→Q Q→P (false because [¬p])) = ofⁿ (invert [¬p] ∘ Q→P) +map′ : (A → B) → (B → A) → Dec A → Dec B +does (map′ A→B B→A a?) = does a? +proof (map′ A→B B→A (true because [a])) = ofʸ (A→B (invert [a])) +proof (map′ A→B B→A (false because [¬a])) = ofⁿ (invert [¬a] ∘ B→A) ------------------------------------------------------------------------- --- Relationship with double-negation +------------------------------------------------------------------------ +-- Relationship with double-negation --- Decidable predicates are stable. +-- Decidable predicates are stable. -decidable-stable : Dec P → Stable P -decidable-stable (yes p) ¬¬p = p -decidable-stable (no ¬p) ¬¬p = ⊥-elim (¬¬p ¬p) +decidable-stable : Dec A → Stable A +decidable-stable (yes a) ¬¬a = a +decidable-stable (no ¬a) ¬¬a = ⊥-elim (¬¬a ¬a) -¬-drop-Dec : Dec (¬ ¬ P) → Dec (¬ P) -¬-drop-Dec ¬¬p? = map′ negated-stable contradiction (¬? ¬¬p?) +¬-drop-Dec : Dec (¬ ¬ A) → Dec (¬ A) +¬-drop-Dec ¬¬a? = map′ negated-stable contradiction (¬? ¬¬a?) --- A double-negation-translated variant of excluded middle (or: every --- nullary relation is decidable in the double-negation monad). +-- A double-negation-translated variant of excluded middle (or: every +-- nullary relation is decidable in the double-negation monad). -excluded-middle : DoubleNegation (Dec P) -excluded-middle ¬h = ¬h (no (λ p → ¬h (yes p))) +¬¬-excluded-middle : DoubleNegation (Dec A) +¬¬-excluded-middle ¬?a = ¬?a (no (λ a → ¬?a (yes a))) + + +------------------------------------------------------------------------ +-- DEPRECATED NAMES +------------------------------------------------------------------------ +-- Please use the new names as continuing support for the old names is +-- not guaranteed. + +-- Version 2.0 + +excluded-middle = ¬¬-excluded-middle +{-# WARNING_ON_USAGE excluded-middle +"Warning: excluded-middle was deprecated in v2.0. +Please use ¬¬-excluded-middle instead." +#-} \ No newline at end of file diff --git a/Relation.Nullary.Decidable.html b/Relation.Nullary.Decidable.html index e480418f..02c9909e 100644 --- a/Relation.Nullary.Decidable.html +++ b/Relation.Nullary.Decidable.html @@ -10,83 +10,75 @@ module Relation.Nullary.Decidable where open import Level using (Level) -open import Data.Bool.Base using (true; false; if_then_else_) +open import Data.Bool.Base using (true; false; if_then_else_) open import Data.Empty using (⊥-elim) -open import Data.Product as Prod hiding (map) -open import Data.Sum.Base as Sum hiding (map) -open import Function.Base -open import Function.Bundles using - (Injection; module Injection; module Equivalence; _⇔_; _↔_; mk↔′) -open import Relation.Binary using (Setoid; module Setoid; Decidable) -open import Relation.Nullary -open import Relation.Nullary.Negation -open import Relation.Nullary.Reflects using (invert) -open import Relation.Binary.PropositionalEquality.Core using (_≡_; refl; cong′) - -private - variable - p q r : Level - P Q R : Set p - ------------------------------------------------------------------------- --- Re-exporting the core definitions - -open import Relation.Nullary.Decidable.Core public - ------------------------------------------------------------------------- --- Maps - -map : P ⇔ Q → Dec P → Dec Q -map P⇔Q = map′ to from - where open Equivalence P⇔Q - -module _ {a₁ a₂ b₁ b₂} {A : Setoid a₁ a₂} {B : Setoid b₁ b₂} - (inj : Injection A B) - where - - open Injection inj - open Setoid A using () renaming (_≈_ to _≈A_) - open Setoid B using () renaming (_≈_ to _≈B_) - - -- If there is an injection from one setoid to another, and the - -- latter's equivalence relation is decidable, then the former's - -- equivalence relation is also decidable. - - via-injection : Decidable _≈B_ → Decidable _≈A_ - via-injection dec x y = - map′ injective cong (dec (to x) (to y)) - ------------------------------------------------------------------------- --- A lemma relating True and Dec - -True-↔ : (dec : Dec P) → Irrelevant P → True dec ↔ P -True-↔ (true because [p]) irr = mk↔′ (λ _ → invert [p]) _ (irr (invert [p])) cong′ -True-↔ (false because ofⁿ ¬p) _ = mk↔′ (λ ()) (invert (ofⁿ ¬p)) (⊥-elim ∘ ¬p) λ () - ------------------------------------------------------------------------- --- Result of decidability - -isYes≗does : (P? : Dec P) → isYes P? ≡ does P? -isYes≗does (true because _) = refl -isYes≗does (false because _) = refl - -dec-true : (p? : Dec P) → P → does p? ≡ true -dec-true (true because _ ) p = refl -dec-true (false because [¬p]) p = ⊥-elim (invert [¬p] p) - -dec-false : (p? : Dec P) → ¬ P → does p? ≡ false -dec-false (false because _ ) ¬p = refl -dec-false (true because [p]) ¬p = ⊥-elim (¬p (invert [p])) - -dec-yes : (p? : Dec P) → P → ∃ λ p′ → p? ≡ yes p′ -dec-yes p? p with dec-true p? p -dec-yes (yes p′) p | refl = p′ , refl - -dec-no : (p? : Dec P) (¬p : ¬ P) → p? ≡ no ¬p -dec-no p? ¬p with dec-false p? ¬p -dec-no (no _) _ | refl = refl - -dec-yes-irr : (p? : Dec P) → Irrelevant P → (p : P) → p? ≡ yes p -dec-yes-irr p? irr p with dec-yes p? p -... | p′ , eq rewrite irr p p′ = eq +open import Data.Product.Base using (∃; _,_) +open import Function.Base +open import Function.Bundles using + (Injection; module Injection; module Equivalence; _⇔_; _↔_; mk↔ₛ′) +open import Relation.Binary.Bundles using (Setoid; module Setoid) +open import Relation.Binary.Definitions using (Decidable) +open import Relation.Nullary +open import Relation.Nullary.Reflects using (invert) +open import Relation.Binary.PropositionalEquality.Core using (_≡_; refl; cong′) + +private + variable + a b ℓ₁ ℓ₂ : Level + A B : Set a + +------------------------------------------------------------------------ +-- Re-exporting the core definitions + +open import Relation.Nullary.Decidable.Core public + +------------------------------------------------------------------------ +-- Maps + +map : A ⇔ B → Dec A → Dec B +map A⇔B = map′ to from + where open Equivalence A⇔B + +-- If there is an injection from one setoid to another, and the +-- latter's equivalence relation is decidable, then the former's +-- equivalence relation is also decidable. +via-injection : {S : Setoid a ℓ₁} {T : Setoid b ℓ₂} + (inj : Injection S T) (open Injection inj) → + Decidable Eq₂._≈_ → Decidable Eq₁._≈_ +via-injection inj _≟_ x y = map′ injective cong (to x ≟ to y) + where open Injection inj + +------------------------------------------------------------------------ +-- A lemma relating True and Dec + +True-↔ : (a? : Dec A) → Irrelevant A → True a? ↔ A +True-↔ (true because [a]) irr = mk↔ₛ′ (λ _ → invert [a]) _ (irr (invert [a])) cong′ +True-↔ (false because ofⁿ ¬a) _ = mk↔ₛ′ (λ ()) (invert (ofⁿ ¬a)) (⊥-elim ∘ ¬a) λ () + +------------------------------------------------------------------------ +-- Result of decidability + +isYes≗does : (a? : Dec A) → isYes a? ≡ does a? +isYes≗does (true because _) = refl +isYes≗does (false because _) = refl + +dec-true : (a? : Dec A) → A → does a? ≡ true +dec-true (true because _ ) a = refl +dec-true (false because [¬a]) a = ⊥-elim (invert [¬a] a) + +dec-false : (a? : Dec A) → ¬ A → does a? ≡ false +dec-false (false because _ ) ¬a = refl +dec-false (true because [a]) ¬a = ⊥-elim (¬a (invert [a])) + +dec-yes : (a? : Dec A) → A → ∃ λ a → a? ≡ yes a +dec-yes a? a with dec-true a? a +dec-yes (yes a′) a | refl = a′ , refl + +dec-no : (a? : Dec A) (¬a : ¬ A) → a? ≡ no ¬a +dec-no a? ¬a with dec-false a? ¬a +dec-no (no _) _ | refl = refl + +dec-yes-irr : (a? : Dec A) → Irrelevant A → (a : A) → a? ≡ yes a +dec-yes-irr a? irr a with dec-yes a? a +... | a′ , eq rewrite irr a a′ = eq \ No newline at end of file diff --git a/Relation.Nullary.Negation.Core.html b/Relation.Nullary.Negation.Core.html index 7eed7d86..ae9a39c6 100644 --- a/Relation.Nullary.Negation.Core.html +++ b/Relation.Nullary.Negation.Core.html @@ -10,69 +10,68 @@ module Relation.Nullary.Negation.Core where open import Data.Bool.Base using (not) -open import Data.Empty using (⊥) -open import Data.Empty.Irrelevant using (⊥-elim) -open import Data.Product.Base using (_×_; _,_; proj₁; proj₂) -open import Data.Sum.Base using (_⊎_; [_,_]; inj₁; inj₂) -open import Function.Base using (flip; _$_; _∘_; const) -open import Level - -private - variable - a p q w : Level - A : Set a - P : Set p - Q : Set q - Whatever : Set w - ------------------------------------------------------------------------- --- Negation. - -infix 3 ¬_ -¬_ : Set a → Set a -¬ P = P → ⊥ - --- Double-negation -DoubleNegation : Set p → Set p -DoubleNegation P = ¬ ¬ P - --- Stability under double-negation. -Stable : Set p → Set p -Stable P = ¬ ¬ P → P - ------------------------------------------------------------------------- --- Relationship to product and sum - -infixr 1 _¬-⊎_ -_¬-⊎_ : ¬ P → ¬ Q → ¬ (P ⊎ Q) -_¬-⊎_ = [_,_] - ------------------------------------------------------------------------- --- Uses of negation - -contradiction : P → ¬ P → Whatever -contradiction p ¬p = ⊥-elim (¬p p) - -contradiction₂ : P ⊎ Q → ¬ P → ¬ Q → Whatever -contradiction₂ (inj₁ p) ¬p ¬q = contradiction p ¬p -contradiction₂ (inj₂ q) ¬p ¬q = contradiction q ¬q - -contraposition : (P → Q) → ¬ Q → ¬ P -contraposition f ¬q p = contradiction (f p) ¬q - --- Note also the following use of flip: -private - note : (P → ¬ Q) → Q → ¬ P - note = flip - --- Everything is stable in the double-negation monad. -stable : ¬ ¬ Stable P -stable ¬[¬¬p→p] = ¬[¬¬p→p] (λ ¬¬p → ⊥-elim (¬¬p (¬[¬¬p→p] ∘ const))) - --- Negated predicates are stable. -negated-stable : Stable (¬ P) -negated-stable ¬¬¬P P = ¬¬¬P (λ ¬P → ¬P P) - -¬¬-map : (P → Q) → ¬ ¬ P → ¬ ¬ Q -¬¬-map f = contraposition (contraposition f) +open import Data.Empty using (⊥; ⊥-elim) +open import Data.Sum.Base using (_⊎_; [_,_]; inj₁; inj₂) +open import Function.Base using (flip; _$_; _∘_; const) +open import Level + +private + variable + a p q w : Level + A B C : Set a + Whatever : Set w + +------------------------------------------------------------------------ +-- Negation. + +infix 3 ¬_ +¬_ : Set a → Set a +¬ A = A → ⊥ + +------------------------------------------------------------------------ +-- Stability. + +-- Double-negation +DoubleNegation : Set a → Set a +DoubleNegation A = ¬ ¬ A + +-- Stability under double-negation. +Stable : Set a → Set a +Stable A = ¬ ¬ A → A + +------------------------------------------------------------------------ +-- Relationship to sum + +infixr 1 _¬-⊎_ +_¬-⊎_ : ¬ A → ¬ B → ¬ (A ⊎ B) +_¬-⊎_ = [_,_] + +------------------------------------------------------------------------ +-- Uses of negation + +contradiction : A → ¬ A → Whatever +contradiction a ¬a = ⊥-elim (¬a a) + +contradiction₂ : A ⊎ B → ¬ A → ¬ B → Whatever +contradiction₂ (inj₁ a) ¬a ¬b = contradiction a ¬a +contradiction₂ (inj₂ b) ¬a ¬b = contradiction b ¬b + +contraposition : (A → B) → ¬ B → ¬ A +contraposition f ¬b a = contradiction (f a) ¬b + +-- Everything is stable in the double-negation monad. +stable : ¬ ¬ Stable A +stable ¬[¬¬a→a] = ¬[¬¬a→a] (λ ¬¬a → ⊥-elim (¬¬a (¬[¬¬a→a] ∘ const))) + +-- Negated predicates are stable. +negated-stable : Stable (¬ A) +negated-stable ¬¬¬a a = ¬¬¬a (_$ a) + +¬¬-map : (A → B) → ¬ ¬ A → ¬ ¬ B +¬¬-map f = contraposition (contraposition f) + +-- Note also the following use of flip: +private + note : (A → ¬ B) → B → ¬ A + note = flip \ No newline at end of file diff --git a/Relation.Nullary.Negation.html b/Relation.Nullary.Negation.html index f4d16ca0..174822fb 100644 --- a/Relation.Nullary.Negation.html +++ b/Relation.Nullary.Negation.html @@ -9,112 +9,103 @@ module Relation.Nullary.Negation where -open import Effect.Monad -open import Data.Bool.Base using (Bool; false; true; if_then_else_; not) -open import Data.Empty -open import Data.Product as Prod -open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂; [_,_]) -open import Function.Base -open import Level -open import Relation.Nullary.Negation.Core -open import Relation.Nullary.Decidable.Core -open import Relation.Unary - -private - variable - a p q r w : Level - A : Set a - P : Set p - Q : Set q - R : Set r - Whatever : Set w - ------------------------------------------------------------------------- --- Re-export public definitions - -open import Relation.Nullary.Negation.Core public - ------------------------------------------------------------------------- --- Quantifier juggling - -module _ {P : A → Set p} where - - ∃⟶¬∀¬ : ∃ P → ¬ (∀ x → ¬ P x) - ∃⟶¬∀¬ = flip uncurry - - ∀⟶¬∃¬ : (∀ x → P x) → ¬ ∃ λ x → ¬ P x - ∀⟶¬∃¬ ∀xPx (x , ¬Px) = ¬Px (∀xPx x) - - ¬∃⟶∀¬ : ¬ ∃ (λ x → P x) → ∀ x → ¬ P x - ¬∃⟶∀¬ = curry - - ∀¬⟶¬∃ : (∀ x → ¬ P x) → ¬ ∃ (λ x → P x) - ∀¬⟶¬∃ = uncurry - - ∃¬⟶¬∀ : ∃ (λ x → ¬ P x) → ¬ (∀ x → P x) - ∃¬⟶¬∀ = flip ∀⟶¬∃¬ - ------------------------------------------------------------------------- --- Double Negation - --- Double-negation is a monad (if we assume that all elements of ¬ ¬ P --- are equal). - -¬¬-Monad : RawMonad {p} DoubleNegation -¬¬-Monad = mkRawMonad - DoubleNegation - contradiction - (λ x f → negated-stable (¬¬-map f x)) - -¬¬-push : {Q : P → Set q} → - DoubleNegation Π[ Q ] → Π[ DoubleNegation ∘ Q ] -¬¬-push ¬¬P⟶Q P ¬Q = ¬¬P⟶Q (λ P⟶Q → ¬Q (P⟶Q P)) - --- If Whatever is instantiated with ¬ ¬ something, then this function --- is call with current continuation in the double-negation monad, or, --- if you will, a double-negation translation of Peirce's law. --- --- In order to prove ¬ ¬ P one can assume ¬ P and prove ⊥. However, --- sometimes it is nice to avoid leaving the double-negation monad; in --- that case this function can be used (with Whatever instantiated to --- ⊥). - -call/cc : ((P → Whatever) → DoubleNegation P) → DoubleNegation P -call/cc hyp ¬p = hyp (λ p → ⊥-elim (¬p p)) ¬p - --- The "independence of premise" rule, in the double-negation monad. --- It is assumed that the index set (Q) is inhabited. - -independence-of-premise : {R : Q → Set r} → - Q → (P → Σ Q R) → DoubleNegation (Σ[ x ∈ Q ] (P → R x)) -independence-of-premise {P = P} q f = ¬¬-map helper excluded-middle - where - helper : Dec P → _ - helper (yes p) = Prod.map id const (f p) - helper (no ¬p) = (q , ⊥-elim ∘′ ¬p) - --- The independence of premise rule for binary sums. - -independence-of-premise-⊎ : (P → Q ⊎ R) → DoubleNegation ((P → Q) ⊎ (P → R)) -independence-of-premise-⊎ {P = P} f = ¬¬-map helper excluded-middle - where - helper : Dec P → _ - helper (yes p) = Sum.map const const (f p) - helper (no ¬p) = inj₁ (⊥-elim ∘′ ¬p) - -private - - -- Note that independence-of-premise-⊎ is a consequence of - -- independence-of-premise (for simplicity it is assumed that Q and - -- R have the same type here): - - corollary : {Q R : Set q} → - (P → Q ⊎ R) → DoubleNegation ((P → Q) ⊎ (P → R)) - corollary {P = P} {Q} {R} f = - ¬¬-map helper (independence-of-premise - true ([ _,_ true , _,_ false ] ∘′ f)) - where - helper : ∃ (λ b → P → if b then Q else R) → (P → Q) ⊎ (P → R) - helper (true , f) = inj₁ f - helper (false , f) = inj₂ f +open import Effect.Monad using (RawMonad; mkRawMonad) +open import Data.Bool.Base using (Bool; false; true; if_then_else_; not) +open import Data.Empty using (⊥-elim) +open import Data.Product.Base as Prod using (_,_; Σ; Σ-syntax; ∃; curry; uncurry) +open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂; [_,_]) +open import Function.Base using (flip; _∘_; const; _∘′_) +open import Level using (Level) +open import Relation.Nullary.Decidable.Core using (Dec; yes; no; ¬¬-excluded-middle) +open import Relation.Unary using (Universal; Pred) + +private + variable + a b c d p w : Level + A B C D : Set a + P : Pred A p + Whatever : Set w + +------------------------------------------------------------------------ +-- Re-export public definitions + +open import Relation.Nullary.Negation.Core public + +------------------------------------------------------------------------ +-- Quantifier juggling + +∃⟶¬∀¬ : ∃ P → ¬ (∀ x → ¬ P x) +∃⟶¬∀¬ = flip uncurry + +∀⟶¬∃¬ : (∀ x → P x) → ¬ ∃ λ x → ¬ P x +∀⟶¬∃¬ ∀xPx (x , ¬Px) = ¬Px (∀xPx x) + +¬∃⟶∀¬ : ¬ ∃ (λ x → P x) → ∀ x → ¬ P x +¬∃⟶∀¬ = curry + +∀¬⟶¬∃ : (∀ x → ¬ P x) → ¬ ∃ (λ x → P x) +∀¬⟶¬∃ = uncurry + +∃¬⟶¬∀ : ∃ (λ x → ¬ P x) → ¬ (∀ x → P x) +∃¬⟶¬∀ = flip ∀⟶¬∃¬ + +------------------------------------------------------------------------ +-- Double Negation + +-- Double-negation is a monad (if we assume that all elements of ¬ ¬ P +-- are equal). + +¬¬-Monad : RawMonad {a} DoubleNegation +¬¬-Monad = mkRawMonad + DoubleNegation + contradiction + (λ x f → negated-stable (¬¬-map f x)) + +¬¬-push : DoubleNegation Π[ P ] → Π[ DoubleNegation ∘ P ] +¬¬-push ¬¬∀P a ¬Pa = ¬¬∀P (λ ∀P → ¬Pa (∀P a)) + +-- If Whatever is instantiated with ¬ ¬ something, then this function +-- is call with current continuation in the double-negation monad, or, +-- if you will, a double-negation translation of Peirce's law. +-- +-- In order to prove ¬ ¬ P one can assume ¬ P and prove ⊥. However, +-- sometimes it is nice to avoid leaving the double-negation monad; in +-- that case this function can be used (with Whatever instantiated to +-- ⊥). + +call/cc : ((A → Whatever) → DoubleNegation A) → DoubleNegation A +call/cc hyp ¬a = hyp (λ a → ⊥-elim (¬a a)) ¬a + +-- The "independence of premise" rule, in the double-negation monad. +-- It is assumed that the index set (A) is inhabited. + +independence-of-premise : A → (B → Σ A P) → DoubleNegation (Σ[ x ∈ A ] (B → P x)) +independence-of-premise {A = A} {B = B} {P = P} q f = ¬¬-map helper ¬¬-excluded-middle + where + helper : Dec B → Σ[ x ∈ A ] (B → P x) + helper (yes p) = Prod.map₂ const (f p) + helper (no ¬p) = (q , ⊥-elim ∘′ ¬p) + +-- The independence of premise rule for binary sums. + +independence-of-premise-⊎ : (A → B ⊎ C) → DoubleNegation ((A → B) ⊎ (A → C)) +independence-of-premise-⊎ {A = A} {B = B} {C = C} f = ¬¬-map helper ¬¬-excluded-middle + where + helper : Dec A → (A → B) ⊎ (A → C) + helper (yes p) = Sum.map const const (f p) + helper (no ¬p) = inj₁ (⊥-elim ∘′ ¬p) + +private + + -- Note that independence-of-premise-⊎ is a consequence of + -- independence-of-premise (for simplicity it is assumed that Q and + -- R have the same type here): + + corollary : {B C : Set b} → (A → B ⊎ C) → DoubleNegation ((A → B) ⊎ (A → C)) + corollary {A = A} {B = B} {C = C} f = + ¬¬-map helper (independence-of-premise true ([ _,_ true , _,_ false ] ∘′ f)) + where + helper : ∃ (λ b → A → if b then B else C) → (A → B) ⊎ (A → C) + helper (true , f) = inj₁ f + helper (false , f) = inj₂ f \ No newline at end of file diff --git a/Relation.Nullary.Reflects.html b/Relation.Nullary.Reflects.html index aadac8e5..49106857 100644 --- a/Relation.Nullary.Reflects.html +++ b/Relation.Nullary.Reflects.html @@ -12,88 +12,95 @@ open import Agda.Builtin.Equality open import Data.Bool.Base -open import Data.Empty -open import Data.Sum.Base using (_⊎_; inj₁; inj₂) -open import Data.Product.Base using (_×_; _,_; proj₁; proj₂) -open import Level using (Level) -open import Function.Base using (_$_; _∘_; const) - -open import Relation.Nullary.Negation.Core - -private - variable - p q : Level - P Q : Set p - ------------------------------------------------------------------------- --- `Reflects` idiom. - --- The truth value of P is reflected by a boolean value. --- `Reflects P b` is equivalent to `if b then P else ¬ P`. - -data Reflects {p} (P : Set p) : Bool → Set p where - ofʸ : ( p : P) → Reflects P true - ofⁿ : (¬p : ¬ P) → Reflects P false - ------------------------------------------------------------------------- --- Constructors and destructors - --- These lemmas are intended to be used mostly when `b` is a value, so --- that the `if` expressions have already been evaluated away. --- In this case, `of` works like the relevant constructor (`ofⁿ` or --- `ofʸ`), and `invert` strips off the constructor to just give either --- the proof of `P` or the proof of `¬ P`. - -of : ∀ {b} → if b then P else ¬ P → Reflects P b -of {b = false} ¬p = ofⁿ ¬p -of {b = true } p = ofʸ p - -invert : ∀ {b} → Reflects P b → if b then P else ¬ P -invert (ofʸ p) = p -invert (ofⁿ ¬p) = ¬p - ------------------------------------------------------------------------- --- Interaction with negation, product, sums etc. - --- If we can decide P, then we can decide its negation. -¬-reflects : ∀ {b} → Reflects P b → Reflects (¬ P) (not b) -¬-reflects (ofʸ p) = ofⁿ (_$ p) -¬-reflects (ofⁿ ¬p) = ofʸ ¬p - --- If we can decide P and Q then we can decide their product -infixr 2 _×-reflects_ -_×-reflects_ : ∀ {a b} → Reflects P a → Reflects Q b → - Reflects (P × Q) (a ∧ b) -ofʸ p ×-reflects ofʸ q = ofʸ (p , q) -ofʸ p ×-reflects ofⁿ ¬q = ofⁿ (¬q ∘ proj₂) -ofⁿ ¬p ×-reflects _ = ofⁿ (¬p ∘ proj₁) - - -infixr 1 _⊎-reflects_ -_⊎-reflects_ : ∀ {a b} → Reflects P a → Reflects Q b → - Reflects (P ⊎ Q) (a ∨ b) -ofʸ p ⊎-reflects _ = ofʸ (inj₁ p) -ofⁿ ¬p ⊎-reflects ofʸ q = ofʸ (inj₂ q) -ofⁿ ¬p ⊎-reflects ofⁿ ¬q = ofⁿ (¬p ¬-⊎ ¬q) - -infixr 2 _→-reflects_ -_→-reflects_ : ∀ {a b} → Reflects P a → Reflects Q b → - Reflects (P → Q) (not a ∨ b) -ofʸ p →-reflects ofʸ q = ofʸ (const q) -ofʸ p →-reflects ofⁿ ¬q = ofⁿ (¬q ∘ (_$ p)) -ofⁿ ¬p →-reflects _ = ofʸ (⊥-elim ∘ ¬p) - ------------------------------------------------------------------------- --- Other lemmas - -fromEquivalence : ∀ {b} → (T b → P) → (P → T b) → Reflects P b -fromEquivalence {b = true} sound complete = ofʸ (sound _) -fromEquivalence {b = false} sound complete = ofⁿ complete - --- `Reflects` is deterministic. -det : ∀ {b b′} → Reflects P b → Reflects P b′ → b ≡ b′ -det (ofʸ p) (ofʸ p′) = refl -det (ofʸ p) (ofⁿ ¬p′) = ⊥-elim (¬p′ p) -det (ofⁿ ¬p) (ofʸ p′) = ⊥-elim (¬p p′) -det (ofⁿ ¬p) (ofⁿ ¬p′) = refl +open import Data.Unit.Base using (⊤) +open import Data.Empty +open import Data.Sum.Base using (_⊎_; inj₁; inj₂) +open import Data.Product.Base using (_×_; _,_; proj₁; proj₂) +open import Level using (Level) +open import Function.Base using (_$_; _∘_; const; id) + +open import Relation.Nullary.Negation.Core + +private + variable + a : Level + A B : Set a + +------------------------------------------------------------------------ +-- `Reflects` idiom. + +-- The truth value of A is reflected by a boolean value. +-- `Reflects A b` is equivalent to `if b then A else ¬ A`. + +data Reflects (A : Set a) : Bool → Set a where + ofʸ : ( a : A) → Reflects A true + ofⁿ : (¬a : ¬ A) → Reflects A false + +------------------------------------------------------------------------ +-- Constructors and destructors + +-- These lemmas are intended to be used mostly when `b` is a value, so +-- that the `if` expressions have already been evaluated away. +-- In this case, `of` works like the relevant constructor (`ofⁿ` or +-- `ofʸ`), and `invert` strips off the constructor to just give either +-- the proof of `A` or the proof of `¬ A`. + +of : ∀ {b} → if b then A else ¬ A → Reflects A b +of {b = false} ¬a = ofⁿ ¬a +of {b = true } a = ofʸ a + +invert : ∀ {b} → Reflects A b → if b then A else ¬ A +invert (ofʸ a) = a +invert (ofⁿ ¬a) = ¬a + +------------------------------------------------------------------------ +-- Interaction with negation, product, sums etc. + +infixr 1 _⊎-reflects_ +infixr 2 _×-reflects_ _→-reflects_ + +T-reflects : ∀ b → Reflects (T b) b +T-reflects true = of _ +T-reflects false = of id + +-- If we can decide A, then we can decide its negation. +¬-reflects : ∀ {b} → Reflects A b → Reflects (¬ A) (not b) +¬-reflects (ofʸ a) = ofⁿ (_$ a) +¬-reflects (ofⁿ ¬a) = ofʸ ¬a + +-- If we can decide A and Q then we can decide their product +_×-reflects_ : ∀ {a b} → Reflects A a → Reflects B b → + Reflects (A × B) (a ∧ b) +ofʸ a ×-reflects ofʸ b = ofʸ (a , b) +ofʸ a ×-reflects ofⁿ ¬b = ofⁿ (¬b ∘ proj₂) +ofⁿ ¬a ×-reflects _ = ofⁿ (¬a ∘ proj₁) + +_⊎-reflects_ : ∀ {a b} → Reflects A a → Reflects B b → + Reflects (A ⊎ B) (a ∨ b) +ofʸ a ⊎-reflects _ = ofʸ (inj₁ a) +ofⁿ ¬a ⊎-reflects ofʸ b = ofʸ (inj₂ b) +ofⁿ ¬a ⊎-reflects ofⁿ ¬b = ofⁿ (¬a ¬-⊎ ¬b) + +_→-reflects_ : ∀ {a b} → Reflects A a → Reflects B b → + Reflects (A → B) (not a ∨ b) +ofʸ a →-reflects ofʸ b = ofʸ (const b) +ofʸ a →-reflects ofⁿ ¬b = ofⁿ (¬b ∘ (_$ a)) +ofⁿ ¬a →-reflects _ = ofʸ (⊥-elim ∘ ¬a) + +------------------------------------------------------------------------ +-- Other lemmas + +fromEquivalence : ∀ {b} → (T b → A) → (A → T b) → Reflects A b +fromEquivalence {b = true} sound complete = ofʸ (sound _) +fromEquivalence {b = false} sound complete = ofⁿ complete + +-- `Reflects` is deterministic. +det : ∀ {b b′} → Reflects A b → Reflects A b′ → b ≡ b′ +det (ofʸ a) (ofʸ _) = refl +det (ofʸ a) (ofⁿ ¬a) = contradiction a ¬a +det (ofⁿ ¬a) (ofʸ a) = contradiction a ¬a +det (ofⁿ ¬a) (ofⁿ _) = refl + +T-reflects-elim : ∀ {a b} → Reflects (T a) b → b ≡ a +T-reflects-elim {a} r = det r (T-reflects a) \ No newline at end of file diff --git a/Relation.Nullary.html b/Relation.Nullary.html index 621b2595..8b872cd0 100644 --- a/Relation.Nullary.html +++ b/Relation.Nullary.html @@ -16,24 +16,13 @@ ------------------------------------------------------------------------ -- Re-exports -open import Relation.Nullary.Negation.Core public using - ( ¬_; _¬-⊎_ - ; contradiction; contradiction₂; contraposition - ) - -open import Relation.Nullary.Reflects public using - ( Reflects; ofʸ; ofⁿ - ; _×-reflects_; _⊎-reflects_; _→-reflects_ - ) - -open import Relation.Nullary.Decidable.Core public using - ( Dec; does; proof; yes; no; _because_; recompute - ; ¬?; _×-dec_; _⊎-dec_; _→-dec_ - ) - ------------------------------------------------------------------------- --- Irrelevant types - -Irrelevant : ∀ {p} → Set p → Set p -Irrelevant P = ∀ (p₁ p₂ : P) → p₁ ≡ p₂ +open import Relation.Nullary.Negation.Core public +open import Relation.Nullary.Reflects public +open import Relation.Nullary.Decidable.Core public + +------------------------------------------------------------------------ +-- Irrelevant types + +Irrelevant : ∀ {p} → Set p → Set p +Irrelevant P = ∀ (p₁ p₂ : P) → p₁ ≡ p₂ \ No newline at end of file diff --git a/Relation.Unary.Properties.html b/Relation.Unary.Properties.html index a9dfdbc8..38cb069b 100644 --- a/Relation.Unary.Properties.html +++ b/Relation.Unary.Properties.html @@ -9,230 +9,236 @@ module Relation.Unary.Properties where -open import Data.Product as Product using (_×_; _,_; swap; proj₁; zip′) -open import Data.Sum.Base using (inj₁; inj₂) -open import Data.Unit.Base using (tt) -open import Level -open import Relation.Binary.Core as Binary -open import Relation.Binary.Definitions hiding (Decidable; Universal; Irrelevant) -open import Relation.Binary.PropositionalEquality.Core using (refl) -open import Relation.Unary -open import Relation.Nullary.Decidable using (yes; no; _⊎-dec_; _×-dec_; ¬?) -open import Function.Base using (id; _$_; _∘_) +open import Data.Product.Base as Product using (_×_; _,_; swap; proj₁; zip′) +open import Data.Sum.Base using (inj₁; inj₂) +open import Data.Unit.Base using (tt) +open import Level using (Level) +open import Relation.Binary.Core as Binary +open import Relation.Binary.Definitions hiding (Decidable; Universal; Irrelevant) +open import Relation.Binary.PropositionalEquality.Core using (refl) +open import Relation.Unary +open import Relation.Nullary.Decidable using (yes; no; _⊎-dec_; _×-dec_; ¬?) +open import Function.Base using (id; _$_; _∘_) -private - variable - a b ℓ ℓ₁ ℓ₂ ℓ₃ : Level - A : Set a - B : Set b +private + variable + a b ℓ ℓ₁ ℓ₂ ℓ₃ : Level + A : Set a + B : Set b ----------------------------------------------------------------------- --- The empty set +------------------------------------------------------------------------ +-- The empty set -∅? : Decidable {A = A} ∅ -∅? _ = no λ() +∅? : Decidable {A = A} ∅ +∅? _ = no λ() -∅-Empty : Empty {A = A} ∅ -∅-Empty x () +∅-Empty : Empty {A = A} ∅ +∅-Empty x () -∁∅-Universal : Universal {A = A} (∁ ∅) -∁∅-Universal = λ x x∈∅ → x∈∅ +∁∅-Universal : Universal {A = A} (∁ ∅) +∁∅-Universal = λ x x∈∅ → x∈∅ ----------------------------------------------------------------------- --- The universe +------------------------------------------------------------------------ +-- The universe -U? : Decidable {A = A} U -U? _ = yes tt +U? : Decidable {A = A} U +U? _ = yes tt -U-Universal : Universal {A = A} U -U-Universal = λ _ → _ +U-Universal : Universal {A = A} U +U-Universal = λ _ → _ -∁U-Empty : Empty {A = A} (∁ U) -∁U-Empty = λ x x∈∁U → x∈∁U _ +∁U-Empty : Empty {A = A} (∁ U) +∁U-Empty = λ x x∈∁U → x∈∁U _ ----------------------------------------------------------------------- --- Subset properties +------------------------------------------------------------------------ +-- Subset properties -∅-⊆ : (P : Pred A ℓ) → ∅ ⊆ P -∅-⊆ P () +∅-⊆ : (P : Pred A ℓ) → ∅ ⊆ P +∅-⊆ P () -⊆-U : (P : Pred A ℓ) → P ⊆ U -⊆-U P _ = _ +⊆-U : (P : Pred A ℓ) → P ⊆ U +⊆-U P _ = _ -⊆-refl : Reflexive {A = Pred A ℓ} _⊆_ -⊆-refl x∈P = x∈P +⊆-refl : Reflexive {A = Pred A ℓ} _⊆_ +⊆-refl x∈P = x∈P -⊆-reflexive : Binary._⇒_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _≐_ _⊆_ -⊆-reflexive (P⊆Q , Q⊆P) = P⊆Q +⊆-reflexive : Binary._⇒_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _≐_ _⊆_ +⊆-reflexive (P⊆Q , Q⊆P) = P⊆Q -⊆-trans : Trans {A = Pred A ℓ₁} {B = Pred A ℓ₂} {C = Pred A ℓ₃} _⊆_ _⊆_ _⊆_ -⊆-trans P⊆Q Q⊆R x∈P = Q⊆R (P⊆Q x∈P) +⊆-trans : Trans {A = Pred A ℓ₁} {B = Pred A ℓ₂} {C = Pred A ℓ₃} _⊆_ _⊆_ _⊆_ +⊆-trans P⊆Q Q⊆R x∈P = Q⊆R (P⊆Q x∈P) -⊆-antisym : Antisymmetric {A = Pred A ℓ} _≐_ _⊆_ -⊆-antisym = _,_ +⊆-antisym : Antisymmetric {A = Pred A ℓ} _≐_ _⊆_ +⊆-antisym = _,_ -⊆-min : Min {B = Pred A ℓ} _⊆_ ∅ -⊆-min = ∅-⊆ +⊆-min : Min {B = Pred A ℓ} _⊆_ ∅ +⊆-min = ∅-⊆ -⊆-max : Max {A = Pred A ℓ} _⊆_ U -⊆-max = ⊆-U +⊆-max : Max {A = Pred A ℓ} _⊆_ U +⊆-max = ⊆-U -⊂⇒⊆ : Binary._⇒_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _⊂_ _⊆_ -⊂⇒⊆ = proj₁ +⊂⇒⊆ : Binary._⇒_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _⊂_ _⊆_ +⊂⇒⊆ = proj₁ -⊂-trans : Trans {A = Pred A ℓ₁} {B = Pred A ℓ₂} {C = Pred A ℓ₃} _⊂_ _⊂_ _⊂_ -⊂-trans (P⊆Q , Q⊈P) (Q⊆R , R⊈Q) = (λ x∈P → Q⊆R (P⊆Q x∈P)) , (λ R⊆P → R⊈Q (λ x∈R → P⊆Q (R⊆P x∈R))) +⊂-trans : Trans {A = Pred A ℓ₁} {B = Pred A ℓ₂} {C = Pred A ℓ₃} _⊂_ _⊂_ _⊂_ +⊂-trans (P⊆Q , Q⊈P) (Q⊆R , R⊈Q) = (λ x∈P → Q⊆R (P⊆Q x∈P)) , (λ R⊆P → R⊈Q (λ x∈R → P⊆Q (R⊆P x∈R))) -⊂-⊆-trans : Trans {A = Pred A ℓ₁} {B = Pred A ℓ₂} {C = Pred A ℓ₃} _⊂_ _⊆_ _⊂_ -⊂-⊆-trans (P⊆Q , Q⊈P) Q⊆R = (λ x∈P → Q⊆R (P⊆Q x∈P)) , (λ R⊆P → Q⊈P (λ x∈Q → R⊆P (Q⊆R x∈Q))) +⊂-⊆-trans : Trans {A = Pred A ℓ₁} {B = Pred A ℓ₂} {C = Pred A ℓ₃} _⊂_ _⊆_ _⊂_ +⊂-⊆-trans (P⊆Q , Q⊈P) Q⊆R = (λ x∈P → Q⊆R (P⊆Q x∈P)) , (λ R⊆P → Q⊈P (λ x∈Q → R⊆P (Q⊆R x∈Q))) -⊆-⊂-trans : Trans {A = Pred A ℓ₁} {B = Pred A ℓ₂} {C = Pred A ℓ₃} _⊆_ _⊂_ _⊂_ -⊆-⊂-trans P⊆Q (Q⊆R , R⊈Q) = (λ x∈P → Q⊆R (P⊆Q x∈P)) , (λ R⊆P → R⊈Q (λ R⊆Q → P⊆Q (R⊆P R⊆Q))) +⊆-⊂-trans : Trans {A = Pred A ℓ₁} {B = Pred A ℓ₂} {C = Pred A ℓ₃} _⊆_ _⊂_ _⊂_ +⊆-⊂-trans P⊆Q (Q⊆R , R⊈Q) = (λ x∈P → Q⊆R (P⊆Q x∈P)) , (λ R⊆P → R⊈Q (λ R⊆Q → P⊆Q (R⊆P R⊆Q))) -⊂-respʳ-≐ : _Respectsʳ_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _⊂_ _≐_ -⊂-respʳ-≐ (Q⊆R , _) P⊂Q = ⊂-⊆-trans P⊂Q Q⊆R +⊂-respʳ-≐ : _Respectsʳ_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _⊂_ _≐_ +⊂-respʳ-≐ (Q⊆R , _) P⊂Q = ⊂-⊆-trans P⊂Q Q⊆R -⊂-respˡ-≐ : _Respectsˡ_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _⊂_ _≐_ -⊂-respˡ-≐ (_ , R⊆Q) P⊂Q = ⊆-⊂-trans R⊆Q P⊂Q +⊂-respˡ-≐ : _Respectsˡ_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _⊂_ _≐_ +⊂-respˡ-≐ (_ , R⊆Q) P⊂Q = ⊆-⊂-trans R⊆Q P⊂Q -⊂-resp-≐ : _Respects₂_ {A = Pred A ℓ} _⊂_ _≐_ -⊂-resp-≐ = ⊂-respʳ-≐ , ⊂-respˡ-≐ +⊂-resp-≐ : _Respects₂_ {A = Pred A ℓ} _⊂_ _≐_ +⊂-resp-≐ = ⊂-respʳ-≐ , ⊂-respˡ-≐ -⊂-irrefl : Irreflexive {A = Pred A ℓ₁} {B = Pred A ℓ₂} _≐_ _⊂_ -⊂-irrefl (_ , Q⊆P) (_ , Q⊈P) = Q⊈P Q⊆P +⊂-irrefl : Irreflexive {A = Pred A ℓ₁} {B = Pred A ℓ₂} _≐_ _⊂_ +⊂-irrefl (_ , Q⊆P) (_ , Q⊈P) = Q⊈P Q⊆P -⊂-antisym : Antisymmetric {A = Pred A ℓ} _≐_ _⊂_ -⊂-antisym (P⊆Q , _) (Q⊆P , _) = ⊆-antisym P⊆Q Q⊆P +⊂-antisym : Antisymmetric {A = Pred A ℓ} _≐_ _⊂_ +⊂-antisym (P⊆Q , _) (Q⊆P , _) = ⊆-antisym P⊆Q Q⊆P -⊂-asym : Asymmetric {A = Pred A ℓ} _⊂_ -⊂-asym (_ , Q⊈P) = Q⊈P ∘ proj₁ +⊂-asym : Asymmetric {A = Pred A ℓ} _⊂_ +⊂-asym (_ , Q⊈P) = Q⊈P ∘ proj₁ -∅-⊆′ : (P : Pred A ℓ) → ∅ ⊆′ P -∅-⊆′ _ _ = λ () +∅-⊆′ : (P : Pred A ℓ) → ∅ ⊆′ P +∅-⊆′ _ _ = λ () -⊆′-U : (P : Pred A ℓ) → P ⊆′ U -⊆′-U _ _ _ = _ +⊆′-U : (P : Pred A ℓ) → P ⊆′ U +⊆′-U _ _ _ = _ -⊆′-refl : Reflexive {A = Pred A ℓ} _⊆′_ -⊆′-refl x x∈P = x∈P +⊆′-refl : Reflexive {A = Pred A ℓ} _⊆′_ +⊆′-refl x x∈P = x∈P -⊆′-reflexive : Binary._⇒_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _≐′_ _⊆′_ -⊆′-reflexive (P⊆Q , Q⊆P) = P⊆Q +⊆′-reflexive : Binary._⇒_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _≐′_ _⊆′_ +⊆′-reflexive (P⊆Q , Q⊆P) = P⊆Q -⊆′-trans : Trans {A = Pred A ℓ₁} {B = Pred A ℓ₂} {C = Pred A ℓ₃} _⊆′_ _⊆′_ _⊆′_ -⊆′-trans P⊆Q Q⊆R x x∈P = Q⊆R x (P⊆Q x x∈P) +⊆′-trans : Trans {A = Pred A ℓ₁} {B = Pred A ℓ₂} {C = Pred A ℓ₃} _⊆′_ _⊆′_ _⊆′_ +⊆′-trans P⊆Q Q⊆R x x∈P = Q⊆R x (P⊆Q x x∈P) -⊆′-antisym : Antisymmetric {A = Pred A ℓ} _≐′_ _⊆′_ -⊆′-antisym = _,_ +⊆′-antisym : Antisymmetric {A = Pred A ℓ} _≐′_ _⊆′_ +⊆′-antisym = _,_ -⊆′-min : Min {B = Pred A ℓ} _⊆′_ ∅ -⊆′-min = ∅-⊆′ +⊆′-min : Min {B = Pred A ℓ} _⊆′_ ∅ +⊆′-min = ∅-⊆′ -⊆′-max : Max {A = Pred A ℓ} _⊆′_ U -⊆′-max = ⊆′-U +⊆′-max : Max {A = Pred A ℓ} _⊆′_ U +⊆′-max = ⊆′-U -⊂′⇒⊆′ : Binary._⇒_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _⊂′_ _⊆′_ -⊂′⇒⊆′ = proj₁ +⊂′⇒⊆′ : Binary._⇒_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _⊂′_ _⊆′_ +⊂′⇒⊆′ = proj₁ -⊂′-trans : Trans {A = Pred A ℓ₁} {B = Pred A ℓ₂} {C = Pred A ℓ₃} _⊂′_ _⊂′_ _⊂′_ -⊂′-trans (P⊆Q , Q⊈P) (Q⊆R , R⊈Q) = ⊆′-trans P⊆Q Q⊆R , λ R⊆P → R⊈Q (⊆′-trans R⊆P P⊆Q) +⊂′-trans : Trans {A = Pred A ℓ₁} {B = Pred A ℓ₂} {C = Pred A ℓ₃} _⊂′_ _⊂′_ _⊂′_ +⊂′-trans (P⊆Q , Q⊈P) (Q⊆R , R⊈Q) = ⊆′-trans P⊆Q Q⊆R , λ R⊆P → R⊈Q (⊆′-trans R⊆P P⊆Q) -⊂′-⊆′-trans : Trans {A = Pred A ℓ₁} {B = Pred A ℓ₂} {C = Pred A ℓ₃} _⊂′_ _⊆′_ _⊂′_ -⊂′-⊆′-trans (P⊆Q , Q⊈P) Q⊆R = ⊆′-trans P⊆Q Q⊆R , λ R⊆P → Q⊈P (⊆′-trans Q⊆R R⊆P) +⊂′-⊆′-trans : Trans {A = Pred A ℓ₁} {B = Pred A ℓ₂} {C = Pred A ℓ₃} _⊂′_ _⊆′_ _⊂′_ +⊂′-⊆′-trans (P⊆Q , Q⊈P) Q⊆R = ⊆′-trans P⊆Q Q⊆R , λ R⊆P → Q⊈P (⊆′-trans Q⊆R R⊆P) -⊆′-⊂′-trans : Trans {A = Pred A ℓ₁} {B = Pred A ℓ₂} {C = Pred A ℓ₃} _⊆′_ _⊂′_ _⊂′_ -⊆′-⊂′-trans P⊆Q (Q⊆R , R⊈Q) = ⊆′-trans P⊆Q Q⊆R , λ R⊆P → R⊈Q (⊆′-trans R⊆P P⊆Q) +⊆′-⊂′-trans : Trans {A = Pred A ℓ₁} {B = Pred A ℓ₂} {C = Pred A ℓ₃} _⊆′_ _⊂′_ _⊂′_ +⊆′-⊂′-trans P⊆Q (Q⊆R , R⊈Q) = ⊆′-trans P⊆Q Q⊆R , λ R⊆P → R⊈Q (⊆′-trans R⊆P P⊆Q) -⊂′-respʳ-≐′ : _Respectsʳ_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _⊂′_ _≐′_ -⊂′-respʳ-≐′ (Q⊆R , _) P⊂Q = ⊂′-⊆′-trans P⊂Q Q⊆R +⊂′-respʳ-≐′ : _Respectsʳ_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _⊂′_ _≐′_ +⊂′-respʳ-≐′ (Q⊆R , _) P⊂Q = ⊂′-⊆′-trans P⊂Q Q⊆R -⊂′-respˡ-≐′ : _Respectsˡ_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _⊂′_ _≐′_ -⊂′-respˡ-≐′ (_ , R⊆Q) P⊂Q = ⊆′-⊂′-trans R⊆Q P⊂Q +⊂′-respˡ-≐′ : _Respectsˡ_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _⊂′_ _≐′_ +⊂′-respˡ-≐′ (_ , R⊆Q) P⊂Q = ⊆′-⊂′-trans R⊆Q P⊂Q -⊂′-resp-≐′ : _Respects₂_ {A = Pred A ℓ₁} _⊂′_ _≐′_ -⊂′-resp-≐′ = ⊂′-respʳ-≐′ , ⊂′-respˡ-≐′ +⊂′-resp-≐′ : _Respects₂_ {A = Pred A ℓ₁} _⊂′_ _≐′_ +⊂′-resp-≐′ = ⊂′-respʳ-≐′ , ⊂′-respˡ-≐′ -⊂′-irrefl : Irreflexive {A = Pred A ℓ₁} {B = Pred A ℓ₂} _≐′_ _⊂′_ -⊂′-irrefl (_ , Q⊆P) (_ , Q⊈P) = Q⊈P Q⊆P +⊂′-irrefl : Irreflexive {A = Pred A ℓ₁} {B = Pred A ℓ₂} _≐′_ _⊂′_ +⊂′-irrefl (_ , Q⊆P) (_ , Q⊈P) = Q⊈P Q⊆P -⊂′-antisym : Antisymmetric {A = Pred A ℓ} _≐′_ _⊂′_ -⊂′-antisym (P⊆Q , _) (Q⊆P , _) = ⊆′-antisym P⊆Q Q⊆P +⊂′-antisym : Antisymmetric {A = Pred A ℓ} _≐′_ _⊂′_ +⊂′-antisym (P⊆Q , _) (Q⊆P , _) = ⊆′-antisym P⊆Q Q⊆P -⊆⇒⊆′ : Binary._⇒_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _⊆_ _⊆′_ -⊆⇒⊆′ P⊆Q _ x∈P = P⊆Q x∈P +⊆⇒⊆′ : Binary._⇒_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _⊆_ _⊆′_ +⊆⇒⊆′ P⊆Q _ x∈P = P⊆Q x∈P -⊆′⇒⊆ : Binary._⇒_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _⊆′_ _⊆_ -⊆′⇒⊆ P⊆Q x∈P = P⊆Q _ x∈P +⊆′⇒⊆ : Binary._⇒_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _⊆′_ _⊆_ +⊆′⇒⊆ P⊆Q x∈P = P⊆Q _ x∈P -⊂⇒⊂′ : Binary._⇒_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _⊂_ _⊂′_ -⊂⇒⊂′ = Product.map ⊆⇒⊆′ (_∘ ⊆′⇒⊆) +⊂⇒⊂′ : Binary._⇒_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _⊂_ _⊂′_ +⊂⇒⊂′ = Product.map ⊆⇒⊆′ (_∘ ⊆′⇒⊆) -⊂′⇒⊂ : Binary._⇒_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _⊂′_ _⊂_ -⊂′⇒⊂ = Product.map ⊆′⇒⊆ (_∘ ⊆⇒⊆′) +⊂′⇒⊂ : Binary._⇒_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _⊂′_ _⊂_ +⊂′⇒⊂ = Product.map ⊆′⇒⊆ (_∘ ⊆⇒⊆′) ----------------------------------------------------------------------- --- Equality properties +------------------------------------------------------------------------ +-- Equality properties -≐-refl : Reflexive {A = Pred A ℓ} _≐_ -≐-refl = id , id +≐-refl : Reflexive {A = Pred A ℓ} _≐_ +≐-refl = id , id -≐-sym : Sym {A = Pred A ℓ₁} {B = Pred A ℓ₂} _≐_ _≐_ -≐-sym = swap +≐-sym : Sym {A = Pred A ℓ₁} {B = Pred A ℓ₂} _≐_ _≐_ +≐-sym = swap -≐-trans : Trans {A = Pred A ℓ₁} {B = Pred A ℓ₂} {C = Pred A ℓ₃} _≐_ _≐_ _≐_ -≐-trans = zip′ (λ P⊆Q Q⊆R x∈P → Q⊆R (P⊆Q x∈P)) (λ Q⊆P R⊆Q x∈R → Q⊆P (R⊆Q x∈R)) +≐-trans : Trans {A = Pred A ℓ₁} {B = Pred A ℓ₂} {C = Pred A ℓ₃} _≐_ _≐_ _≐_ +≐-trans = zip′ (λ P⊆Q Q⊆R x∈P → Q⊆R (P⊆Q x∈P)) (λ Q⊆P R⊆Q x∈R → Q⊆P (R⊆Q x∈R)) -≐′-refl : Reflexive {A = Pred A ℓ} _≐′_ -≐′-refl = (λ _ → id) , (λ _ → id) +≐′-refl : Reflexive {A = Pred A ℓ} _≐′_ +≐′-refl = (λ _ → id) , (λ _ → id) -≐′-sym : Sym {A = Pred A ℓ₁} {B = Pred A ℓ₂} _≐′_ _≐′_ -≐′-sym = swap +≐′-sym : Sym {A = Pred A ℓ₁} {B = Pred A ℓ₂} _≐′_ _≐′_ +≐′-sym = swap -≐′-trans : Trans {A = Pred A ℓ₁} {B = Pred A ℓ₂} {C = Pred A ℓ₃} _≐′_ _≐′_ _≐′_ -≐′-trans = zip′ (λ P⊆Q Q⊆R x x∈P → Q⊆R x (P⊆Q x x∈P)) λ Q⊆P R⊆Q x x∈R → Q⊆P x (R⊆Q x x∈R) +≐′-trans : Trans {A = Pred A ℓ₁} {B = Pred A ℓ₂} {C = Pred A ℓ₃} _≐′_ _≐′_ _≐′_ +≐′-trans = zip′ (λ P⊆Q Q⊆R x x∈P → Q⊆R x (P⊆Q x x∈P)) λ Q⊆P R⊆Q x x∈R → Q⊆P x (R⊆Q x x∈R) -≐⇒≐′ : Binary._⇒_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _≐_ _≐′_ -≐⇒≐′ = Product.map ⊆⇒⊆′ ⊆⇒⊆′ +≐⇒≐′ : Binary._⇒_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _≐_ _≐′_ +≐⇒≐′ = Product.map ⊆⇒⊆′ ⊆⇒⊆′ -≐′⇒≐ : Binary._⇒_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _≐′_ _≐_ -≐′⇒≐ = Product.map ⊆′⇒⊆ ⊆′⇒⊆ +≐′⇒≐ : Binary._⇒_ {A = Pred A ℓ₁} {B = Pred A ℓ₂} _≐′_ _≐_ +≐′⇒≐ = Product.map ⊆′⇒⊆ ⊆′⇒⊆ ----------------------------------------------------------------------- --- Decidability properties +------------------------------------------------------------------------ +-- Decidability properties -∁? : {P : Pred A ℓ} → Decidable P → Decidable (∁ P) -∁? P? x = ¬? (P? x) +∁? : {P : Pred A ℓ} → Decidable P → Decidable (∁ P) +∁? P? x = ¬? (P? x) -_∪?_ : {P : Pred A ℓ₁} {Q : Pred A ℓ₂} → - Decidable P → Decidable Q → Decidable (P ∪ Q) -_∪?_ P? Q? x = (P? x) ⊎-dec (Q? x) +infix 2 _×?_ _⊙?_ +infix 10 _~? +infixr 1 _⊎?_ +infixr 7 _∩?_ +infixr 6 _∪?_ -_∩?_ : {P : Pred A ℓ₁} {Q : Pred A ℓ₂} → - Decidable P → Decidable Q → Decidable (P ∩ Q) -_∩?_ P? Q? x = (P? x) ×-dec (Q? x) +_∪?_ : {P : Pred A ℓ₁} {Q : Pred A ℓ₂} → + Decidable P → Decidable Q → Decidable (P ∪ Q) +_∪?_ P? Q? x = (P? x) ⊎-dec (Q? x) -_×?_ : {P : Pred A ℓ₁} {Q : Pred B ℓ₂} → - Decidable P → Decidable Q → Decidable (P ⟨×⟩ Q) -_×?_ P? Q? (a , b) = (P? a) ×-dec (Q? b) +_∩?_ : {P : Pred A ℓ₁} {Q : Pred A ℓ₂} → + Decidable P → Decidable Q → Decidable (P ∩ Q) +_∩?_ P? Q? x = (P? x) ×-dec (Q? x) -_⊙?_ : {P : Pred A ℓ₁} {Q : Pred B ℓ₂} → - Decidable P → Decidable Q → Decidable (P ⟨⊙⟩ Q) -_⊙?_ P? Q? (a , b) = (P? a) ⊎-dec (Q? b) +_×?_ : {P : Pred A ℓ₁} {Q : Pred B ℓ₂} → + Decidable P → Decidable Q → Decidable (P ⟨×⟩ Q) +_×?_ P? Q? (a , b) = (P? a) ×-dec (Q? b) -_⊎?_ : {P : Pred A ℓ} {Q : Pred B ℓ} → - Decidable P → Decidable Q → Decidable (P ⟨⊎⟩ Q) -_⊎?_ P? Q? (inj₁ a) = P? a -_⊎?_ P? Q? (inj₂ b) = Q? b +_⊙?_ : {P : Pred A ℓ₁} {Q : Pred B ℓ₂} → + Decidable P → Decidable Q → Decidable (P ⟨⊙⟩ Q) +_⊙?_ P? Q? (a , b) = (P? a) ⊎-dec (Q? b) -_~? : {P : Pred (A × B) ℓ} → Decidable P → Decidable (P ~) -_~? P? = P? ∘ swap +_⊎?_ : {P : Pred A ℓ} {Q : Pred B ℓ} → + Decidable P → Decidable Q → Decidable (P ⟨⊎⟩ Q) +_⊎?_ P? Q? (inj₁ a) = P? a +_⊎?_ P? Q? (inj₂ b) = Q? b ----------------------------------------------------------------------- --- Irrelevant properties +_~? : {P : Pred (A × B) ℓ} → Decidable P → Decidable (P ~) +_~? P? = P? ∘ swap -U-irrelevant : Irrelevant {A = A} U -U-irrelevant a b = refl +------------------------------------------------------------------------ +-- Irrelevant properties -∁-irrelevant : (P : Pred A ℓ) → Irrelevant (∁ P) -∁-irrelevant P a b = refl +U-irrelevant : Irrelevant {A = A} U +U-irrelevant a b = refl + +∁-irrelevant : (P : Pred A ℓ) → Irrelevant (∁ P) +∁-irrelevant P a b = refl \ No newline at end of file diff --git a/Relation.Unary.html b/Relation.Unary.html index 65b920a6..c2be754c 100644 --- a/Relation.Unary.html +++ b/Relation.Unary.html @@ -9,303 +9,303 @@ module Relation.Unary where -open import Data.Empty -open import Data.Unit.Base using (⊤) -open import Data.Product -open import Data.Sum.Base using (_⊎_; [_,_]) -open import Function.Base -open import Level -open import Relation.Nullary.Decidable.Core using (Dec; True) -open import Relation.Nullary.Negation.Core using (¬_) -open import Relation.Binary.PropositionalEquality.Core using (_≡_) +open import Data.Empty using (⊥) +open import Data.Unit.Base using (⊤) +open import Data.Product.Base using (_×_; _,_; Σ-syntax; ∃; uncurry; swap) +open import Data.Sum.Base using (_⊎_; [_,_]) +open import Function.Base using (_∘_; _|>_) +open import Level using (Level; _⊔_; 0ℓ; suc; Lift) +open import Relation.Nullary.Decidable.Core using (Dec; True) +open import Relation.Nullary.Negation.Core using (¬_) +open import Relation.Binary.PropositionalEquality.Core using (_≡_) -private - variable - a b c ℓ ℓ₁ ℓ₂ : Level - A : Set a - B : Set b - C : Set c +private + variable + a b c ℓ ℓ₁ ℓ₂ : Level + A : Set a + B : Set b + C : Set c ------------------------------------------------------------------------- --- Definition +------------------------------------------------------------------------ +-- Definition --- Unary relations are known as predicates and `Pred A ℓ` can be viewed --- as some property that elements of type A might satisfy. +-- Unary relations are known as predicates and `Pred A ℓ` can be viewed +-- as some property that elements of type A might satisfy. --- Consequently `P : Pred A ℓ` can also be seen as a subset of A --- containing all the elements of A that satisfy property P. This view --- informs much of the notation used below. +-- Consequently `P : Pred A ℓ` can also be seen as a subset of A +-- containing all the elements of A that satisfy property P. This view +-- informs much of the notation used below. -Pred : ∀ {a} → Set a → (ℓ : Level) → Set (a ⊔ suc ℓ) -Pred A ℓ = A → Set ℓ +Pred : ∀ {a} → Set a → (ℓ : Level) → Set (a ⊔ suc ℓ) +Pred A ℓ = A → Set ℓ ------------------------------------------------------------------------- --- Special sets +------------------------------------------------------------------------ +-- Special sets --- The empty set. +-- The empty set. -∅ : Pred A 0ℓ -∅ = λ _ → ⊥ +∅ : Pred A 0ℓ +∅ = λ _ → ⊥ --- The singleton set. +-- The singleton set. -｛_｝ : A → Pred A _ -｛ x ｝ = x ≡_ +｛_｝ : A → Pred A _ +｛ x ｝ = x ≡_ --- The universal set. +-- The universal set. -U : Pred A 0ℓ -U = λ _ → ⊤ +U : Pred A 0ℓ +U = λ _ → ⊤ ------------------------------------------------------------------------- --- Membership +------------------------------------------------------------------------ +-- Membership -infix 4 _∈_ _∉_ +infix 4 _∈_ _∉_ -_∈_ : A → Pred A ℓ → Set _ -x ∈ P = P x +_∈_ : A → Pred A ℓ → Set _ +x ∈ P = P x -_∉_ : A → Pred A ℓ → Set _ -x ∉ P = ¬ x ∈ P +_∉_ : A → Pred A ℓ → Set _ +x ∉ P = ¬ x ∈ P ------------------------------------------------------------------------- --- Subset relations +------------------------------------------------------------------------ +-- Subset relations -infix 4 _⊆_ _⊇_ _⊈_ _⊉_ _⊂_ _⊃_ _⊄_ _⊅_ _≐_ _≐′_ +infix 4 _⊆_ _⊇_ _⊈_ _⊉_ _⊂_ _⊃_ _⊄_ _⊅_ _≐_ _≐′_ -_⊆_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ -P ⊆ Q = ∀ {x} → x ∈ P → x ∈ Q +_⊆_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ +P ⊆ Q = ∀ {x} → x ∈ P → x ∈ Q -_⊇_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ -P ⊇ Q = Q ⊆ P +_⊇_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ +P ⊇ Q = Q ⊆ P -_⊈_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ -P ⊈ Q = ¬ (P ⊆ Q) +_⊈_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ +P ⊈ Q = ¬ (P ⊆ Q) -_⊉_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ -P ⊉ Q = ¬ (P ⊇ Q) +_⊉_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ +P ⊉ Q = ¬ (P ⊇ Q) -_⊂_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ -P ⊂ Q = P ⊆ Q × Q ⊈ P +_⊂_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ +P ⊂ Q = P ⊆ Q × Q ⊈ P -_⊃_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ -P ⊃ Q = Q ⊂ P +_⊃_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ +P ⊃ Q = Q ⊂ P -_⊄_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ -P ⊄ Q = ¬ (P ⊂ Q) +_⊄_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ +P ⊄ Q = ¬ (P ⊂ Q) -_⊅_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ -P ⊅ Q = ¬ (P ⊃ Q) +_⊅_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ +P ⊅ Q = ¬ (P ⊃ Q) -_≐_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ -P ≐ Q = (P ⊆ Q) × (Q ⊆ P) +_≐_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ +P ≐ Q = (P ⊆ Q) × (Q ⊆ P) --- The following primed variants of _⊆_ can be used when 'x' can't --- be inferred from 'x ∈ P'. +-- The following primed variants of _⊆_ can be used when 'x' can't +-- be inferred from 'x ∈ P'. -infix 4 _⊆′_ _⊇′_ _⊈′_ _⊉′_ _⊂′_ _⊃′_ _⊄′_ _⊅′_ +infix 4 _⊆′_ _⊇′_ _⊈′_ _⊉′_ _⊂′_ _⊃′_ _⊄′_ _⊅′_ -_⊆′_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ -P ⊆′ Q = ∀ x → x ∈ P → x ∈ Q +_⊆′_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ +P ⊆′ Q = ∀ x → x ∈ P → x ∈ Q -_⊇′_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ -Q ⊇′ P = P ⊆′ Q +_⊇′_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ +Q ⊇′ P = P ⊆′ Q -_⊈′_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ -P ⊈′ Q = ¬ (P ⊆′ Q) +_⊈′_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ +P ⊈′ Q = ¬ (P ⊆′ Q) -_⊉′_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ -P ⊉′ Q = ¬ (P ⊇′ Q) +_⊉′_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ +P ⊉′ Q = ¬ (P ⊇′ Q) -_⊂′_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ -P ⊂′ Q = P ⊆′ Q × Q ⊈′ P +_⊂′_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ +P ⊂′ Q = P ⊆′ Q × Q ⊈′ P -_⊃′_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ -P ⊃′ Q = Q ⊂′ P +_⊃′_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ +P ⊃′ Q = Q ⊂′ P -_⊄′_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ -P ⊄′ Q = ¬ (P ⊂′ Q) +_⊄′_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ +P ⊄′ Q = ¬ (P ⊂′ Q) -_⊅′_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ -P ⊅′ Q = ¬ (P ⊃′ Q) +_⊅′_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ +P ⊅′ Q = ¬ (P ⊃′ Q) -_≐′_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ -P ≐′ Q = (P ⊆′ Q) × (Q ⊆′ P) +_≐′_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ +P ≐′ Q = (P ⊆′ Q) × (Q ⊆′ P) ------------------------------------------------------------------------- --- Properties of sets +------------------------------------------------------------------------ +-- Properties of sets -infix 10 Satisfiable Universal IUniversal +infix 10 Satisfiable Universal IUniversal --- Emptiness - no element satisfies P. +-- Emptiness - no element satisfies P. -Empty : Pred A ℓ → Set _ -Empty P = ∀ x → x ∉ P +Empty : Pred A ℓ → Set _ +Empty P = ∀ x → x ∉ P --- Satisfiable - at least one element satisfies P. +-- Satisfiable - at least one element satisfies P. -Satisfiable : Pred A ℓ → Set _ -Satisfiable P = ∃ λ x → x ∈ P +Satisfiable : Pred A ℓ → Set _ +Satisfiable P = ∃ λ x → x ∈ P -syntax Satisfiable P = ∃⟨ P ⟩ +syntax Satisfiable P = ∃⟨ P ⟩ --- Universality - all elements satisfy P. +-- Universality - all elements satisfy P. -Universal : Pred A ℓ → Set _ -Universal P = ∀ x → x ∈ P +Universal : Pred A ℓ → Set _ +Universal P = ∀ x → x ∈ P -syntax Universal P = Π[ P ] +syntax Universal P = Π[ P ] --- Implicit universality - all elements satisfy P. +-- Implicit universality - all elements satisfy P. -IUniversal : Pred A ℓ → Set _ -IUniversal P = ∀ {x} → x ∈ P +IUniversal : Pred A ℓ → Set _ +IUniversal P = ∀ {x} → x ∈ P -syntax IUniversal P = ∀[ P ] +syntax IUniversal P = ∀[ P ] --- Decidability - it is possible to determine if an arbitrary element --- satisfies P. +-- Decidability - it is possible to determine if an arbitrary element +-- satisfies P. -Decidable : Pred A ℓ → Set _ -Decidable P = ∀ x → Dec (P x) +Decidable : Pred A ℓ → Set _ +Decidable P = ∀ x → Dec (P x) --- Erasure: A decidable predicate gives rise to another one, more --- amenable to η-expansion +-- Erasure: A decidable predicate gives rise to another one, more +-- amenable to η-expansion -⌊_⌋ : {P : Pred A ℓ} → Decidable P → Pred A ℓ -⌊ P? ⌋ a = Lift _ (True (P? a)) +⌊_⌋ : {P : Pred A ℓ} → Decidable P → Pred A ℓ +⌊ P? ⌋ a = Lift _ (True (P? a)) --- Irrelevance - any two proofs that an element satifies P are --- indistinguishable. +-- Irrelevance - any two proofs that an element satifies P are +-- indistinguishable. -Irrelevant : Pred A ℓ → Set _ -Irrelevant P = ∀ {x} (a : P x) (b : P x) → a ≡ b +Irrelevant : Pred A ℓ → Set _ +Irrelevant P = ∀ {x} (a : P x) (b : P x) → a ≡ b --- Recomputability - we can rebuild a relevant proof given an --- irrelevant one. +-- Recomputability - we can rebuild a relevant proof given an +-- irrelevant one. -Recomputable : Pred A ℓ → Set _ -Recomputable P = ∀ {x} → .(P x) → P x +Recomputable : Pred A ℓ → Set _ +Recomputable P = ∀ {x} → .(P x) → P x ------------------------------------------------------------------------- --- Operations on sets +------------------------------------------------------------------------ +-- Operations on sets -infix 10 ⋃ ⋂ -infixr 9 _⊢_ -infixr 8 _⇒_ -infixr 7 _∩_ -infixr 6 _∪_ -infixr 6 _∖_ -infix 4 _≬_ +infix 10 ⋃ ⋂ +infixr 9 _⊢_ +infixr 8 _⇒_ +infixr 7 _∩_ +infixr 6 _∪_ +infixr 6 _∖_ +infix 4 _≬_ --- Complement. +-- Complement. -∁ : Pred A ℓ → Pred A ℓ -∁ P = λ x → x ∉ P +∁ : Pred A ℓ → Pred A ℓ +∁ P = λ x → x ∉ P --- Implication. +-- Implication. -_⇒_ : Pred A ℓ₁ → Pred A ℓ₂ → Pred A _ -P ⇒ Q = λ x → x ∈ P → x ∈ Q +_⇒_ : Pred A ℓ₁ → Pred A ℓ₂ → Pred A _ +P ⇒ Q = λ x → x ∈ P → x ∈ Q --- Union. +-- Union. -_∪_ : Pred A ℓ₁ → Pred A ℓ₂ → Pred A _ -P ∪ Q = λ x → x ∈ P ⊎ x ∈ Q +_∪_ : Pred A ℓ₁ → Pred A ℓ₂ → Pred A _ +P ∪ Q = λ x → x ∈ P ⊎ x ∈ Q --- Intersection. +-- Intersection. -_∩_ : Pred A ℓ₁ → Pred A ℓ₂ → Pred A _ -P ∩ Q = λ x → x ∈ P × x ∈ Q +_∩_ : Pred A ℓ₁ → Pred A ℓ₂ → Pred A _ +P ∩ Q = λ x → x ∈ P × x ∈ Q --- Difference. +-- Difference. -_∖_ : Pred A ℓ₁ → Pred A ℓ₂ → Pred A _ -P ∖ Q = λ x → x ∈ P × x ∉ Q +_∖_ : Pred A ℓ₁ → Pred A ℓ₂ → Pred A _ +P ∖ Q = λ x → x ∈ P × x ∉ Q --- Infinitary union. +-- Infinitary union. -⋃ : ∀ {i} (I : Set i) → (I → Pred A ℓ) → Pred A _ -⋃ I P = λ x → Σ[ i ∈ I ] P i x +⋃ : ∀ {i} (I : Set i) → (I → Pred A ℓ) → Pred A _ +⋃ I P = λ x → Σ[ i ∈ I ] P i x -syntax ⋃ I (λ i → P) = ⋃[ i ∶ I ] P +syntax ⋃ I (λ i → P) = ⋃[ i ∶ I ] P --- Infinitary intersection. +-- Infinitary intersection. -⋂ : ∀ {i} (I : Set i) → (I → Pred A ℓ) → Pred A _ -⋂ I P = λ x → (i : I) → P i x +⋂ : ∀ {i} (I : Set i) → (I → Pred A ℓ) → Pred A _ +⋂ I P = λ x → (i : I) → P i x -syntax ⋂ I (λ i → P) = ⋂[ i ∶ I ] P +syntax ⋂ I (λ i → P) = ⋂[ i ∶ I ] P --- Positive version of non-disjointness, dual to inclusion. +-- Positive version of non-disjointness, dual to inclusion. -_≬_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ -P ≬ Q = ∃ λ x → x ∈ P × x ∈ Q +_≬_ : Pred A ℓ₁ → Pred A ℓ₂ → Set _ +P ≬ Q = ∃ λ x → x ∈ P × x ∈ Q --- Update. +-- Update. -_⊢_ : (A → B) → Pred B ℓ → Pred A ℓ -f ⊢ P = λ x → P (f x) +_⊢_ : (A → B) → Pred B ℓ → Pred A ℓ +f ⊢ P = λ x → P (f x) ------------------------------------------------------------------------- --- Predicate combinators +------------------------------------------------------------------------ +-- Predicate combinators --- These differ from the set operations above, as the carrier set of the --- resulting predicates are not the same as the carrier set of the --- component predicates. +-- These differ from the set operations above, as the carrier set of the +-- resulting predicates are not the same as the carrier set of the +-- component predicates. -infixr 2 _⟨×⟩_ -infixr 2 _⟨⊙⟩_ -infixr 1 _⟨⊎⟩_ -infixr 0 _⟨→⟩_ -infixl 9 _⟨·⟩_ -infix 10 _~ -infixr 9 _⟨∘⟩_ -infixr 2 _//_ _\\_ +infixr 2 _⟨×⟩_ +infixr 2 _⟨⊙⟩_ +infixr 1 _⟨⊎⟩_ +infixr 0 _⟨→⟩_ +infixl 9 _⟨·⟩_ +infix 10 _~ +infixr 9 _⟨∘⟩_ +infixr 2 _//_ _\\_ --- Product. +-- Product. -_⟨×⟩_ : Pred A ℓ₁ → Pred B ℓ₂ → Pred (A × B) _ -(P ⟨×⟩ Q) (x , y) = x ∈ P × y ∈ Q +_⟨×⟩_ : Pred A ℓ₁ → Pred B ℓ₂ → Pred (A × B) _ +(P ⟨×⟩ Q) (x , y) = x ∈ P × y ∈ Q --- Sum over one element. +-- Sum over one element. -_⟨⊎⟩_ : Pred A ℓ → Pred B ℓ → Pred (A ⊎ B) _ -P ⟨⊎⟩ Q = [ P , Q ] +_⟨⊎⟩_ : Pred A ℓ → Pred B ℓ → Pred (A ⊎ B) _ +P ⟨⊎⟩ Q = [ P , Q ] --- Sum over two elements. +-- Sum over two elements. -_⟨⊙⟩_ : Pred A ℓ₁ → Pred B ℓ₂ → Pred (A × B) _ -(P ⟨⊙⟩ Q) (x , y) = x ∈ P ⊎ y ∈ Q +_⟨⊙⟩_ : Pred A ℓ₁ → Pred B ℓ₂ → Pred (A × B) _ +(P ⟨⊙⟩ Q) (x , y) = x ∈ P ⊎ y ∈ Q --- Implication. +-- Implication. -_⟨→⟩_ : Pred A ℓ₁ → Pred B ℓ₂ → Pred (A → B) _ -(P ⟨→⟩ Q) f = P ⊆ Q ∘ f +_⟨→⟩_ : Pred A ℓ₁ → Pred B ℓ₂ → Pred (A → B) _ +(P ⟨→⟩ Q) f = P ⊆ Q ∘ f --- Product. +-- Product. -_⟨·⟩_ : (P : Pred A ℓ₁) (Q : Pred B ℓ₂) → - (P ⟨×⟩ (P ⟨→⟩ Q)) ⊆ Q ∘ uncurry (flip _$_) -(P ⟨·⟩ Q) (p , f) = f p +_⟨·⟩_ : (P : Pred A ℓ₁) (Q : Pred B ℓ₂) → + (P ⟨×⟩ (P ⟨→⟩ Q)) ⊆ Q ∘ uncurry _|>_ +(P ⟨·⟩ Q) (p , f) = f p --- Converse. +-- Converse. -_~ : Pred (A × B) ℓ → Pred (B × A) ℓ -P ~ = P ∘ swap +_~ : Pred (A × B) ℓ → Pred (B × A) ℓ +P ~ = P ∘ swap --- Composition. +-- Composition. -_⟨∘⟩_ : Pred (A × B) ℓ₁ → Pred (B × C) ℓ₂ → Pred (A × C) _ -(P ⟨∘⟩ Q) (x , z) = ∃ λ y → (x , y) ∈ P × (y , z) ∈ Q +_⟨∘⟩_ : Pred (A × B) ℓ₁ → Pred (B × C) ℓ₂ → Pred (A × C) _ +(P ⟨∘⟩ Q) (x , z) = ∃ λ y → (x , y) ∈ P × (y , z) ∈ Q --- Post-division. +-- Post-division. -_//_ : Pred (A × C) ℓ₁ → Pred (B × C) ℓ₂ → Pred (A × B) _ -(P // Q) (x , y) = Q ∘ (y ,_) ⊆ P ∘ (x ,_) +_//_ : Pred (A × C) ℓ₁ → Pred (B × C) ℓ₂ → Pred (A × B) _ +(P // Q) (x , y) = Q ∘ (y ,_) ⊆ P ∘ (x ,_) --- Pre-division. +-- Pre-division. -_\\_ : Pred (A × C) ℓ₁ → Pred (A × B) ℓ₂ → Pred (B × C) _ -P \\ Q = (P ~ // Q ~) ~ +_\\_ : Pred (A × C) ℓ₁ → Pred (A × B) ℓ₂ → Pred (B × C) _ +P \\ Q = (P ~ // Q ~) ~ \ No newline at end of file