diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,102 @@ +0.13.3.0 +=== + +- Added `Read` instance for `Polar` in `NumHask.Algebra.Metric`. +- Added `NumHask.Algebra.Tropical` with the `MinPlus` tropical semiring. +- Added `StarSemiring` and `KleeneAlgebra` instances for `Bool`. +- Added `Magma`, `Unital` and `Idempotent` instances for `Bool`. +- Documented `StarSemiring` and `KleeneAlgebra` laws with the Conway equations. + +0.13.2.1 +=== + +- removed doctest-parallel test suite, use cabal-docspec in CI instead +- updated CI to use cabal-docspec 0.0.0.20250606 + +0.13.2 +=== + +- GHC 9.14.1 support +- simplified Cabal stanzas to best practice template +- fixed asinh bug in Field module + +0.13.1 +=== + +- added Data instances + + +0.13 +=== + +- added modF, divF and divModF as field versions of modulo and diviso Integral functions. +- fixed bug in EuclideanPair log function. +- BoundedJoinSemiLattice becomes LowerBounded +- BoundedMeetSemiLattice becomes UpperBounded +- switch to GHC2024 + +0.12.1 +=== + +- added doctests + +0.12 +=== + +- added SemiField, and bumped QuotientField to default for Subtraction. + +- moved infinity & nqn to SemiField, from Field. + +- introduced NumHask.Data.Positive + +- introduced NumHask.Data.Wrapped + +- Monus & Addus + +- hiding Prelude.Rational + +0.11.1.0 +=== +* Added Sum (..) +* Added Product (..) + +0.11.0.0 +=== + +* TypeFamilies introduced replacing FunDep usage for QuotientField, AdditiveAction, MultiplicativeAction, Basis. Classes go from Multi-parameter to single. +* EuclideanPair introduced as an intended DerivingVia support for 2 dimensional Basis & Direction instances. +* Complex modified to use EuclideanPair. Underlying representation changed to tuple and (+:) constructor as a top-level function. +* Action class operators changed from (.\*) to (|\*), and (\*.) to (\*|) etc. +* Ring, Field, Distributive & Module become type synonyms (were classes). +* Added Basis class replacing Norm & Signed +* extra type synonyms added for Basis specialisations: Absolute, Sign, EndoBased. +* abs becomes top-level function (previously method of Norm). +* sign removed and replaced with signum, mirroring Num. +* aboutEqual & nearZero moved outside Epsilon class definition. +* rationalised Language pragmas around GHC2021 +* introduced QuotientField instance for Complex & EuclideanPair without Ord constraint. + +0.10.0 +=== +* Moved operators back in. +* added doctests and properties +* added accsum & accproduct +* fixed Ratio Eq instance + +0.9.0 +=== +* Removed bounded classes. +* Moved operators outside of class definitions where possible. + +0.8.0 +===== + +* GHC 9.0.1 support +* Removed protolude and replaced it with prelude +* Removed NumHask.Data.Positive, NumHask.Data.LogFloat, NumHask.Data.Wrapper +* modified project build to cabal +* removed NegativeLiterals recommendation. + 0.7.0 ===== @@ -14,7 +113,6 @@ * Added doctests and laws * Improved haddocks * Made (^) a monomorphic `a -> Int -> a` and accept negative Ints - 0.6.0 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Tony Day (c) 2016 +Copyright (c) 2016, Tony Day All rights reserved. diff --git a/numhask.cabal b/numhask.cabal --- a/numhask.cabal +++ b/numhask.cabal @@ -1,113 +1,77 @@ -cabal-version: 2.4 +cabal-version: 3.0 name: numhask -version: 0.7.1.0 -synopsis: - A numeric class hierarchy. +version: 0.13.3.0 +license: BSD-3-Clause +license-file: LICENSE +copyright: Tony Day (c) 2016 +category: math +author: Tony Day +maintainer: tonyday567@gmail.com +homepage: https://github.com/tonyday567/numhask#readme +bug-reports: https://github.com/tonyday567/numhask/issues +synopsis: A numeric class hierarchy. description: - This package provides numeric classes alternate to the prelude specified in [haskell98](https://www.haskell.org/onlinereport/standard-prelude.html). - . - The numeric class constellation looks somewhat like: - . - ![nh](docs/other/nh.svg) - . - == Usage - . - >>> {-# LANGUAGE NegativeLiterals #-} - >>> {-# LANGUAGE RebindableSyntax #-} - >>> import NumHask.Prelude - . - See "NumHask" for a detailed overview. + This package provides alternative numeric classes over Prelude. -category: - mathematics -homepage: - https://github.com/tonyday567/numhask#readme -bug-reports: - https://github.com/tonyday567/numhask/issues -author: - Tony Day -maintainer: - tonyday567@gmail.com -copyright: - Tony Day -license: - BSD-3-Clause -license-file: - LICENSE -build-type: - Simple + The numeric class constellation looks somewhat like: + + ![nh](docs/other/nh12.svg) + + == Usage + + >>> {-# LANGUAGE GHC2024 #-} + >>> {-# LANGUAGE RebindableSyntax #-} + >>> import NumHask.Prelude + + See "NumHask" for a detailed overview. + +build-type: Simple tested-with: - GHC ==8.8.4 - || ==8.10.2 + ghc ==9.10.3 + ghc ==9.12.2 + ghc ==9.14.1 extra-doc-files: + ChangeLog.md other/*.svg - -extra-source-files: readme.md - ChangeLog.md source-repository head - type: - git - location: - https://github.com/tonyday567/numhask - subdir: - numhask -library - hs-source-dirs: - src + type: git + location: https://github.com/tonyday567/numhask + +common ghc-options-stanza ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints - -fwrite-ide-info - -hiedir=.hie - build-depends: - base >=4.7 && <5, - protolude >=0.3 && <0.4, - bifunctors >= 5.5 && < 5.6, - mmorph >= 1.1 && < 1.2, - random >= 1.2 && < 1.3, - transformers >= 0.5 && < 0.6, - text >= 1.2 && < 1.3, + +library + import: ghc-options-stanza + default-language: GHC2024 + hs-source-dirs: src + build-depends: base >=4.14 && <5 exposed-modules: NumHask + NumHask.Algebra.Action NumHask.Algebra.Additive NumHask.Algebra.Field NumHask.Algebra.Group NumHask.Algebra.Lattice - NumHask.Algebra.Module + NumHask.Algebra.Metric NumHask.Algebra.Multiplicative + NumHask.Algebra.Patterns NumHask.Algebra.Ring - NumHask.Analysis.Metric + NumHask.Algebra.Tropical NumHask.Data.Complex NumHask.Data.Integral - NumHask.Data.LogField NumHask.Data.Positive NumHask.Data.Rational NumHask.Data.Wrapped NumHask.Exception NumHask.Prelude - other-modules: - default-language: Haskell2010 -test-suite test - type: exitcode-stdio-1.0 - main-is: test.hs - hs-source-dirs: - test - build-depends: - QuickCheck >= 2.13 && < 2.15, - base >=4.7 && <5, - doctest >= 0.16 && < 0.18, - numhask, - default-language: Haskell2010 - ghc-options: - -Wall - -Wcompat - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wredundant-constraints + default-extensions: RebindableSyntax + diff --git a/other/nh.svg b/other/nh.svg deleted file mode 100644 --- a/other/nh.svg +++ /dev/null @@ -1,1 +0,0 @@ -AdditiveSubtractiveMultiplicativeDivisiveDistributiveRingFieldExpFieldQuotientFieldUpperBoundedFieldLowerBoundedFieldTrigFieldMultiplicativeActionModuleIntegralRatioSignedNormDirection diff --git a/other/nh11.svg b/other/nh11.svg new file mode 100644 --- /dev/null +++ b/other/nh11.svg @@ -0,0 +1,25 @@ +ActionsAdditiveBasisDirectionDistributiveDivisiveExpFieldFieldIntegralMultiplicativeQuotientFieldRatioRingSubtractiveTrigField diff --git a/other/nh12.svg b/other/nh12.svg new file mode 100644 --- /dev/null +++ b/other/nh12.svg @@ -0,0 +1,32 @@ +AdditiveBasisDirectionDistributiveDivisiveExpFieldFieldIntegralMultiplicativeQuotientFieldRatioRingSemiFieldSubtractiveTrigField diff --git a/other/nhmagma.svg b/other/nhmagma.svg deleted file mode 100644 --- a/other/nhmagma.svg +++ /dev/null @@ -1,2 +0,0 @@ -MagmaUnitalAssociativeCommutativeInvertibleAbsorbingAdditiveSubtractiveMultiplicativeDivisiveDistributiveRingField diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -1,27 +1,152 @@ numhask === -[![Build Status](https://travis-ci.org/tonyday567/numhask.svg)](https://travis-ci.org/tonyday567/numhask) [![Hackage](https://img.shields.io/hackage/v/numhask.svg)](https://hackage.haskell.org/package/numhask) - -This package provides numeric classes alternate to the prelude specified in haskell98. - -The numeric class constellation looks somewhat like: +[![Hackage](https://img.shields.io/hackage/v/numhask.svg)](https://hackage.haskell.org/package/numhask) +[![build](https://github.com/tonyday567/numhask/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/tonyday567/numhask/actions/workflows/haskell-ci.yml) -![nh](other/nh.svg) +![](other/nh12.svg) Usage === ``` haskell -{-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE RebindableSyntax #-} import NumHask.Prelude ``` -See the documentation in the Numhask module for a detailed overview. +See the documentation in the NumHask module for a detailed overview. -Develop +v0.12 notes === +SemiField +--- + +Compared to previous library versions, Ring and Field have been removed as super classes of QuotientField, and SemiField introduced as the new constraint. + +Old version: + +![](other/nh11.svg) + ``` -stack build --test --haddock --file-watch +type SemiField a = (Distributive a, Divisive a) + +class (SemiField a) => QuotientField a where + type Whole a :: Type + properFraction :: a -> (Whole a, a) ``` + +The notion of a quotient is now that which distributes and divides. + +Subtractive originally slipped in as a super class due to the notion of rounding down (or, specifically, towards zero). By using DefaultSignatures, a default for Subtractive-type numbers can be provided and still allow non-Subtractive (SemiField) things to be quotient fields. + +Infinity and nan move from a Field to a SemiField constraint - subtraction is not needed to come up with an infinity or silly compute. + +Positive +--- + +A motivation for SemiField was to introduce NumHask.Data.Positive into the library. Positive has no sane Subtractive instance (but should be able to be rounded). + +Out of the many approaches that can be taken in defining a positive number, the definition relies on a notion of truncated subtraction; that subtraction can be performed on positive numbers but, for answers outside the typed range, the lower bound should be returned. + +Specifically, the positive constructor needs to be supplied with a number that has a MeetSemiLattice instance, so that complex numbers and other geometries are correctly handled: + +``` haskell +ghci> 2 +: (-2) +Complex {complexPair = (2,-2)} +ghci> positive (2 +: (-2)) +UnsafePositive {unPositive = Complex {complexPair = (2,0)}} +``` + +Truncated Arithmetic +--- + +Truncated subtraction can be generalised to a notion of truncated arithmetic on a number with a typed range. This may be a direction explored further in the library including: + +- [epsilon, +infinity): A positive number type which is a safe divisor. +- /= zero, non-zero arithmetic (x - x returns epsilon, say) +- [0,1]: probability and weight arithmetic +- [-1,1]: correlation math + +magnitudes are positive +--- + +The current Basis instance of Double: + +``` haskell +instance Basis Double where + type Mag Double = Double + type Base Double = Double + magnitude = P.abs + basis = P.signum +``` + +is probably more correctly written as: + +``` haskell +instance Basis Double where + type Mag Double = Positive Double + type Base Double = Sign Double + magnitude = Positive . P.abs + basis = Sign . P.signum +``` + +where Sign is a future-imagined type representing {-1,0,1} or {-1,1} + +In Haskell, there is a basic choice between using multiple parameters for a type or embedding types using type families. Using multiple parameters would, in practice, force users to have to chose and write 'Basis Double Double Double' or 'Basis Positive Sign Double'. + +On balance, a computational chain involving magnitude is likely to be a single, underlying type, so that providing a Basis instance returning a Positive would result in a lot of unwrapping. + +``` haskell +-- endo-based +x == basis x * magnitude x + +-- if hetero-typed ... +x == (unSign $ basis x) * (unPositive $ magnitude x) +``` + +The library awaits real-world feedback on safety versus ergonomics. + +Monus +--- + +Truncated subtraction is encapsulated within the Monus class and supplied operator: + +``` haskell +ghci> 4 ∸ 7 :: Positive Int +UnsafePositive {unPositive = 0} +ghci> unPositive (4 ∸ 7 :: Positive Int) +0 +ghci> unPositive (7 ∸ 4 :: Positive Int) +3 +``` + +NumHask.Data.Wrapped +--- + +The introduction of Positive provoked including a wrapper type for most numhask types. This type can be used with derivingvia: + +``` haskell +newtype Positive a = UnsafePositive {unPositive :: a} + deriving stock + (Eq, Ord, Show) + deriving + ( Additive, + Multiplicative, + Divisive, + Integral, + FromInteger, + FromRational, + Basis, + Direction, + Epsilon, + AdditiveAction, + SubtractiveAction, + MultiplicativeAction, + DivisiveAction, + JoinSemiLattice, + MeetSemiLattice, + UpperBounded + ) + via (Wrapped a) +``` + diff --git a/src/NumHask.hs b/src/NumHask.hs --- a/src/NumHask.hs +++ b/src/NumHask.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE RebindableSyntax #-} -{-# OPTIONS_GHC -Wall #-} {-# OPTIONS_HADDOCK prune #-} -- | Numeric classes. @@ -14,57 +12,245 @@ -- * Prelude Mappings -- $mapping - -- $backend -- * Extensions -- $extensions - -- * Exports - module NumHask.Algebra.Additive, - module NumHask.Algebra.Field, - module NumHask.Algebra.Group, - module NumHask.Algebra.Lattice, - module NumHask.Algebra.Module, - module NumHask.Algebra.Multiplicative, - module NumHask.Algebra.Ring, - module NumHask.Analysis.Metric, - module NumHask.Data.Complex, - module NumHask.Data.Integral, - module NumHask.Data.LogField, - module NumHask.Data.Rational, - module NumHask.Data.Positive, - module NumHask.Exception, + -- * Additive + Additive (..), + sum, + accsum, + Subtractive (..), + + -- * Multiplicative + Multiplicative (..), + product, + accproduct, + Divisive (..), + + -- * Ring + Distributive, + Ring, + StarSemiring (..), + KleeneAlgebra, + InvolutiveRing (..), + two, + + -- * Tropical + MinPlus (..), + + -- * Field + Field, + ExpField (..), + QuotientField (..), + TrigField (..), + infinity, + negInfinity, + nan, + half, + modF, + divF, + divModF, + + -- * Lattice + JoinSemiLattice (..), + joinLeq, + (<\), + MeetSemiLattice (..), + meetLeq, + (>> :m -Prelude -- >>> :set -XRebindableSyntax --- >>> :set -XNegativeLiterals -- >>> import NumHask.Prelude -- >>> 1+1 -- 2 -- $extensions -- --- [RebindableSyntax](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/rebindable_syntax.html) and [NegativeLiterals](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/negative_literals.html) are both recommended for use with numhask. [LexicalNegation](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/lexical_negation.html) also looks sweet when it arrives. +-- [RebindableSyntax](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/rebindable_syntax.html) +-- is recommended for use with numhask. -- --- As a replacement for the numerical classes, numhask clashes significantly with an unqualified import of the @Prelude@. Either numhask modules should be qualified, or prelude turned off with the NoImplicitPrelude extension, or with RebindableSyntax, which implies NoImplicitPrelude. +-- As a replacement for the numerical classes, numhask clashes significantly with an +-- unqualified import of the @Prelude@. Either numhask modules should be qualified, +-- or prelude turned off with the NoImplicitPrelude extension, or with RebindableSyntax, +-- which implies NoImplicitPrelude. -- -- == defaulting -- @@ -72,10 +258,10 @@ -- -- >>> :set -XNoRebindableSyntax -- >>> :t 1 --- 1 :: Num p => p +-- 1 :: Num a => a -- -- >>> :t 1.0 --- 1.0 :: Fractional p => p +-- 1.0 :: Fractional a => a -- -- With RebindableSyntax (which also switches NoImplicitPrelude on) literal numbers change to the numhask types, 'FromInteger' and 'FromRational': -- @@ -92,60 +278,47 @@ -- >>> 1.0 -- 1.0 -- --- It is recommended to switch on RebindableSyntax to avoid Num constraints being introduced due to literal defaulting. The extension is a tradeoff, however, and usage comes attached with other non-numeric changes that "NumHask.Prelude" attempts to counteract. --- --- See See [haskell2010 Section 4.3.4](https://www.haskell.org/onlinereport/haskell2010/haskellch4.html#x10-750004.3) for the nuts and bolts to defaulting. --- --- The effect of [ExtendedDefaultRules](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/ghci.html#extension-ExtendedDefaultRules) in ghci or switched on as an extension also need to be understood. It can lead to unusual interactions with numerics and strange error messages at times because it adds @()@ and @[]@ to the start of the type defaulting list. --- --- == Negatives --- --- Without [NegativeLiterals](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/negative_literals.html), GHC and Haskell often reads a negative as subtraction rather than a minus. --- --- > :set -XNoNegativeLiterals --- > :t Point 1 -2 --- Point 1 -2 --- :: (Subtractive (Point a), FromInteger a, --- FromInteger (a -> Point a)) => --- a -> Pair a --- ... --- --- > :set -XNegativeLiterals --- > :t Point 1 -2 --- Point 1 -2 :: FromInteger a => Point a +-- RebindableSyntax is a tradeoff, however, and usage comes attached with other non-numeric changes +-- that "NumHask.Prelude" attempts to counteract. -- --- > Point 1 -2 --- Point 1 -2 +-- See [haskell2010 Section 4.3.4](https://www.haskell.org/onlinereport/haskell2010/haskellch4.html#x10-750004.3) for the nuts and bolts to defaulting. -- --- [LexicalNegation](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/lexical_negation.html) is coming soon as a valid replacement for NegativeLiterals and will tighten things up further. +-- The effect of [ExtendedDefaultRules](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/ghci.html#extension-ExtendedDefaultRules) +-- in ghci or switched on as an extension also need to be understood. +-- It can lead to unusual interactions with numerics and strange error messages at times because +-- it adds @()@ and @[]@ to the start of the type defaulting list. -- $overview --- numhask is largely a set of classes that can replace the 'GHC.Num.Num' class and it's descendents. Principles that have guided design include: +-- numhask is largely a set of classes that can replace the 'GHC.Num.Num' class and it's descendents. +-- Principles that have guided design include: -- --- - __/balanced class density/__. The numeric heirarchy begins with addition and multiplication, choosing not to build from a 'Magma' base. Whilst not being as principled as other approaches, this circumvents the instance explosion problems of Haskell whilst maintaining clarity of class purpose. +-- - __/balanced class density/__. The numeric hierarchy begins with addition and multiplication, +-- choosing not to build from a Magma base. Whilst not being as principled as other approaches, this circumvents the instance explosion problems of Haskell whilst maintaining clarity of class purpose. -- --- - __/operator-first/__. In most cases, a class exists to define useful operators. The exceptions are 'Distributive', 'Ring' and 'Field', which are collections of operators representing major teleological fault lines. +-- - __/operator-first/__. In all cases, a class exists to define useful operators. +-- Major class groupings, such as 'Distributive', 'Ring' and 'Field' are type synonyms. -- --- - __/lawful/__. Most classes have laws associated with them that serve to relate class operators together in a meaningful way. +-- - __/lawful/__. All classes have laws associated with them that serve to relate class operators together in a meaningful way. -- --- - __/low-impact/__. The library attempts to fit in with the rest of the Haskell ecosystem. It provides instances for common numbers: 'GHC.Num.Int', 'GHC.Num.Integer', 'GHC.Float.Double', 'GHC.Float.Float' and the Word classes. It avoids name (or idea) clashes with other popular libraries and adopts conventions in the where they make sense. +-- - __/low-impact/__. The library attempts to fit in with the rest of the Haskell ecosystem. +-- It provides instances for common numbers: 'GHC.Num.Int', 'GHC.Num.Integer', 'GHC.Float.Double', +-- 'GHC.Float.Float', 'GHC.Natural.Natural', and the Word classes. It avoids name (or idea) clashes with other popular libraries +-- and adopts conventions in the +-- where they make sense. -- --- - __/proof-of-concept/__. The library may be below industrial-strength depending on a definition of this term. At the same time, correspondence around improving the library is most welcome. +-- - __/proof-of-concept/__. The library may be below industrial-strength depending on a definition +-- of this term. At the same time, correspondence around improving the library is most welcome. -- $pictures -- -- The class heirarchy looks somewhat like this: --- ![classes](other/nh.svg) -- --- If the base started with magma, and the library tolerated clashing with 'Data.Semigroup' and 'Data.Monoid' in base, it would look like: --- --- ![magma classes](other/nhmagma.svg) --- --- These first two levels, contained in 'NumHask.Algebra.Group' can be considered "morally" super-classes. +-- ![classes](other/nh.svg) -- $mapping -- --- 'GHC.Num' is a very old part of haskell, and is virtually unchanged since it's specification in [haskell98](https://www.haskell.org/onlinereport/standard-prelude.html). +-- 'GHC.Num' is a very old part of haskell, and is virtually unchanged since its specification in +-- [haskell98](https://www.haskell.org/onlinereport/standard-prelude.html). -- -- A deconstruction of 'GHC.Num.Num' and mapping to numhask. -- @@ -163,7 +336,7 @@ -- -- '(*)' is an operator of the 'Multiplicative' class. -- --- 'zero' and 'one' are also introduced to the numeric heirarchy. +-- 'zero' and 'one' are also introduced to the numeric hierarchy. -- -- > -- | Absolute value. -- > abs :: a -> a @@ -176,10 +349,16 @@ -- > -- or @1@ (positive). -- > signum :: a -> a -- --- 'abs' is a function in the 'NumHask.Analysis.Metric.Signed' class. The concept of an absolute value can also include situations where the domain and codomain are different, and 'norm' as a function in the 'NumHask.Analysis.Metric.Norm' class is supplied for these cases. +-- The concept of an absolute value and the sign of a number can include situations where the domain type is different to the absolute and sign codomain types. -- --- 'NumHask.Analysis.Metric.sign' replaces 'GHC.Num.signum', because signum is simply a naming crime. 'NumHask.Analysis.Metric.basis' can also be seen as a generalisation of sign. +-- A new class, 'Basis' is supplied to handle these situations: -- +-- - the 'magnitude' method is a generalisation of 'abs' +-- +-- - the 'basis' method is a generalisation of 'signum' +-- +-- 'NumHask.Algebra.Metric.abs' and 'NumHask.Algebra.Metric.signum' are specialisations of these methods. +-- -- > -- | Conversion from an 'Integer'. -- > -- An integer literal represents the application of the function -- > -- 'fromInteger' to the appropriate value of type 'Integer', @@ -188,17 +367,18 @@ -- -- 'FromInteger' becomes its own class and 'FromIntegral' is introduced to polymorphise the covariant. -- --- Mappings from other areas of prelude include:\ +-- Mappings from other areas of prelude include: -- --- 'GHC.Real.Integral' becomes 'Integral' and a polymorphic 'ToIntegral' is introduced. +-- - 'GHC.Real.Integral' becomes 'Integral' and a polymorphic 'ToIntegral' is introduced. -- --- 'GHC.Real.Fractional' is roughly synonymous to 'Field' together with a polymorphic 'FromRatio'. +-- - 'GHC.Real.Fractional' is roughly synonymous to 'Field' together with a polymorphic 'FromRatio'. -- --- 'GHC.Real.RealFrac' becomes the polymorphic 'QuotientField' +-- - 'GHC.Real.RealFrac' becomes 'QuotientField' with a polymorphic 'Whole' type using Type Families. -- --- 'GHC.Float.Floating' is split into 'ExpField' and 'TrigField' +-- - 'GHC.Float.Floating' is split into 'ExpField' and 'TrigField' -- --- 'GHC.Float.RealFloat' is not attempted. Life is too short. - --- $backend --- NumHask imports [protolude](https://hackage.haskell.org/package/protolude) as a base prelude with some minor tweaks. +-- - 'GHC.Float.RealFloat' is not attempted. Life is too short. +-- +-- - Complex is resupplied in 'NumHask.Data.Complex' but with some functionality deriving via 'NumHask.Algebra.Metric.EuclideanPair'. The underlying representation has also been switched to a newtype-wrapped tuple. +-- +-- In addition to base changes, alternatives to 'sum' and 'product' from 'Data.Foldable' are also supplied. diff --git a/src/NumHask/Algebra/Action.hs b/src/NumHask/Algebra/Action.hs new file mode 100644 --- /dev/null +++ b/src/NumHask/Algebra/Action.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | Algebra for Actions +-- +-- Convention: the |'s in the operators point towards the higher-kinded number, representing an operator or action __into__ a structure. +module NumHask.Algebra.Action + ( AdditiveAction (..), + (+|), + SubtractiveAction (..), + (-|), + MultiplicativeAction (..), + (*|), + DivisiveAction (..), + (/|), + Module, + TrivialAction (..), + ) +where + +import Data.Kind (Type) +import NumHask.Algebra.Additive (Additive (..), Subtractive (..)) +import NumHask.Algebra.Multiplicative (Divisive (..), Multiplicative (..)) +import NumHask.Algebra.Ring (Distributive) +import Prelude (Eq, Ord, flip) + +-- | Additive Action +-- +-- > m |+ zero == m +class + (Additive (AdditiveScalar m)) => + AdditiveAction m + where + type AdditiveScalar m :: Type + + infixl 6 |+ + (|+) :: m -> AdditiveScalar m -> m + +infixl 6 +| + +-- | flipped additive action +-- +-- > (+|) == flip (|+) +-- > zero +| m = m +(+|) :: (AdditiveAction m) => AdditiveScalar m -> m -> m +(+|) = flip (|+) + +-- | Subtractive Action +-- +-- > m |- zero = m +class + (AdditiveAction m, Subtractive (AdditiveScalar m)) => + SubtractiveAction m + where + infixl 6 |- + (|-) :: m -> AdditiveScalar m -> m + +infixl 6 -| + +-- | Subtraction with the scalar on the left +-- +-- > (-|) == (+|) . negate +-- > zero -| m = negate m +(-|) :: (AdditiveAction m, Subtractive m) => AdditiveScalar m -> m -> m +a -| b = a +| negate b + +-- | Multiplicative Action +-- +-- > m |* one = m +-- > m |* zero = zero +class + (Multiplicative (Scalar m)) => + MultiplicativeAction m + where + type Scalar m :: Type + + infixl 7 |* + (|*) :: m -> Scalar m -> m + +infixl 7 *| + +-- | flipped multiplicative action +-- +-- > (*|) == flip (|*) +-- > one *| m = one +-- > zero *| m = zero +(*|) :: (MultiplicativeAction m) => Scalar m -> m -> m +(*|) = flip (|*) + +-- | Divisive Action +-- +-- > m |/ one = m +class + (Divisive (Scalar m), MultiplicativeAction m) => + DivisiveAction m + where + infixl 7 |/ + (|/) :: m -> Scalar m -> m + +-- | left scalar division +-- +-- > (/|) == (*|) . recip +-- > one |/ m = recip m +(/|) :: (MultiplicativeAction m, Divisive m) => Scalar m -> m -> m +a /| b = a *| recip b + +-- | A +-- +-- > a *| one == a +-- > (a + b) *| c == (a *| c) + (b *| c) +-- > c |* (a + b) == (c |* a) + (c |* b) +-- > a *| zero == zero +-- > a *| b == b |* a +type Module m = (Distributive (Scalar m), MultiplicativeAction m) + +-- | An action of a set of numbers on itself +newtype TrivialAction a = TrivialAction + { getTrivialAction :: a + } + deriving (Eq, Ord, Additive, Subtractive, Multiplicative, Divisive) + +instance (Additive a) => AdditiveAction (TrivialAction a) where + type AdditiveScalar (TrivialAction a) = a + TrivialAction a |+ b = TrivialAction (a + b) + +instance (Subtractive a) => SubtractiveAction (TrivialAction a) where + TrivialAction a |- b = TrivialAction (a - b) + +instance (Multiplicative a) => MultiplicativeAction (TrivialAction a) where + type Scalar (TrivialAction a) = a + TrivialAction a |* b = TrivialAction (a * b) + +instance (Divisive a) => DivisiveAction (TrivialAction a) where + TrivialAction a |/ b = TrivialAction (a / b) diff --git a/src/NumHask/Algebra/Additive.hs b/src/NumHask/Algebra/Additive.hs --- a/src/NumHask/Algebra/Additive.hs +++ b/src/NumHask/Algebra/Additive.hs @@ -1,26 +1,26 @@ -{-# OPTIONS_GHC -Wall #-} - -- | Additive classes module NumHask.Algebra.Additive ( Additive (..), + Sum (..), sum, + accsum, Subtractive (..), ) where import Data.Int (Int16, Int32, Int64, Int8) +import Data.Semigroup (Semigroup (..)) +import Data.Traversable (mapAccumL) import Data.Word (Word, Word16, Word32, Word64, Word8) import GHC.Natural (Natural (..)) -import Prelude (Bool, Double, Float, Int, Integer) -import qualified Prelude as P +import Prelude (Bool, Double, Eq, Float, Int, Integer, Ord, Show, fromInteger) +import Prelude qualified as P -- $setup -- +-- >>> :m -Prelude -- >>> :set -XRebindableSyntax --- >>> :set -XNegativeLiterals --- >>> :set -XFlexibleContexts -- >>> import NumHask.Prelude --- >>> import Test.QuickCheck -- | or [Addition](https://en.wikipedia.org/wiki/Addition) -- @@ -44,10 +44,36 @@ zero :: a +-- | A wrapper for an Additive which distinguishes the additive structure +-- +-- @since 0.11.1 +newtype Sum a = Sum + { getSum :: a + } + deriving (Eq, Ord, Show) + +instance (Additive a) => P.Semigroup (Sum a) where + Sum a <> Sum b = Sum (a + b) + +instance (Additive a) => P.Monoid (Sum a) where + mempty = Sum zero + +deriving instance (Additive a) => Additive (Sum a) + -- | Compute the sum of a 'Data.Foldable.Foldable'. +-- +-- >>> sum [0..10] +-- 55 sum :: (Additive a, P.Foldable f) => f a -> a -sum = P.foldr (+) zero +sum = getSum P.. P.foldMap Sum +-- | Compute the accumulating sum of a 'Data.Traversable.Traversable'. +-- +-- >>> accsum [0..10] +-- [0,1,3,6,10,15,21,28,36,45,55] +accsum :: (Additive a, P.Traversable f) => f a -> f a +accsum = P.snd P.. mapAccumL (\a b -> (a + b, a + b)) zero + -- | or [Subtraction](https://en.wikipedia.org/wiki/Subtraction) -- -- prop> \a -> a - a == zero @@ -62,17 +88,21 @@ -- >>> 1 - 2 -- -1 class (Additive a) => Subtractive a where + {-# MINIMAL (-) | negate #-} + negate :: a -> a + negate a = zero - a infixl 6 - (-) :: a -> a -> a - (-) a b = a + negate b + a - b = a + negate b instance Additive Double where (+) = (P.+) zero = 0 instance Subtractive Double where + (-) = (P.-) negate = P.negate instance Additive Float where @@ -80,6 +110,7 @@ zero = 0 instance Subtractive Float where + (-) = (P.-) negate = P.negate instance Additive Int where @@ -87,6 +118,7 @@ zero = 0 instance Subtractive Int where + (-) = (P.-) negate = P.negate instance Additive Integer where @@ -94,20 +126,19 @@ zero = 0 instance Subtractive Integer where + (-) = (P.-) negate = P.negate instance Additive Bool where (+) = (P.||) zero = P.False -instance Subtractive Bool where - negate = P.not - instance Additive Natural where (+) = (P.+) zero = 0 instance Subtractive Natural where + (-) = (P.-) negate = P.negate instance Additive Int8 where @@ -115,6 +146,7 @@ zero = 0 instance Subtractive Int8 where + (-) = (P.-) negate = P.negate instance Additive Int16 where @@ -122,6 +154,7 @@ zero = 0 instance Subtractive Int16 where + (-) = (P.-) negate = P.negate instance Additive Int32 where @@ -129,6 +162,7 @@ zero = 0 instance Subtractive Int32 where + (-) = (P.-) negate = P.negate instance Additive Int64 where @@ -136,6 +170,7 @@ zero = 0 instance Subtractive Int64 where + (-) = (P.-) negate = P.negate instance Additive Word where @@ -143,6 +178,7 @@ zero = 0 instance Subtractive Word where + (-) = (P.-) negate = P.negate instance Additive Word8 where @@ -150,6 +186,7 @@ zero = 0 instance Subtractive Word8 where + (-) = (P.-) negate = P.negate instance Additive Word16 where @@ -157,6 +194,7 @@ zero = 0 instance Subtractive Word16 where + (-) = (P.-) negate = P.negate instance Additive Word32 where @@ -164,6 +202,7 @@ zero = 0 instance Subtractive Word32 where + (-) = (P.-) negate = P.negate instance Additive Word64 where @@ -171,11 +210,13 @@ zero = 0 instance Subtractive Word64 where + (-) = (P.-) negate = P.negate -instance Additive b => Additive (a -> b) where +instance (Additive b) => Additive (a -> b) where f + f' = \a -> f a + f' a zero _ = zero -instance Subtractive b => Subtractive (a -> b) where +instance (Subtractive b) => Subtractive (a -> b) where + f - f' = \a -> f a - f' a negate f = negate P.. f diff --git a/src/NumHask/Algebra/Field.hs b/src/NumHask/Algebra/Field.hs --- a/src/NumHask/Algebra/Field.hs +++ b/src/NumHask/Algebra/Field.hs @@ -1,44 +1,52 @@ {-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE TypeFamilies #-} --- | Field classes +-- | [field](https://en.wikipedia.org/wiki/Field_(mathematics\)) classes module NumHask.Algebra.Field - ( Field, + ( SemiField, + Field, ExpField (..), QuotientField (..), - UpperBoundedField (..), - LowerBoundedField (..), + infinity, + negInfinity, + nan, TrigField (..), half, + modF, + divF, + divModF, ) where import Data.Bool (bool) -import NumHask.Algebra.Additive +import Data.Kind +import NumHask.Algebra.Additive (Additive (..), Subtractive (..), (-)) import NumHask.Algebra.Multiplicative -import NumHask.Algebra.Ring -import NumHask.Data.Integral -import Prelude ((.)) -import qualified Prelude as P + ( Divisive (..), + Multiplicative (..), + (/), + ) +import NumHask.Algebra.Ring (Distributive, Ring, two) +import NumHask.Data.Integral (FromIntegral (..), Integral, even) +import Prelude (Eq (..), (.)) +import Prelude qualified as P -- $setup -- +-- >>> :m -Prelude -- >>> :set -XRebindableSyntax --- >>> :set -XNegativeLiterals --- >>> :set -XFlexibleContexts -- >>> :set -XScopedTypeVariables -- >>> import NumHask.Prelude --- >>> import Test.QuickCheck +-- | A is a field with no subtraction. +-- +-- @since 0.12 +type SemiField a = (Distributive a, Divisive a) + -- | A is a set -- on which addition, subtraction, multiplication, and division are defined. It is also assumed that multiplication is distributive over addition. -- --- A summary of the rules inherited from super-classes of Field. Floating point computation is a terrible, messy business and, in practice, only rough approximation can be achieve for association and distribution. +-- A summary of the rules inherited from super-classes of Field: -- -- > zero + a == a -- > a + zero == a @@ -59,31 +67,33 @@ -- > recip a == one / a || a == zero -- > recip a * a == one || a == zero -- > a * recip a == one || a == zero -class - (Distributive a, Subtractive a, Divisive a) => - Field a - -instance Field P.Double - -instance Field P.Float - -instance Field b => Field (a -> b) +type Field a = (Ring a, Divisive a) -- | A hyperbolic field class -- --- > sqrt . (**2) == id --- > log . exp == id --- > for +ive b, a != 0,1: a ** logBase a b ≈ b +-- prop> \(a::Double) -> a < zero || (sqrt . (**2)) a == a +-- prop> \(a::Double) -> a < zero || (log . exp) a ~= a +-- prop> \(a::Double) (b::Double) -> (b < zero) || a <= zero || a == 1 || abs (a ** logBase a b - b) < 10 * epsilon class (Field a) => ExpField a where exp :: a -> a log :: a -> a - logBase :: a -> a -> a - logBase a b = log b / log a (**) :: a -> a -> a (**) a b = exp (log a * b) + + -- | log to the base of + -- + -- >>> logBase 2 8 + -- 2.9999999999999996 + logBase :: a -> a -> a + logBase a b = log b / log a + + -- | square root + -- + -- >>> sqrt 4 + -- 2.0 sqrt :: a -> a sqrt a = a ** (one / (one + one)) @@ -97,118 +107,110 @@ log = P.log (**) = (P.**) -instance ExpField b => ExpField (a -> b) where +instance (ExpField b) => ExpField (a -> b) where exp f = exp . f log f = log . f - logBase f f' a = logBase (f a) (f' a) - f ** f' = \a -> f a ** f' a - sqrt f = sqrt . f --- | Conversion from a 'Field' to a 'Ring' +-- | Quotienting of a 'Field' into a 'NumHask.Algebra.Ring' -- -- See [Field of fractions](https://en.wikipedia.org/wiki/Field_of_fractions) -- --- > a - one < floor a <= a <= ceiling a < a + one --- > round a == floor (a + half) -class (Field a, Multiplicative b, Additive b) => QuotientField a b where - properFraction :: a -> (b, a) +-- > \a -> a - one < floor a <= a <= ceiling a < a + one +class (SemiField a) => QuotientField a where + type Whole a :: Type + properFraction :: a -> (Whole a, a) - round :: a -> b - default round :: (P.Ord a, P.Ord b, Subtractive b, Integral b) => a -> b + -- | round to the nearest Int + -- + -- Exact ties are managed by rounding down ties if the whole component is even. + -- + -- >>> round (1.5 :: Double) + -- 2 + -- + -- >>> round (2.5 :: Double) + -- 2 + round :: a -> Whole a + default round :: (Subtractive a, Integral (Whole a), P.Eq (Whole a), P.Ord a, Subtractive (Whole a)) => a -> Whole a round x = case properFraction x of (n, r) -> let m = bool (n + one) (n - one) (r P.< zero) - half_down = abs' r - (one / (one + one)) + half_up = abs' r + half abs' a | a P.< zero = negate a | P.otherwise = a - in case P.compare half_down zero of + in case P.compare half_up one of P.LT -> n P.EQ -> bool m n (even n) P.GT -> m - ceiling :: a -> b - default ceiling :: (P.Ord a) => a -> b - ceiling x = bool n (n + one) (r P.>= zero) + -- | supply the next upper whole component + -- + -- >>> ceiling (1.001 :: Double) + -- 2 + ceiling :: a -> Whole a + default ceiling :: (P.Ord a, Distributive (Whole a)) => a -> Whole a + ceiling x = bool n (n + one) (r P.> zero) where (n, r) = properFraction x - floor :: a -> b - default floor :: (P.Ord a, Subtractive b) => a -> b + -- | supply the previous lower whole component + -- + -- >>> floor (1.001 :: Double) + -- 1 + floor :: a -> Whole a + default floor :: (P.Ord a, Subtractive (Whole a), Distributive (Whole a)) => a -> Whole a floor x = bool n (n - one) (r P.< zero) where (n, r) = properFraction x - truncate :: a -> b - default truncate :: (P.Ord a) => a -> b + -- | supply the whole component closest to zero + -- + -- >>> floor (-1.001 :: Double) + -- -2 + -- + -- >>> truncate (-1.001 :: Double) + -- -1 + truncate :: a -> Whole a + default truncate :: (P.Ord a) => a -> Whole a truncate x = bool (ceiling x) (floor x) (x P.> zero) -instance QuotientField P.Float P.Integer where - properFraction = P.properFraction - -instance QuotientField P.Double P.Integer where - properFraction = P.properFraction - -instance QuotientField P.Float P.Int where +instance QuotientField P.Float where + type Whole P.Float = P.Int properFraction = P.properFraction -instance QuotientField P.Double P.Int where +instance QuotientField P.Double where + type Whole P.Double = P.Int properFraction = P.properFraction -instance QuotientField b c => QuotientField (a -> b) (a -> c) where - properFraction f = (P.fst . frac, P.snd . frac) - where - frac a = properFraction @b @c (f a) - - round f = round . f - - ceiling f = ceiling . f - - floor f = floor . f - - truncate f = truncate . f - --- | A bounded field introduces the concepts of infinity and NaN. +-- | infinity is defined for any 'Field'. -- --- > one / zero + infinity == infinity --- > infinity + a == infinity --- > zero / zero != nan +-- >>> one / zero + infinity +-- Infinity -- --- Note the tricky law that, although nan is assigned to zero/zero, they are never-the-less not equal. A committee decided this. -class - (Field a) => - UpperBoundedField a - where - infinity :: a - infinity = one / zero - - nan :: a - nan = zero / zero - -instance UpperBoundedField P.Float - -instance UpperBoundedField P.Double - -instance UpperBoundedField b => UpperBoundedField (a -> b) where - infinity _ = infinity - nan _ = nan - --- | Negative infinity. -class - (Subtractive a, Field a) => - LowerBoundedField a - where - negInfinity :: a - negInfinity = negate (one / zero) - -instance LowerBoundedField P.Float +-- >>> infinity + 1 +-- Infinity +infinity :: (SemiField a) => a +infinity = one / zero -instance LowerBoundedField P.Double +-- | nan is defined as zero/zero +-- +-- but note the (social) law: +-- +-- >>> nan == zero / zero +-- False +nan :: (SemiField a) => a +nan = zero / zero -instance LowerBoundedField b => LowerBoundedField (a -> b) where - negInfinity _ = negInfinity +-- | negative infinity +-- +-- >>> negInfinity + infinity +-- NaN +negInfinity :: (Field a) => a +negInfinity = negate infinity -- | Trigonometric Field +-- +-- The list of laws is quite long: class (Field a) => TrigField a @@ -240,7 +242,7 @@ atan2 = P.atan2 sinh = P.sinh cosh = P.cosh - asinh = P.sinh + asinh = P.asinh acosh = P.acosh atanh = P.atanh @@ -254,11 +256,11 @@ atan2 = P.atan2 sinh = P.sinh cosh = P.cosh - asinh = P.sinh + asinh = P.asinh acosh = P.acosh atanh = P.atanh -instance TrigField b => TrigField (a -> b) where +instance (TrigField b) => TrigField (a -> b) where pi _ = pi sin f = sin . f cos f = cos . f @@ -272,6 +274,49 @@ acosh f = acosh . f atanh f = atanh . f --- | A 'half' is a 'Field' because it requires addition, multiplication and division. -half :: (Field a) => a +-- | A half of 'one' +-- +-- >>> half :: Double +-- 0.5 +half :: (Additive a, Divisive a) => a half = one / two + +-- | Approximate modulo for fields +-- +-- @since 0.13 +-- +-- >>> modF 1.5 1.2 +-- 0.30000000000000004 +modF :: (Eq a, Field a, FromIntegral a (Whole a), QuotientField a) => a -> a -> a +modF n d + | d == infinity = n + | d == zero = nan + | P.True = n - d * fromIntegral (floor (n / d)) + +-- | Approximate diviso for fields. +-- +-- Compared with 'NumHask.Algebra.Field.div', divF returns the original type rather than the 'Whole' type. +-- +-- @since 0.13 +-- +-- >>> divF 1.5 1.2 +-- 1.0 +divF :: (Eq a, Field a, FromIntegral a (Whole a), QuotientField a) => a -> a -> a +divF n d + | d == infinity = zero + | d == zero = infinity + | P.True = fromIntegral (floor (n / d)) + +-- | Approximate `NumHask.Algebra.Field.divMod` for fields. +-- +-- @since 0.13 +-- +-- >>> divModF 1.5 1.2 +-- (1.0,0.30000000000000004) +divModF :: (Eq a, Field a, FromIntegral a (Whole a), QuotientField a) => a -> a -> (a, a) +divModF n d + | d == infinity = (zero, n) + | d == zero = (infinity, nan) + | P.True = (div', n - d * div') + where + div' = fromIntegral (floor (n / d)) diff --git a/src/NumHask/Algebra/Group.hs b/src/NumHask/Algebra/Group.hs --- a/src/NumHask/Algebra/Group.hs +++ b/src/NumHask/Algebra/Group.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall #-} - -- | The Group hierarchy module NumHask.Algebra.Group ( Magma (..), @@ -41,9 +37,15 @@ infix 3 ⊕ (⊕) :: a -> a -> a -instance Magma b => Magma (a -> b) where +instance (Magma b) => Magma (a -> b) where f ⊕ g = \a -> f a ⊕ g a +instance Magma Bool where + a ⊕ b = a || b + +instance Unital Bool where + unit = False + -- | A Unital Magma is a magma with an -- (the -- unit). @@ -51,12 +53,12 @@ -- > unit ⊕ a = a -- > a ⊕ unit = a class - Magma a => + (Magma a) => Unital a where unit :: a -instance Unital b => Unital (a -> b) where +instance (Unital b) => Unital (a -> b) where {-# INLINE unit #-} unit _ = unit @@ -64,51 +66,49 @@ -- -- > (a ⊕ b) ⊕ c = a ⊕ (b ⊕ c) class - Magma a => + (Magma a) => Associative a -instance Associative b => Associative (a -> b) +instance (Associative b) => Associative (a -> b) -- | A Commutative Magma is a Magma where the binary operation is -- . -- -- > a ⊕ b = b ⊕ a class - Magma a => + (Magma a) => Commutative a -instance Commutative b => Commutative (a -> b) +instance (Commutative b) => Commutative (a -> b) -- | An Invertible Magma -- -- > ∀ a,b ∈ T: inv a ⊕ (a ⊕ b) = b = (b ⊕ a) ⊕ inv a class - Magma a => + (Magma a) => Invertible a where inv :: a -> a -instance Invertible b => Invertible (a -> b) where +instance (Invertible b) => Invertible (a -> b) where {-# INLINE inv #-} inv f = inv . f -- | A is a -- Associative, Unital and Invertible Magma. -class (Associative a, Unital a, Invertible a) => Group a - -instance (Associative a, Unital a, Invertible a) => Group a +type Group a = (Associative a, Unital a, Invertible a) -- | An Absorbing is a Magma with an -- -- -- > a ⊕ absorb = absorb class - Magma a => + (Magma a) => Absorbing a where absorb :: a -instance Absorbing b => Absorbing (a -> b) where +instance (Absorbing b) => Absorbing (a -> b) where {-# INLINE absorb #-} absorb _ = absorb @@ -117,14 +117,14 @@ -- -- > a ⊕ a = a class - Magma a => + (Magma a) => Idempotent a -instance Idempotent b => Idempotent (a -> b) +instance (Idempotent b) => Idempotent (a -> b) +instance Idempotent Bool + -- | An is an -- Associative, Unital, Invertible and Commutative Magma . In other words, it -- is a Commutative Group -class (Associative a, Unital a, Invertible a, Commutative a) => AbelianGroup a - -instance (Associative a, Unital a, Invertible a, Commutative a) => AbelianGroup a +type AbelianGroup a = (Associative a, Unital a, Invertible a, Commutative a) diff --git a/src/NumHask/Algebra/Lattice.hs b/src/NumHask/Algebra/Lattice.hs --- a/src/NumHask/Algebra/Lattice.hs +++ b/src/NumHask/Algebra/Lattice.hs @@ -1,22 +1,20 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall #-} - -- | [Lattices](https://en.wikipedia.org/wiki/Lattice_(order\)) module NumHask.Algebra.Lattice ( JoinSemiLattice (..), joinLeq, + (<\), MeetSemiLattice (..), meetLeq, - BoundedJoinSemiLattice (..), - BoundedMeetSemiLattice (..), + ( a -> a -> Bool joinLeq x y = (x \/ y) == y +infixr 6 <\ + +-- | The partial ordering induced by the join-semilattice structure +(<\) :: (JoinSemiLattice a) => a -> a -> Bool +(<\) = joinLeq + -- | A algebraic structure with element meets: See [Semilattice](http://en.wikipedia.org/wiki/Semilattice) -- -- > Associativity: x /\ (y /\ z) == (x /\ y) /\ z @@ -55,54 +62,59 @@ meetLeq :: (MeetSemiLattice a) => a -> a -> Bool meetLeq x y = (x /\ y) == x +infixr 6 a -> a -> Bool +( Absorption: a \/ (a /\ b) == a /\ (a \/ b) == a -class (JoinSemiLattice a, MeetSemiLattice a) => Lattice a - -instance (JoinSemiLattice a, MeetSemiLattice a) => Lattice a +type Lattice a = (JoinSemiLattice a, MeetSemiLattice a) -- | A join-semilattice with an identity element 'bottom' for '\/'. -- --- > Identity: x \/ bottom == x -class JoinSemiLattice a => BoundedJoinSemiLattice a where +-- > x \/ bottom == x +class (JoinSemiLattice a) => LowerBounded a where bottom :: a -- | A meet-semilattice with an identity element 'top' for '/\'. -- --- > Identity: x /\ top == x -class MeetSemiLattice a => BoundedMeetSemiLattice a where +-- > x /\ top == x +class (MeetSemiLattice a) => UpperBounded a where top :: a -- | Lattices with both bounds -class (JoinSemiLattice a, MeetSemiLattice a, BoundedJoinSemiLattice a, BoundedMeetSemiLattice a) => BoundedLattice a - -instance (JoinSemiLattice a, MeetSemiLattice a, BoundedJoinSemiLattice a, BoundedMeetSemiLattice a) => BoundedLattice a +-- +-- > x /\ bottom == bottom +-- > x \/ top == top +type BoundedLattice a = (JoinSemiLattice a, MeetSemiLattice a, LowerBounded a, UpperBounded a) instance JoinSemiLattice Float where - (\/) = min + (\/) = max instance MeetSemiLattice Float where - (/\) = max + (/\) = min instance JoinSemiLattice Double where - (\/) = min + (\/) = max instance MeetSemiLattice Double where - (/\) = max + (/\) = min instance JoinSemiLattice Int where - (\/) = min + (\/) = max instance MeetSemiLattice Int where - (/\) = max + (/\) = min instance JoinSemiLattice Integer where - (\/) = min + (\/) = max instance MeetSemiLattice Integer where - (/\) = max + (/\) = min instance JoinSemiLattice Bool where (\/) = (||) @@ -111,156 +123,142 @@ (/\) = (&&) instance JoinSemiLattice Natural where - (\/) = min + (\/) = max instance MeetSemiLattice Natural where - (/\) = max + (/\) = min instance JoinSemiLattice Int8 where - (\/) = min + (\/) = max instance MeetSemiLattice Int8 where - (/\) = max + (/\) = min instance JoinSemiLattice Int16 where - (\/) = min + (\/) = max instance MeetSemiLattice Int16 where - (/\) = max + (/\) = min instance JoinSemiLattice Int32 where - (\/) = min + (\/) = max instance MeetSemiLattice Int32 where - (/\) = max + (/\) = min instance JoinSemiLattice Int64 where - (\/) = min + (\/) = max instance MeetSemiLattice Int64 where - (/\) = max + (/\) = min instance JoinSemiLattice Word where - (\/) = min + (\/) = max instance MeetSemiLattice Word where - (/\) = max + (/\) = min instance JoinSemiLattice Word8 where - (\/) = min + (\/) = max instance MeetSemiLattice Word8 where - (/\) = max + (/\) = min instance JoinSemiLattice Word16 where - (\/) = min + (\/) = max instance MeetSemiLattice Word16 where - (/\) = max + (/\) = min instance JoinSemiLattice Word32 where - (\/) = min + (\/) = max instance MeetSemiLattice Word32 where - (/\) = max + (/\) = min instance JoinSemiLattice Word64 where - (\/) = min + (\/) = max instance MeetSemiLattice Word64 where - (/\) = max - -instance (Eq (a -> b), JoinSemiLattice b) => JoinSemiLattice (a -> b) where - f \/ f' = \a -> f a \/ f' a - -instance (Eq (a -> b), MeetSemiLattice b) => MeetSemiLattice (a -> b) where - f /\ f' = \a -> f a /\ f' a - --- from here + (/\) = min -instance BoundedJoinSemiLattice Float where +instance LowerBounded Float where bottom = negInfinity -instance BoundedMeetSemiLattice Float where +instance UpperBounded Float where top = infinity -instance BoundedJoinSemiLattice Double where +instance LowerBounded Double where bottom = negInfinity -instance BoundedMeetSemiLattice Double where +instance UpperBounded Double where top = infinity -instance BoundedJoinSemiLattice Int where +instance LowerBounded Int where bottom = minBound -instance BoundedMeetSemiLattice Int where +instance UpperBounded Int where top = maxBound -instance BoundedJoinSemiLattice Bool where +instance LowerBounded Bool where bottom = False -instance BoundedMeetSemiLattice Bool where +instance UpperBounded Bool where top = True -instance BoundedJoinSemiLattice Natural where +instance LowerBounded Natural where bottom = zero -instance BoundedJoinSemiLattice Int8 where +instance LowerBounded Int8 where bottom = minBound -instance BoundedMeetSemiLattice Int8 where +instance UpperBounded Int8 where top = maxBound -instance BoundedJoinSemiLattice Int16 where +instance LowerBounded Int16 where bottom = minBound -instance BoundedMeetSemiLattice Int16 where +instance UpperBounded Int16 where top = maxBound -instance BoundedJoinSemiLattice Int32 where +instance LowerBounded Int32 where bottom = minBound -instance BoundedMeetSemiLattice Int32 where +instance UpperBounded Int32 where top = maxBound -instance BoundedJoinSemiLattice Int64 where +instance LowerBounded Int64 where bottom = minBound -instance BoundedMeetSemiLattice Int64 where +instance UpperBounded Int64 where top = maxBound -instance BoundedJoinSemiLattice Word where +instance LowerBounded Word where bottom = minBound -instance BoundedMeetSemiLattice Word where +instance UpperBounded Word where top = maxBound -instance BoundedJoinSemiLattice Word8 where +instance LowerBounded Word8 where bottom = minBound -instance BoundedMeetSemiLattice Word8 where +instance UpperBounded Word8 where top = maxBound -instance BoundedJoinSemiLattice Word16 where +instance LowerBounded Word16 where bottom = minBound -instance BoundedMeetSemiLattice Word16 where +instance UpperBounded Word16 where top = maxBound -instance BoundedJoinSemiLattice Word32 where +instance LowerBounded Word32 where bottom = minBound -instance BoundedMeetSemiLattice Word32 where +instance UpperBounded Word32 where top = maxBound -instance BoundedJoinSemiLattice Word64 where +instance LowerBounded Word64 where bottom = minBound -instance BoundedMeetSemiLattice Word64 where +instance UpperBounded Word64 where top = maxBound - -instance (Eq (a -> b), BoundedJoinSemiLattice b) => BoundedJoinSemiLattice (a -> b) where - bottom = const bottom - -instance (Eq (a -> b), BoundedMeetSemiLattice b) => BoundedMeetSemiLattice (a -> b) where - top = const top diff --git a/src/NumHask/Algebra/Metric.hs b/src/NumHask/Algebra/Metric.hs new file mode 100644 --- /dev/null +++ b/src/NumHask/Algebra/Metric.hs @@ -0,0 +1,401 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Metric classes +module NumHask.Algebra.Metric + ( Basis (..), + Absolute, + Sign, + EndoBased, + abs, + signum, + distance, + Direction (..), + Polar (..), + polar, + coord, + Epsilon (..), + nearZero, + aboutEqual, + (~=), + EuclideanPair (..), + ) +where + +import Control.Applicative +import Data.Bool +import Data.Data +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind +import Data.Type.Equality +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Generics +import GHC.Natural (Natural (..)) +import NumHask.Algebra.Action +import NumHask.Algebra.Additive +import NumHask.Algebra.Field +import NumHask.Algebra.Lattice +import NumHask.Algebra.Multiplicative +import NumHask.Algebra.Ring +import Prelude (Double, Eq (..), Float, Functor (..), Int, Integer, Read, Show, Word, fromRational) +import Prelude qualified as P + +-- $setup +-- +-- >>> :m -Prelude +-- >>> :set -XRebindableSyntax +-- >>> import NumHask.Prelude + +-- | 'Basis' encapsulates the notion of magnitude (intuitively the quotienting of a higher-kinded number to a scalar one) and the basis on which the magnitude quotienting was performed. An instance needs to satisfy these laws: +-- +-- @since 0.11 +-- +-- > \a -> magnitude a >= zero +-- > \a -> magnitude zero == zero +-- > \a -> a == magnitude a *| basis a +-- > \a -> magnitude (basis a) == one +-- +-- The names chosen are meant to represent the spiritual idea of a basis rather than a specific mathematics. See https://en.wikipedia.org/wiki/Basis_(linear_algebra) & https://en.wikipedia.org/wiki/Norm_(mathematics) for some mathematical motivations. +-- +-- >>> magnitude (-0.5 :: Double) +-- 0.5 +-- +-- >>> basis (-0.5 :: Double) +-- -1.0 +class (Distributive (Mag a)) => Basis a where + type Mag a :: Type + type Base a :: Type + + -- | or length, or ||v|| + magnitude :: a -> Mag a + + -- | or direction, or v-hat + basis :: a -> Base a + +-- | Basis where the domain and magnitude codomain are the same. +-- +-- @since 0.11 +type Absolute a = (Basis a, Mag a ~ a) + +-- | Basis where the domain and basis codomain are the same. +-- +-- @since 0.11 +type Sign a = (Basis a, Base a ~ a) + +-- | Basis where the domain, magnitude codomain and basis codomain are the same. +-- +-- @since 0.11 +type EndoBased a = (Basis a, Mag a ~ a, Base a ~ a) + +-- | The absolute value of a number. +-- +-- prop> \a -> abs a * signum a ~= a +-- +-- +-- >>> abs (-1) +-- 1 +abs :: (Absolute a) => a -> a +abs = magnitude + +-- | The sign of a number. +-- +-- @since 0.11 +-- +-- >>> signum (-1) +-- -1 +-- +-- @abs zero == zero@, so any value for @signum zero@ is ok. We choose lawful neutral: +-- +-- >>> signum zero == zero +-- True +signum :: (Sign a) => a -> a +signum = basis + +instance Basis Double where + type Mag Double = Double + type Base Double = Double + magnitude = P.abs + basis = P.signum + +instance Basis Float where + type Mag Float = Float + type Base Float = Float + magnitude = P.abs + basis = P.signum + +instance Basis Int where + type Mag Int = Int + type Base Int = Int + magnitude = P.abs + basis = P.signum + +instance Basis Integer where + type Mag Integer = Integer + type Base Integer = Integer + magnitude = P.abs + basis = P.signum + +instance Basis Natural where + type Mag Natural = Natural + type Base Natural = Natural + magnitude = P.abs + basis = P.signum + +instance Basis Int8 where + type Mag Int8 = Int8 + type Base Int8 = Int8 + magnitude = P.abs + basis = P.signum + +instance Basis Int16 where + type Mag Int16 = Int16 + type Base Int16 = Int16 + magnitude = P.abs + basis = P.signum + +instance Basis Int32 where + type Mag Int32 = Int32 + type Base Int32 = Int32 + magnitude = P.abs + basis = P.signum + +instance Basis Int64 where + type Mag Int64 = Int64 + type Base Int64 = Int64 + magnitude = P.abs + basis = P.signum + +instance Basis Word where + type Mag Word = Word + type Base Word = Word + magnitude = P.abs + basis = P.signum + +instance Basis Word8 where + type Mag Word8 = Word8 + type Base Word8 = Word8 + magnitude = P.abs + basis = P.signum + +instance Basis Word16 where + type Mag Word16 = Word16 + type Base Word16 = Word16 + magnitude = P.abs + basis = P.signum + +instance Basis Word32 where + type Mag Word32 = Word32 + type Base Word32 = Word32 + magnitude = P.abs + basis = P.signum + +instance Basis Word64 where + type Mag Word64 = Word64 + type Base Word64 = Word64 + magnitude = P.abs + basis = P.signum + +-- | Distance, which combines the Subtractive notion of difference, with Basis. +-- +-- > distance a b >= zero +-- > distance a a == zero +-- > distance a b *| basis (a - b) == a - b +distance :: (Basis a, Subtractive a) => a -> a -> Mag a +distance a b = magnitude (a - b) + +-- | Convert between a "co-ordinated" or "higher-kinded" number and a direction. +-- +-- @since 0.7 +-- +-- > ray . angle == basis +-- > magnitude (ray x) == one +class (Distributive coord, Distributive (Dir coord)) => Direction coord where + type Dir coord :: Type + angle :: coord -> Dir coord + ray :: Dir coord -> coord + +-- | Something that has a magnitude and a direction, with both expressed as the same type. +-- +-- @since 0.7 +-- +-- See [Polar coordinate system](https://en.wikipedia.org/wiki/Polar_coordinate_system) +data Polar a = Polar {radial :: a, azimuth :: a} + deriving (Eq, Show, Read, Generic, Data) + +instance (Additive a, Multiplicative a) => Basis (Polar a) where + type Mag (Polar a) = a + type Base (Polar a) = a + magnitude = radial + basis = azimuth + +-- | Convert a higher-kinded number that has direction, to a 'Polar' +-- +-- @since 0.7 +polar :: (Dir (Base a) ~ Mag a, Basis a, Direction (Base a)) => a -> Polar (Mag a) +polar x = Polar (magnitude x) (angle (basis x)) + +-- | Convert a Polar to a (higher-kinded) number that has a direction. +-- +-- @since 0.07 +coord :: (Scalar m ~ Dir m, MultiplicativeAction m, Direction m) => Polar (Scalar m) -> m +coord x = radial x *| ray (azimuth x) + +-- | A small number, especially useful for approximate equality. +class + (Eq a, Additive a) => + Epsilon a + where + epsilon :: a + epsilon = zero + +-- | Note that the constraint is Lattice rather than Ord allowing broader usage. +-- +-- >>> nearZero (epsilon :: Double) +-- True +-- +-- >>> nearZero (epsilon :: EuclideanPair Double) +-- True +nearZero :: (Epsilon a, Lattice a, Subtractive a) => a -> Bool +nearZero a = a /\ epsilon == a && negate a /\ epsilon == negate a + +-- | Approximate equality +-- +-- >>> aboutEqual zero (epsilon :: Double) +-- True +aboutEqual :: (Epsilon a, Lattice a, Subtractive a) => a -> a -> Bool +aboutEqual a b = nearZero (a - b) + +infixl 4 ~= + +-- | About equal operator. +-- +-- >>> (1.0 + epsilon) ~= (1.0 :: Double) +-- True +(~=) :: (Epsilon a) => (Lattice a, Subtractive a) => a -> a -> Bool +(~=) = aboutEqual + +-- | 1e-14 +instance Epsilon Double where + epsilon = 1e-14 + +-- | 1e-6 +instance Epsilon Float where + epsilon = 1e-6 + +-- | 0 +instance Epsilon Int + +instance Epsilon Integer + +instance Epsilon Int8 + +instance Epsilon Int16 + +instance Epsilon Int32 + +instance Epsilon Int64 + +instance Epsilon Word + +instance Epsilon Word8 + +instance Epsilon Word16 + +instance Epsilon Word32 + +instance Epsilon Word64 + +-- | Two dimensional cartesian coordinates. +-- +-- @since 0.11 +newtype EuclideanPair a = EuclideanPair {euclidPair :: (a, a)} + deriving stock + (Eq, Show, Generic, Data) + +instance Functor EuclideanPair where + fmap f (EuclideanPair (x, y)) = EuclideanPair (f x, f y) + +instance Applicative EuclideanPair where + pure x = EuclideanPair (x, x) + EuclideanPair (fx, fy) <*> EuclideanPair (x, y) = EuclideanPair (fx x, fy y) + liftA2 f (EuclideanPair (x, y)) (EuclideanPair (x', y')) = EuclideanPair (f x x', f y y') + +instance (Additive a) => Additive (EuclideanPair a) where + (+) = liftA2 (+) + zero = pure zero + +instance (Subtractive a) => Subtractive (EuclideanPair a) where + (-) = liftA2 (-) + negate = fmap negate + +instance + (Multiplicative a) => + Multiplicative (EuclideanPair a) + where + (*) = liftA2 (*) + one = pure one + +instance + (Divisive a) => + Divisive (EuclideanPair a) + where + recip = fmap recip + +instance (TrigField a) => Direction (EuclideanPair a) where + type Dir (EuclideanPair a) = a + angle (EuclideanPair (x, y)) = atan2 y x + ray x = EuclideanPair (cos x, sin x) + +instance + (ExpField a, Eq a) => + Basis (EuclideanPair a) + where + type Mag (EuclideanPair a) = a + type Base (EuclideanPair a) = EuclideanPair a + + magnitude (EuclideanPair (x, y)) = sqrt (x * x + y * y) + basis p = let m = magnitude p in bool (p |/ m) zero (m == zero) + +instance + (Epsilon a) => + Epsilon (EuclideanPair a) + where + epsilon = pure epsilon + +instance (JoinSemiLattice a) => JoinSemiLattice (EuclideanPair a) where + (\/) (EuclideanPair (x, y)) (EuclideanPair (x', y')) = EuclideanPair (x \/ x', y \/ y') + +instance (MeetSemiLattice a) => MeetSemiLattice (EuclideanPair a) where + (/\) (EuclideanPair (x, y)) (EuclideanPair (x', y')) = EuclideanPair (x /\ x', y /\ y') + +instance (LowerBounded a) => LowerBounded (EuclideanPair a) where + bottom = pure bottom + +instance (UpperBounded a) => UpperBounded (EuclideanPair a) where + top = pure top + +instance (Multiplicative a) => MultiplicativeAction (EuclideanPair a) where + type Scalar (EuclideanPair a) = a + (|*) (EuclideanPair (x, y)) s = EuclideanPair (s * x, s * y) + +instance (Divisive a) => DivisiveAction (EuclideanPair a) where + (|/) e s = fmap (/ s) e + +instance (TrigField a, ExpField a) => ExpField (EuclideanPair a) where + exp (EuclideanPair (x, y)) = EuclideanPair (exp x * cos y, exp x * sin y) + log (EuclideanPair (x, y)) = EuclideanPair (log (sqrt (x * x + y * y)), atan2 y x) + +instance (QuotientField a) => QuotientField (EuclideanPair a) where + type Whole (EuclideanPair a) = EuclideanPair (Whole a) + + properFraction (EuclideanPair (x, y)) = + (EuclideanPair (xwhole, ywhole), EuclideanPair (xfrac, yfrac)) + where + (xwhole, xfrac) = properFraction x + (ywhole, yfrac) = properFraction y + + round (EuclideanPair (x, y)) = EuclideanPair (round x, round y) + ceiling (EuclideanPair (x, y)) = EuclideanPair (ceiling x, ceiling y) + floor (EuclideanPair (x, y)) = EuclideanPair (floor x, floor y) + truncate (EuclideanPair (x, y)) = EuclideanPair (truncate x, truncate y) diff --git a/src/NumHask/Algebra/Module.hs b/src/NumHask/Algebra/Module.hs deleted file mode 100644 --- a/src/NumHask/Algebra/Module.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE RebindableSyntax #-} -{-# OPTIONS_GHC -Wall #-} - --- | Algebra for Modules -module NumHask.Algebra.Module - ( AdditiveAction (..), - SubtractiveAction (..), - MultiplicativeAction (..), - DivisiveAction (..), - Module, - ) -where - -import NumHask.Algebra.Additive -import NumHask.Algebra.Multiplicative -import NumHask.Algebra.Ring - --- $setup --- --- >>> :set -XRebindableSyntax --- >>> :set -XNegativeLiterals --- >>> :set -XFlexibleContexts --- >>> :set -XFlexibleInstances --- >>> :set -XScopedTypeVariables --- >>> :set -XMultiParamTypeClasses --- >>> import NumHask.Prelude --- >>> import Test.QuickCheck --- >>> import Prelude (Int, fmap) - --- | Additive Action -class - (Additive a) => - AdditiveAction m a - | m -> a - where - infixl 6 .+ - (.+) :: a -> m -> m - - infixl 6 +. - (+.) :: m -> a -> m - --- | Subtractive Action -class - (Subtractive a) => - SubtractiveAction m a - | m -> a - where - infixl 6 .- - (.-) :: a -> m -> m - - infixl 6 -. - (-.) :: m -> a -> m - --- | Multiplicative Action -class - (Multiplicative a) => - MultiplicativeAction m a - | m -> a - where - infixl 7 .* - (.*) :: a -> m -> m - infixl 7 *. - (*.) :: m -> a -> m - --- | Divisive Action -class - (Divisive a) => - DivisiveAction m a - | m -> a - where - infixl 7 ./ - (./) :: a -> m -> m - infixl 7 /. - (/.) :: m -> a -> m - --- | A --- --- > a .* one == a --- > (a + b) .* c == (a .* c) + (b .* c) --- > c *. (a + b) == (c *. a) + (c *. b) --- > a .* zero == zero --- > a .* b == b *. a -class (Distributive a, MultiplicativeAction m a) => Module m a diff --git a/src/NumHask/Algebra/Multiplicative.hs b/src/NumHask/Algebra/Multiplicative.hs --- a/src/NumHask/Algebra/Multiplicative.hs +++ b/src/NumHask/Algebra/Multiplicative.hs @@ -1,27 +1,25 @@ -{-# OPTIONS_GHC -Wall #-} - -- | Multiplicative classes module NumHask.Algebra.Multiplicative ( Multiplicative (..), + Product (..), product, + accproduct, Divisive (..), ) where import Data.Int (Int16, Int32, Int64, Int8) +import Data.Traversable (mapAccumL) import Data.Word (Word, Word16, Word32, Word64, Word8) import GHC.Natural (Natural (..)) -import Prelude (Double, Float, Int, Integer) -import qualified Prelude as P +import Prelude (Double, Eq, Float, Int, Integer, Ord, Show, fromInteger, fromRational) +import Prelude qualified as P -- $setup -- +-- >>> :m -Prelude -- >>> :set -XRebindableSyntax --- >>> :set -XNegativeLiterals --- >>> :set -XFlexibleContexts --- >>> :set -XScopedTypeVariables -- >>> import NumHask.Prelude --- >>> import Test.QuickCheck -- | or [Multiplication](https://en.wikipedia.org/wiki/Multiplication) -- @@ -45,10 +43,34 @@ one :: a +-- | A wrapper for an Multiplicative which distinguishes the multiplicative structure +-- +-- @since 0.11.1 +newtype Product a = Product + { getProduct :: a + } + deriving (Eq, Ord, Show) + +instance (Multiplicative a) => P.Semigroup (Product a) where + Product a <> Product b = Product (a * b) + +instance (Multiplicative a) => P.Monoid (Product a) where + mempty = Product one + -- | Compute the product of a 'Data.Foldable.Foldable'. +-- +-- >>> product [1..5] +-- 120 product :: (Multiplicative a, P.Foldable f) => f a -> a -product = P.foldr (*) one +product = getProduct P.. P.foldMap Product +-- | Compute the accumulating product of a 'Data.Traversable.Traversable'. +-- +-- >>> accproduct [1..5] +-- [1,2,6,24,120] +accproduct :: (Multiplicative a, P.Traversable f) => f a -> f a +accproduct = P.snd P.. mapAccumL (\a b -> (a * b, a * b)) one + -- | or [Division](https://en.wikipedia.org/wiki/Division_(mathematics\)) -- -- Though unusual, the term Divisive usefully fits in with the grammer of other classes and avoids name clashes that occur with some popular libraries. @@ -64,9 +86,13 @@ -- >>> 1 / 2 -- 0.5 class (Multiplicative a) => Divisive a where + {-# MINIMAL (/) | recip #-} + recip :: a -> a + recip a = one / a infixl 7 / + (/) :: a -> a -> a (/) a b = a * recip b @@ -136,9 +162,9 @@ (*) = (P.*) one = 1 -instance Multiplicative b => Multiplicative (a -> b) where +instance (Multiplicative b) => Multiplicative (a -> b) where f * f' = \a -> f a * f' a one _ = one -instance Divisive b => Divisive (a -> b) where +instance (Divisive b) => Divisive (a -> b) where recip f = recip P.. f diff --git a/src/NumHask/Algebra/Patterns.hs b/src/NumHask/Algebra/Patterns.hs new file mode 100644 --- /dev/null +++ b/src/NumHask/Algebra/Patterns.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Patterns for common tests +module NumHask.Algebra.Patterns + ( pattern Zero, + pattern One, + pattern MinusOne, + ) +where + +import NumHask.Algebra.Additive +import NumHask.Algebra.Multiplicative +import Prelude (Bool (..), Eq (..), (.)) + +-- | Enabling pattern matching on zero: +-- +-- > isItZero Zero = True +-- > isItZero _ = False +pattern Zero :: forall a. (Eq a, Additive a) => a +pattern Zero <- ((== zero) -> True) + +-- | Enabling pattern matching on one: +-- +-- > isItOne One = True +-- > isItOne _ = False +pattern One :: forall a. (Eq a, Multiplicative a) => a +pattern One <- ((== one) -> True) + +-- | Enabling pattern matching on minus one: +-- +-- > isItMinusOne MinusOne = True +-- > isItMinusOne _ = False +-- +-- The means of testing (that is, add one, and check if it equals +-- zero) might be surprising. Other, more obvious, methods would +-- result in underflow errors. (For example, we could negate and test +-- if it's equal to one, but that would fail on any nonzero +-- 'Natural'. Similarly, we could test for equality with the negation of +-- one, but that would fail on any 'Natural' whatsoever, since 'negate +-- one' underflows.) +pattern MinusOne :: forall a. (Eq a, Additive a, Multiplicative a) => a +pattern MinusOne <- ((== zero) . (+ one) -> True) diff --git a/src/NumHask/Algebra/Ring.hs b/src/NumHask/Algebra/Ring.hs --- a/src/NumHask/Algebra/Ring.hs +++ b/src/NumHask/Algebra/Ring.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall #-} - -- | Ring classes module NumHask.Algebra.Ring ( Distributive, @@ -16,19 +12,16 @@ import Data.Int (Int16, Int32, Int64, Int8) import Data.Word (Word, Word16, Word32, Word64, Word8) import GHC.Natural (Natural (..)) -import NumHask.Algebra.Additive -import NumHask.Algebra.Group -import NumHask.Algebra.Multiplicative -import qualified Prelude as P +import NumHask.Algebra.Additive (Additive ((+)), Subtractive) +import NumHask.Algebra.Group (Idempotent) +import NumHask.Algebra.Multiplicative (Multiplicative (..)) +import Prelude qualified as P -- $setup -- +-- >>> :m -Prelude -- >>> :set -XRebindableSyntax --- >>> :set -XNegativeLiterals --- >>> :set -XFlexibleContexts --- >>> :set -XScopedTypeVariables -- >>> import NumHask.Prelude --- >>> import Test.QuickCheck -- | -- @@ -38,87 +31,66 @@ -- prop> \a -> a * zero == zero -- -- The sneaking in of the laws here glosses over the possibility that the multiplicative zero element does not have to correspond with the additive unital zero. -class - (Additive a, Multiplicative a) => - Distributive a - -instance Distributive P.Double - -instance Distributive P.Float - -instance Distributive P.Int - -instance Distributive P.Integer - -instance Distributive Natural - -instance Distributive Int8 - -instance Distributive Int16 - -instance Distributive Int32 - -instance Distributive Int64 - -instance Distributive Word - -instance Distributive Word8 - -instance Distributive Word16 - -instance Distributive Word32 - -instance Distributive Word64 - -instance Distributive P.Bool - -instance Distributive b => Distributive (a -> b) +type Distributive a = (Additive a, Multiplicative a) --- | A is an abelian group under addition ('Unital', 'Associative', 'Commutative', 'Invertible') and monoidal under multiplication ('Unital', 'Associative'), and where multiplication distributes over addition. +-- | A is an abelian group under addition ('NumHask.Algebra.Unital', 'NumHask.Algebra.Associative', 'NumHask.Algebra.Commutative', 'NumHask.Algebra.Invertible') and monoidal under multiplication ('NumHask.Algebra.Unital', 'NumHask.Algebra.Associative'), and where multiplication distributes over addition. -- --- prop> \a -> zero + a == a --- prop> \a -> a + zero == a --- prop> \a b c -> (a + b) + c == a + (b + c) --- prop> \a b -> a + b == b + a --- prop> \a -> a - a == zero --- prop> \a -> negate a == zero - a --- prop> \a -> negate a + a == zero --- prop> \a -> a + negate a == zero --- prop> \a -> one * a == a --- prop> \a -> a * one == a --- prop> \a b c -> (a * b) * c == a * (b * c) --- prop> \a b c -> a * (b + c) == a * b + a * c --- prop> \a b c -> (a + b) * c == a * c + b * c --- prop> \a -> zero * a == zero --- prop> \a -> a * zero == zero -class - (Distributive a, Subtractive a) => - Ring a - -instance - (Distributive a, Subtractive a) => - Ring a +-- > \a -> zero + a == a +-- > \a -> a + zero == a +-- > \a b c -> (a + b) + c == a + (b + c) +-- > \a b -> a + b == b + a +-- > \a -> a - a == zero +-- > \a -> negate a == zero - a +-- > \a -> negate a + a == zero +-- > \a -> a + negate a == zero +-- > \a -> one * a == a +-- > \a -> a * one == a +-- > \a b c -> (a * b) * c == a * (b * c) +-- > \a b c -> a * (b + c) == a * b + a * c +-- > \a b c -> (a + b) * c == a * c + b * c +-- > \a -> zero * a == zero +-- > \a -> a * zero == zero +type Ring a = (Distributive a, Subtractive a) --- | A is a semiring with an additional unary operator (star) satisfying: +-- | A is a semiring with a unary star operator satisfying the Conway equations: -- --- > \a -> star a = one + a * star a +-- > \a -> star a == one + a * star a -- fixpoint +-- > \a b -> star (a * b) == one + a * star (b * a) * b -- product-star (sliding) +-- > \a b -> star (a + b) == star (star a * b) * star a -- sum-star (vanishing) +-- +-- These three equations are the doctestable core; they are exactly the sliding and vanishing axioms of a traced category in semiring clothing. class (Distributive a) => StarSemiring a where + {-# MINIMAL star | plus #-} + star :: a -> a star a = one + plus a plus :: a -> a plus a = a * star a -instance StarSemiring b => StarSemiring (a -> b) - -- | A is a Star Semiring with idempotent addition. -- --- > a * x + x = a ==> star a * x + x = x --- > x * a + x = a ==> x * star a + x = x +-- Idempotent addition gives a natural order @a <= b ⟺ a + b == b@. In that order, Kozen's induction laws hold as derived facts: +-- +-- > a * x + x <= x ==> star a * x + x <= x +-- > x * a + x <= x ==> x * star a + x <= x +-- +-- They are stated here as prose rather than class laws because they involve a partial order and Horn clauses, which do not fit the equational/doctest style of the Conway core. class (StarSemiring a, Idempotent a) => KleeneAlgebra a -instance KleeneAlgebra b => KleeneAlgebra (a -> b) +instance StarSemiring P.Bool where + star _ = P.True +instance KleeneAlgebra P.Bool + +-- | Conway equations for 'Bool'. +-- +-- >>> let a = False; b = True in star (a * b) == one + a * star (b * a) * b +-- True +-- +-- >>> let a = False; b = True in star (a + b) == star (star a * b) * star a +-- True + -- | Involutive Ring -- -- > adj (a + b) ==> adj a + adj b @@ -158,8 +130,6 @@ instance InvolutiveRing Word32 instance InvolutiveRing Word64 - -instance InvolutiveRing b => InvolutiveRing (a -> b) -- | Defining 'two' requires adding the multiplicative unital to itself. In other words, the concept of 'two' is a Ring one. -- diff --git a/src/NumHask/Algebra/Tropical.hs b/src/NumHask/Algebra/Tropical.hs new file mode 100644 --- /dev/null +++ b/src/NumHask/Algebra/Tropical.hs @@ -0,0 +1,65 @@ +-- | Tropical semirings. +module NumHask.Algebra.Tropical + ( MinPlus (..), + ) +where + +import NumHask.Algebra.Additive (Additive (..)) +import NumHask.Algebra.Group (Idempotent, Magma (..)) +import NumHask.Algebra.Multiplicative (Multiplicative (..)) +import NumHask.Algebra.Ring (KleeneAlgebra, StarSemiring (..)) +import Prelude (Double, Eq, Ord, Show, fromInteger) +import Prelude qualified as P + +-- $setup +-- +-- >>> :m -Prelude +-- >>> :set -XRebindableSyntax +-- >>> import NumHask.Prelude +-- >>> import NumHask.Algebra.Tropical + +-- | The min-plus tropical semiring. +-- +-- Addition is 'min', multiplication is ordinary addition, the additive unit +-- is positive infinity, and the multiplicative unit is zero. +-- +-- >>> MinPlus 3 + MinPlus 2 :: MinPlus Double +-- MinPlus {getMinPlus = 2.0} +-- +-- >>> MinPlus 3 * MinPlus 2 :: MinPlus Double +-- MinPlus {getMinPlus = 5.0} +newtype MinPlus a = MinPlus + { getMinPlus :: a + } + deriving (Eq, Ord, Show) + +instance Additive (MinPlus Double) where + MinPlus a + MinPlus b = MinPlus (P.min a b) + zero = MinPlus (1 P./ 0) + +instance Multiplicative (MinPlus Double) where + MinPlus a * MinPlus b = MinPlus (a P.+ b) + one = MinPlus 0 + +instance Magma (MinPlus Double) where + a ⊕ b = a + b + +instance Idempotent (MinPlus Double) + +-- | Star is zero in a min-plus semiring: the cheapest repeated traversal is +-- to stay put. +-- +-- >>> star (MinPlus 2 :: MinPlus Double) +-- MinPlus {getMinPlus = 0.0} +-- +-- Conway equations for 'MinPlus Double'. +-- +-- >>> let a = MinPlus 2 :: MinPlus Double; b = MinPlus 3 :: MinPlus Double in star (a * b) == one + a * star (b * a) * b +-- True +-- +-- >>> let a = MinPlus 2 :: MinPlus Double; b = MinPlus 3 :: MinPlus Double in star (a + b) == star (star a * b) * star a +-- True +instance StarSemiring (MinPlus Double) where + star _ = one + +instance KleeneAlgebra (MinPlus Double) diff --git a/src/NumHask/Analysis/Metric.hs b/src/NumHask/Analysis/Metric.hs deleted file mode 100644 --- a/src/NumHask/Analysis/Metric.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# OPTIONS_GHC -Wall #-} - --- | Metric classes -module NumHask.Analysis.Metric - ( Signed (..), - Norm (..), - distance, - Direction (..), - Polar (..), - polar, - coord, - Epsilon (..), - (~=), - ) -where - -import Data.Bool (bool) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Generics (Generic) -import GHC.Natural (Natural (..)) -import NumHask.Algebra.Additive -import NumHask.Algebra.Lattice -import NumHask.Algebra.Module -import NumHask.Algebra.Multiplicative -import Prelude hiding - ( Bounded (..), - Integral (..), - negate, - (*), - (-), - ) -import qualified Prelude as P - --- | 'signum' from base is not an operator name in numhask and is replaced by 'sign'. Compare with 'Norm' where there is a change in codomain --- --- > abs a * sign a == a -class - (Additive a, Multiplicative a) => - Signed a - where - sign :: a -> a - abs :: a -> a - -instance Signed Double where - sign a = - case compare a zero of - EQ -> zero - GT -> one - LT -> negate one - abs = P.abs - -instance Signed Float where - sign a = - case compare a zero of - EQ -> zero - GT -> one - LT -> negate one - abs = P.abs - -instance Signed Int where - sign a = - case compare a zero of - EQ -> zero - GT -> one - LT -> negate one - abs = P.abs - -instance Signed Integer where - sign a = - case compare a zero of - EQ -> zero - GT -> one - LT -> negate one - abs = P.abs - -instance Signed Natural where - sign a = - case compare a zero of - EQ -> zero - GT -> one - LT -> negate one - abs = id - -instance Signed Int8 where - sign a = - case compare a zero of - EQ -> zero - GT -> one - LT -> negate one - abs = P.abs - -instance Signed Int16 where - sign a = - case compare a zero of - EQ -> zero - GT -> one - LT -> negate one - abs = P.abs - -instance Signed Int32 where - sign a = - case compare a zero of - EQ -> zero - GT -> one - LT -> negate one - abs = P.abs - -instance Signed Int64 where - sign a = - case compare a zero of - EQ -> zero - GT -> one - LT -> negate one - abs = P.abs - -instance Signed Word where - sign a = bool one zero (a == zero) - abs = P.abs - -instance Signed Word8 where - sign a = bool one zero (a == zero) - abs = P.abs - -instance Signed Word16 where - sign a = bool one zero (a == zero) - abs = P.abs - -instance Signed Word32 where - sign a = bool one zero (a == zero) - abs = P.abs - -instance Signed Word64 where - sign a = bool one zero (a == zero) - abs = P.abs - --- | Norm is a slight generalisation of Signed. The class has the same shape but allows the codomain to be different to the domain. --- --- > norm a >= zero --- > norm zero == zero --- > a == norm a .* basis a --- > norm (basis a) == one -class (Additive a, Multiplicative b, Additive b) => Norm a b | a -> b where - norm :: a -> b - basis :: a -> a - -instance Norm Double Double where - norm = P.abs - basis = P.signum - -instance Norm Float Float where - norm = P.abs - basis = P.signum - -instance Norm Int Int where - norm = P.abs - basis = P.signum - -instance Norm Integer Integer where - norm = P.abs - basis = P.signum - -instance Norm Natural Natural where - norm = P.abs - basis = P.signum - -instance Norm Int8 Int8 where - norm = P.abs - basis = P.signum - -instance Norm Int16 Int16 where - norm = P.abs - basis = P.signum - -instance Norm Int32 Int32 where - norm = P.abs - basis = P.signum - -instance Norm Int64 Int64 where - norm = P.abs - basis = P.signum - -instance Norm Word Word where - norm = P.abs - basis = P.signum - -instance Norm Word8 Word8 where - norm = P.abs - basis = P.signum - -instance Norm Word16 Word16 where - norm = P.abs - basis = P.signum - -instance Norm Word32 Word32 where - norm = P.abs - basis = P.signum - -instance Norm Word64 Word64 where - norm = P.abs - basis = P.signum - --- | Distance, which combines the Subtractive notion of difference, with Norm. --- --- > distance a b >= zero --- > distance a a == zero --- > distance a b .* basis (a - b) == a - b -distance :: (Norm a b, Subtractive a) => a -> a -> b -distance a b = norm (a - b) - --- | Convert between a "co-ordinated" or "higher-kinded" number and representations of an angle. Typically thought of as polar co-ordinate conversion. --- --- See [Polar coordinate system](https://en.wikipedia.org/wiki/Polar_coordinate_system) --- --- > ray . angle == basis --- > norm (ray x) == 1 -class (Additive coord, Multiplicative coord, Additive dir, Multiplicative dir) => Direction coord dir | coord -> dir where - angle :: coord -> dir - ray :: dir -> coord - --- | Something that has a magnitude and a direction. -data Polar mag dir = Polar {magnitude :: !mag, direction :: !dir} - deriving (Eq, Show, Generic) - --- | Convert from a number to a Polar. -polar :: (Norm coord mag, Direction coord dir) => coord -> Polar mag dir -polar z = Polar (norm z) (angle z) - --- | Convert from a Polar to a (coordinated aka higher-kinded) number. -coord :: (MultiplicativeAction coord mag, Direction coord dir) => Polar mag dir -> coord -coord (Polar m d) = m .* ray d - --- | A small number, especially useful for approximate equality. -class - (Eq a, Additive a, Subtractive a, MeetSemiLattice a) => - Epsilon a - where - epsilon :: a - epsilon = zero - - nearZero :: a -> Bool - nearZero a = epsilon `meetLeq` a && epsilon `meetLeq` negate a - - aboutEqual :: a -> a -> Bool - aboutEqual a b = nearZero $ a - b - -infixl 4 ~= - --- | About equal. -(~=) :: (Epsilon a) => a -> a -> Bool -(~=) = aboutEqual - --- | 1e-14 -instance Epsilon Double where - epsilon = 1e-14 - --- | 1e-6 -instance Epsilon Float where - epsilon = 1e-6 - --- | 0 -instance Epsilon Int - -instance Epsilon Integer - -instance Epsilon Int8 - -instance Epsilon Int16 - -instance Epsilon Int32 - -instance Epsilon Int64 - -instance Epsilon Word - -instance Epsilon Word8 - -instance Epsilon Word16 - -instance Epsilon Word32 - -instance Epsilon Word64 diff --git a/src/NumHask/Data/Complex.hs b/src/NumHask/Data/Complex.hs --- a/src/NumHask/Data/Complex.hs +++ b/src/NumHask/Data/Complex.hs @@ -1,159 +1,139 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RebindableSyntax #-} -{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | Complex numbers. module NumHask.Data.Complex ( Complex (..), + (+:), realPart, imagPart, + normSquared, ) where import Data.Data (Data) -import GHC.Generics (Generic, Generic1) +import GHC.Generics import NumHask.Algebra.Additive import NumHask.Algebra.Field import NumHask.Algebra.Lattice +import NumHask.Algebra.Metric import NumHask.Algebra.Multiplicative import NumHask.Algebra.Ring -import NumHask.Analysis.Metric import NumHask.Data.Integral import Prelude hiding ( Num (..), atan, atan2, + ceiling, cos, exp, + floor, fromIntegral, log, negate, pi, + properFraction, recip, + round, sin, sqrt, + truncate, (/), ) -import qualified Prelude as P (Ord (..), otherwise, (&&), (<), (<=), (==), (>)) --- ----------------------------------------------------------------------------- --- The Complex type -infix 6 :+ - --- | Complex numbers have real and imaginary parts. +-- $setup -- --- The 'Data.Foldable.Foldable' and 'Data.Traversable.Traversable' instances traverse the real part first. -data Complex a - = -- | forms a complex number from its real and imaginary - -- rectangular components. - !a :+ !a - deriving +-- >>> import NumHask.Prelude +-- >>> :m -Prelude + +-- | The underlying representation is a newtype-wrapped tuple, compared with the base datatype. This was chosen to facilitate the use of DerivingVia. +newtype Complex a = Complex {complexPair :: (a, a)} + deriving stock ( Eq, Show, Read, - Data, Generic, - Generic1, - Functor, - Foldable, - Traversable + Data, + Functor ) + deriving + ( Additive, + Subtractive, + Basis, + Direction, + Epsilon, + JoinSemiLattice, + MeetSemiLattice, + LowerBounded, + UpperBounded, + ExpField + ) + via (EuclideanPair a) +infixl 6 +: + +-- | Complex number constructor. +-- +-- Internally, Complex derives most instances via EuclideanPair. For instance, +-- +-- >>> sqrt (1.0 +: (-1.0)) :: Complex Double +-- Complex {complexPair = (1.0986841134678098,-0.45508986056222733)} +-- +-- >>> sqrt ((-1.0) +: 0.0) :: Complex Double +-- Complex {complexPair = (6.123233995736766e-17,1.0)} +(+:) :: a -> a -> Complex a +(+:) r i = Complex (r, i) + -- | Extracts the real part of a complex number. realPart :: Complex a -> a -realPart (x :+ _) = x +realPart (Complex (x, _)) = x -- | Extracts the imaginary part of a complex number. imagPart :: Complex a -> a -imagPart (_ :+ y) = y - -instance (Additive a) => Additive (Complex a) where - (rx :+ ix) + (ry :+ iy) = (rx + ry) :+ (ix + iy) - zero = zero :+ zero - -instance (Subtractive a) => Subtractive (Complex a) where - negate (rx :+ ix) = negate rx :+ negate ix - -instance - (Distributive a, Subtractive a) => - Distributive (Complex a) +imagPart (Complex (_, y)) = y instance (Subtractive a, Multiplicative a) => Multiplicative (Complex a) where - (rx :+ ix) * (ry :+ iy) = - (rx * ry - ix * iy) :+ (ix * ry + iy * rx) - one = one :+ zero + (Complex (r, i)) * (Complex (r', i')) = + Complex (r * r' - i * i', i * r' + i' * r) + one = one +: zero instance (Subtractive a, Divisive a) => Divisive (Complex a) where - recip (rx :+ ix) = (rx * d) :+ (negate ix * d) + recip (Complex (r, i)) = (r * d) +: (negate i * d) where - d = recip ((rx * rx) + (ix * ix)) + d = recip ((r * r) + (i * i)) instance (Additive a, FromIntegral a b) => FromIntegral (Complex a) b where - fromIntegral x = fromIntegral x :+ zero - --- | A euclidean-style norm is strong convention for Complex. -instance - (ExpField a) => - Norm (Complex a) a - where - norm (rx :+ ix) = sqrt (rx * rx + ix * ix) - basis x@(rx :+ ix) = rx / norm x :+ ix / norm x - -instance (TrigField a) => Direction (Complex a) a where - angle (x :+ y) = atan2 y x - ray x = cos x :+ sin x - -instance - (Ord a, Signed a, Subtractive a, Epsilon a) => - Epsilon (Complex a) - where - epsilon = epsilon :+ epsilon - nearZero (a :+ b) = nearZero a && nearZero b - -instance (Field a) => Field (Complex a) - -instance (Ord a, TrigField a, ExpField a) => ExpField (Complex a) where - exp (rx :+ ix) = (exp rx * cos ix) :+ (exp rx * sin ix) - log (rx :+ ix) = log (sqrt (rx * rx + ix * ix)) :+ atan2' ix rx - where - atan2' y x - | x P.> zero = atan (y / x) - | x P.== zero P.&& y P.> zero = pi / (one + one) - | x P.< one P.&& y P.> one = pi + atan (y / x) - | (x P.<= zero P.&& y P.< zero) || (x P.< zero) = - negate (atan2' (negate y) x) - | y P.== zero = pi -- must be after the previous test on zero y - | x P.== zero P.&& y P.== zero = y -- must be after the other double zero tests - | P.otherwise = x + y -- x or y is a NaN, return a NaN (via +) + fromIntegral x = fromIntegral x +: zero instance (Distributive a, Subtractive a) => InvolutiveRing (Complex a) where - adj (a :+ b) = a :+ negate b - -instance (UpperBoundedField a, Subtractive a) => UpperBoundedField (Complex a) - -instance (LowerBoundedField a) => LowerBoundedField (Complex a) + adj (Complex (r, i)) = r +: negate i -instance (JoinSemiLattice a) => JoinSemiLattice (Complex a) where - (\/) (ar :+ ai) (br :+ bi) = (ar \/ br) :+ (ai \/ bi) +-- Can't use DerivingVia due to extra Whole constraints +instance (Subtractive a, QuotientField a) => QuotientField (Complex a) where + type Whole (Complex a) = Complex (Whole a) -instance (MeetSemiLattice a) => MeetSemiLattice (Complex a) where - (/\) (ar :+ ai) (br :+ bi) = (ar /\ br) :+ (ai /\ bi) + properFraction (Complex (x, y)) = + (Complex (xwhole, ywhole), Complex (xfrac, yfrac)) + where + (xwhole, xfrac) = properFraction x + (ywhole, yfrac) = properFraction y -instance (BoundedJoinSemiLattice a) => BoundedJoinSemiLattice (Complex a) where - bottom = bottom :+ bottom + round (Complex (x, y)) = Complex (round x, round y) + ceiling (Complex (x, y)) = Complex (ceiling x, ceiling y) + floor (Complex (x, y)) = Complex (floor x, floor y) + truncate (Complex (x, y)) = Complex (truncate x, truncate y) -instance (BoundedMeetSemiLattice a) => BoundedMeetSemiLattice (Complex a) where - top = top :+ top +-- | The squared norm: frequently useful, and doesn't require the +-- ability to take square roots. +normSquared :: (Distributive a) => Complex a -> a +normSquared (Complex (x, y)) = x * x + y * y diff --git a/src/NumHask/Data/Integral.hs b/src/NumHask/Data/Integral.hs --- a/src/NumHask/Data/Integral.hs +++ b/src/NumHask/Data/Integral.hs @@ -1,39 +1,47 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wall #-} - -- | Integral classes module NumHask.Data.Integral ( Integral (..), ToIntegral (..), + ToInt, FromIntegral (..), + FromInt, FromInteger (..), even, odd, (^^), (^), + (^+), ) where import Data.Int (Int16, Int32, Int64, Int8) import Data.Ord import Data.Word (Word, Word16, Word32, Word64, Word8) -import GHC.Natural (Natural (..)) -import GHC.Num (naturalFromInteger) +import GHC.Natural (Natural (..), naturalFromInteger) import NumHask.Algebra.Additive import NumHask.Algebra.Multiplicative import NumHask.Algebra.Ring import Prelude (Double, Float, Int, Integer, fst, snd, (.)) -import qualified Prelude as P +import Prelude qualified as P +-- $setup +-- +-- >>> :m -Prelude +-- >>> :set -XRebindableSyntax +-- >>> import NumHask.Prelude + -- | An Integral is anything that satisfies the law: -- --- > b == zero || b * (a `div` b) + (a `mod` b) == a +-- prop> \a b -> b == zero || b * (a `div` b) + (a `mod` b) == a +-- +-- >>> 3 `divMod` 2 +-- (1,1) +-- +-- >>> (-3) `divMod` 2 +-- (-2,1) +-- +-- >>> (-3) `quotRem` 2 +-- (-1,-1) class (Distributive a) => Integral a @@ -101,7 +109,7 @@ divMod = P.divMod quotRem = P.quotRem -instance Integral b => Integral (a -> b) where +instance (Integral b) => Integral (a -> b) where div f f' a = f a `div` f' a mod f f' a = f a `mod` f' a divMod f f' = (\a -> fst (f a `divMod` f' a), \a -> snd (f a `divMod` f' a)) @@ -109,6 +117,18 @@ rem f f' a = f a `mod` f' a quotRem f f' = (\a -> fst (f a `quotRem` f' a), \a -> snd (f a `quotRem` f' a)) +-- | +-- >>> even 2 +-- True +even :: (P.Eq a, Integral a) => a -> P.Bool +even n = n `rem` (one + one) P.== zero + +-- | +-- >>> odd 3 +-- True +odd :: (P.Eq a, Integral a) => a -> P.Bool +odd = P.not . even + -- | toIntegral is kept separate from Integral to help with compatability issues. -- -- > toIntegral a == a @@ -116,9 +136,10 @@ {-# MINIMAL toIntegral #-} toIntegral :: a -> b - default toIntegral :: (a ~ b) => a -> b - toIntegral = P.id +-- | Convert to an 'Int' +type ToInt a = ToIntegral a Int + instance ToIntegral Integer Integer where toIntegral = P.id @@ -228,9 +249,10 @@ {-# MINIMAL fromIntegral #-} fromIntegral :: b -> a - default fromIntegral :: (a ~ b) => b -> a - fromIntegral = P.id +-- | Convert from an 'Int' +type FromInt a = FromIntegral a Int + instance (FromIntegral a b) => FromIntegral (c -> a) b where fromIntegral i _ = fromIntegral i @@ -354,7 +376,7 @@ -- -- - The default rules in < https://www.haskell.org/onlinereport/haskell2010/haskellch4.html#x10-750004.3 haskell2010> specify that constraints on 'fromInteger' need to be in a form @C v@, where v is a Num or a subclass of Num. -- --- So a type synonym of `type FromInteger a = FromIntegral a Integer` doesn't work well with type defaulting; hence the need for a separate class. +-- So a type synonym such as @type FromInteger a = FromIntegral a Integer@ doesn't work well with type defaulting; hence the need for a separate class. class FromInteger a where fromInteger :: Integer -> a @@ -400,21 +422,19 @@ instance FromInteger Word64 where fromInteger = P.fromInteger --- | --- >>> even 2 --- True -even :: (P.Eq a, Integral a) => a -> P.Bool -even n = n `rem` (one + one) P.== zero +deriving instance (FromInteger a) => FromInteger (Sum a) --- | --- >>> odd 3 --- True -odd :: (P.Eq a, Integral a) => a -> P.Bool -odd = P.not . even +deriving instance (FromInteger a) => FromInteger (Product a) infixr 8 ^^ -- | raise a number to an 'Integral' power +-- +-- >>> 2 ^^ 3 +-- 8.0 +-- +-- >>> 2 ^^ (-2) +-- 0.25 (^^) :: (P.Ord b, Divisive a, Subtractive b, Integral b) => a -> @@ -439,7 +459,42 @@ -- | raise a number to an 'Int' power -- --- Note: This differs from (^) found in prelude which is a partial function (it errors on negative integrals). This monomorphic version is provided to help reduce ambiguous type noise in common usages of this sign. +-- Note: This differs from (^) found in prelude which is a partial function (it errors on negative integrals). This is a monomorphic version of '(^^)' provided to help reduce ambiguous type noise in common usages. +-- +-- >>> 2 ^ 3 +-- 8.0 +-- +-- >>> 2 ^ (-2) +-- 0.25 (^) :: (Divisive a) => a -> Int -> a (^) x n = x ^^ n + +infixr 8 ^+ + +-- | raise a number to a non-negative 'Natural' power. +-- +-- Unlike '(^^)' and '(^)', this does not require 'Divisive' or 'Subtractive' +-- constraints, so it works for unsigned types such as 'Natural' and 'Word64'. +-- +-- >>> 2 ^+ 3 +-- 8 +-- +-- >>> 2 ^+ 0 +-- 1 +(^+) :: + (Multiplicative a) => a -> Natural -> a +x0 ^+ y0 = + case compare y0 zero of + EQ -> one + GT -> f x0 y0 + LT -> P.error "(^+): negative exponent" + where + f x y + | even y = f (x * x) (y `quot` two) + | y P.== one = x + | P.otherwise = g (x * x) (y `quot` two) x + g x y z + | even y = g (x * x) (y `quot` two) z + | y P.== one = x * z + | P.otherwise = g (x * x) (y `quot` two) (x * z) diff --git a/src/NumHask/Data/LogField.hs b/src/NumHask/Data/LogField.hs deleted file mode 100644 --- a/src/NumHask/Data/LogField.hs +++ /dev/null @@ -1,316 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall #-} - --- Module : Data.Number.LogFloat --- Copyright : Copyright (c) 2007--2015 wren gayle romano --- License : BSD3 --- Maintainer : wren@community.haskell.org --- Stability : stable --- Portability : portable (with CPP, FFI) --- Link : https://hackage.haskell.org/package/logfloat - --- | A 'Field' in the log domain. --- --- LogField is adapted from [logfloat](https://hackage.haskell.org/package/logfloat) -module NumHask.Data.LogField - ( -- * @LogField@ - LogField (), - logField, - fromLogField, - - -- ** Isomorphism to log-domain - logToLogField, - logFromLogField, - - -- ** Additional operations - accurateSum, - accurateProduct, - pow, - ) -where - -import Data.Data (Data) -import qualified Data.Foldable as F -import GHC.Generics (Generic, Generic1) -import NumHask.Algebra.Additive -import NumHask.Algebra.Field -import NumHask.Algebra.Lattice -import NumHask.Algebra.Multiplicative -import NumHask.Algebra.Ring -import NumHask.Analysis.Metric -import NumHask.Data.Integral -import NumHask.Data.Rational -import Prelude hiding (Num (..), exp, fromIntegral, log, negate) - --- | A @LogField@ is just a 'Field' with a special interpretation. --- The 'LogField' function is presented instead of the constructor, --- in order to ensure semantic conversion. At present the 'Show' --- instance will convert back to the normal-domain, and hence will --- underflow at that point. This behavior may change in the future. --- --- Because 'logField' performs the semantic conversion, we can use --- operators which say what we *mean* rather than saying what we're --- actually doing to the underlying representation. That is, --- equivalences like the following are true[1] thanks to type-class --- overloading: --- --- > logField (p + q) == logField p + logField q --- > logField (p * q) == logField p * logField q --- --- Performing operations in the log-domain is cheap, prevents --- underflow, and is otherwise very nice for dealing with miniscule --- probabilities. However, crossing into and out of the log-domain --- is expensive and should be avoided as much as possible. In --- particular, if you're doing a series of multiplications as in --- @lp * LogField q * LogField r@ it's faster to do @lp * LogField --- (q * r)@ if you're reasonably sure the normal-domain multiplication --- won't underflow; because that way you enter the log-domain only --- once, instead of twice. Also note that, for precision, if you're --- doing more than a few multiplications in the log-domain, you --- should use 'NumHask.Algebra.Multiplication.product' rather than using '(*)' repeatedly. --- --- Even more particularly, you should /avoid addition/ whenever --- possible. Addition is provided because sometimes we need it, and --- the proper implementation is not immediately apparent. However, --- between two @LogField@s addition requires crossing the exp\/log --- boundary twice; with a @LogField@ and a 'Double' it's three --- times, since the regular number needs to enter the log-domain --- first. This makes addition incredibly slow. Again, if you can --- parenthesize to do normal-domain operations first, do it! --- --- [1] That is, true up-to underflow and floating point fuzziness. --- Which is, of course, the whole point of this module. -newtype LogField a - = LogField a - deriving - ( Eq, - Ord, - Read, - Data, - Generic, - Generic1, - Functor, - Foldable, - Traversable - ) - ----------------------------------------------------------------- --- To show it, we want to show the normal-domain value rather than --- the log-domain value. Also, if someone managed to break our --- invariants (e.g. by passing in a negative and noone's pulled on --- the thunk yet) then we want to crash before printing the --- constructor, rather than after. N.B. This means the show will --- underflow\/overflow in the same places as normal doubles since --- we underflow at the @exp@. Perhaps this means we should show the --- log-domain value instead. -instance (ExpField a, Show a) => Show (LogField a) where - showsPrec p (LogField x) = - let y = exp x - in y `seq` showParen (p > 9) (showString "LogField " . showsPrec 11 y) - ----------------------------------------------------------------- - --- | Constructor which does semantic conversion from normal-domain --- to log-domain. Throws errors on negative and NaN inputs. If @p@ --- is non-negative, then following equivalence holds: --- --- > logField p == logToLogField (log p) -logField :: (ExpField a) => a -> LogField a -{-# INLINE [0] logField #-} -logField = LogField . log - --- | Constructor which assumes the argument is already in the --- log-domain. -logToLogField :: a -> LogField a -logToLogField = LogField - --- | Semantically convert our log-domain value back into the --- normal-domain. Beware of overflow\/underflow. The following --- equivalence holds (without qualification): --- --- > fromLogField == exp . logFromLogField -fromLogField :: ExpField a => LogField a -> a -{-# INLINE [0] fromLogField #-} -fromLogField (LogField x) = exp x - --- | Return the log-domain value itself without conversion. -logFromLogField :: LogField a -> a -logFromLogField (LogField x) = x - --- These are our module-specific versions of "log\/exp" and "exp\/log"; --- They do the same things but also have a @LogField@ in between --- the logarithm and exponentiation. In order to ensure these rules --- fire, we have to delay the inlining on two of the four --- con-\/destructors. -{-# RULES -"log/fromLogField" forall x. - log (fromLogField x) = - logFromLogField x -"fromLogField/LogField" forall x. fromLogField (LogField x) = x - #-} - -log1p :: ExpField a => a -> a -{-# INLINE [0] log1p #-} -log1p x = log (one + x) - -expm1 :: (ExpField a) => a -> a -{-# INLINE [0] expm1 #-} -expm1 x = exp x - one - -{-# RULES -"expm1/log1p" forall x. expm1 (log1p x) = x -"log1p/expm1" forall x. log1p (expm1 x) = x - #-} - -instance - (ExpField a, LowerBoundedField a, Ord a) => - Additive (LogField a) - where - x@(LogField x') + y@(LogField y') - | x == zero && y == zero = zero - | x == zero = y - | y == zero = x - | x >= y = LogField (x' + log1p (exp (y' - x'))) - | otherwise = LogField (y' + log1p (exp (x' - y'))) - - zero = LogField negInfinity - -instance - (ExpField a, Ord a, LowerBoundedField a, UpperBoundedField a) => - Subtractive (LogField a) - where - negate x - | x == zero = zero - | otherwise = nan - -instance - (LowerBoundedField a, Eq a) => - Multiplicative (LogField a) - where - (LogField x) * (LogField y) - | x == negInfinity || y == negInfinity = LogField negInfinity - | otherwise = LogField (x + y) - - one = LogField zero - -instance - (LowerBoundedField a, Eq a) => - Divisive (LogField a) - where - recip (LogField x) = LogField $ negate x - -instance - (Ord a, LowerBoundedField a, ExpField a) => - Distributive (LogField a) - -instance (Field (LogField a), ExpField a, LowerBoundedField a, Ord a) => ExpField (LogField a) where - exp (LogField x) = LogField $ exp x - log (LogField x) = LogField $ log x - (**) x (LogField y) = pow x $ exp y - -instance (FromIntegral a b, ExpField a) => FromIntegral (LogField a) b where - fromIntegral = logField . fromIntegral - -instance (ToIntegral a b, ExpField a) => ToIntegral (LogField a) b where - toIntegral = toIntegral . fromLogField - -instance (FromRatio a b, ExpField a) => FromRatio (LogField a) b where - fromRatio = logField . fromRatio - -instance (ToRatio a b, ExpField a) => ToRatio (LogField a) b where - toRatio = toRatio . fromLogField - -instance (Ord a) => JoinSemiLattice (LogField a) where - (\/) = min - -instance (Ord a) => MeetSemiLattice (LogField a) where - (/\) = max - -instance - (Epsilon a, ExpField a, LowerBoundedField a, UpperBoundedField a, Ord a) => - Epsilon (LogField a) - where - epsilon = logField epsilon - nearZero (LogField x) = nearZero $ exp x - aboutEqual (LogField x) (LogField y) = aboutEqual (exp x) (exp y) - -instance (Ord a, ExpField a, LowerBoundedField a, UpperBoundedField a) => Field (LogField a) - -instance - (Ord a, ExpField a, LowerBoundedField a, UpperBoundedField a) => - LowerBoundedField (LogField a) - -instance - (Ord a, ExpField a, LowerBoundedField a, UpperBoundedField a) => - UpperBoundedField (LogField a) - -instance - (Ord a, LowerBoundedField a, UpperBoundedField a, ExpField a) => - Signed (LogField a) - where - sign a - | a == negInfinity = zero - | otherwise = one - abs = id - ----------------------------------------------------------------- - --- | /O(1)/. Compute powers in the log-domain; that is, the following --- equivalence holds (modulo underflow and all that): --- --- > LogField (p ** m) == LogField p `pow` m -pow :: (ExpField a, LowerBoundedField a, Ord a) => LogField a -> a -> LogField a -{-# INLINE pow #-} - -infixr 8 `pow` - -pow x@(LogField x') m - | x == zero && m == zero = LogField zero - | x == zero = x - | otherwise = LogField $ m * x' - --- Some good test cases: --- for @logsumexp == log . accurateSum . map exp@: --- logsumexp[0,1,0] should be about 1.55 --- for correctness of avoiding underflow: --- logsumexp[1000,1001,1000] ~~ 1001.55 == 1000 + 1.55 --- logsumexp[-1000,-999,-1000] ~~ -998.45 == -1000 + 1.55 --- - --- | /O(n)/. Compute the sum of a finite list of 'LogField's, being --- careful to avoid underflow issues. That is, the following --- equivalence holds (modulo underflow and all that): --- --- > LogField . accurateSum == accurateSum . map LogField --- --- /N.B./, this function requires two passes over the input. Thus, --- it is not amenable to list fusion, and hence will use a lot of --- memory when summing long lists. -{-# INLINE accurateSum #-} -accurateSum :: (ExpField a, Foldable f, Ord a) => f (LogField a) -> LogField a -accurateSum xs = LogField (theMax + log theSum) - where - LogField theMax = maximum xs - -- compute @\log \sum_{x \in xs} \exp(x - theMax)@ - theSum = F.foldl' (\acc (LogField x) -> acc + exp (x - theMax)) zero xs - --- | /O(n)/. Compute the product of a finite list of 'LogField's, --- being careful to avoid numerical error due to loss of precision. --- That is, the following equivalence holds (modulo underflow and --- all that): --- --- > LogField . accurateProduct == accurateProduct . map LogField -{-# INLINE accurateProduct #-} -accurateProduct :: (ExpField a, Foldable f) => f (LogField a) -> LogField a -accurateProduct = LogField . fst . F.foldr kahanPlus (zero, zero) - where - kahanPlus (LogField x) (t, c) = - let y = x - c - t' = t + y - c' = (t' - t) - y - in (t', c') diff --git a/src/NumHask/Data/Positive.hs b/src/NumHask/Data/Positive.hs --- a/src/NumHask/Data/Positive.hs +++ b/src/NumHask/Data/Positive.hs @@ -1,82 +1,193 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} --- | Positive numbers. --- --- Positivity is enforced via the positive constructor +-- | A positive number type, defined as existing on [zero, +infinity) module NumHask.Data.Positive - ( Positive, + ( Positive (..), positive, + maybePositive, positive_, + Monus (..), + Addus (..), + MonusSemiField, ) where +import Control.Category ((>>>)) +import Data.Bool (bool) +import Data.Maybe +import NumHask.Algebra.Action import NumHask.Algebra.Additive import NumHask.Algebra.Field import NumHask.Algebra.Lattice +import NumHask.Algebra.Metric import NumHask.Algebra.Multiplicative import NumHask.Algebra.Ring -import NumHask.Analysis.Metric import NumHask.Data.Integral -import NumHask.Exception -import qualified Prelude as P +import NumHask.Data.Rational +import NumHask.Data.Wrapped +import Numeric.Natural (Natural, minusNaturalMaybe) +import Prelude (Eq, Ord, Show) +import Prelude qualified as P --- | Wrapper for positive numbers. Note that the constructor is not exported. -newtype Positive a = Positive {unPositive :: a} +-- $setup +-- +-- >>> :m -Prelude +-- >>> :set -XRebindableSyntax +-- >>> import NumHask.Prelude +-- >>> import NumHask.Data.Positive + +-- | A positive number is a number that is contained in [zero,+infinity). +-- +-- >>> 1 :: Positive Int +-- UnsafePositive {unPositive = 1} +-- +-- +-- >>> -1 :: Positive Int +-- ... +-- • No instance for ‘Subtractive (Positive Int)’ +-- arising from a use of syntactic negation +-- ... +-- +-- zero is positive +-- +-- >>> positive 0 == zero +-- True +-- +-- The main constructors: +-- +-- >>> positive (-1) +-- UnsafePositive {unPositive = 0} +-- +-- >>> maybePositive (-1) +-- Nothing +-- +-- >>> UnsafePositive (-1) +-- UnsafePositive {unPositive = -1} +newtype Positive a = UnsafePositive {unPositive :: a} + deriving stock + (Eq, Ord, Show) deriving - ( P.Show, - P.Eq, - P.Ord, - Additive, + ( Additive, Multiplicative, Divisive, - Distributive, - Field, - ExpField, - TrigField, Integral, - Signed, + FromInteger, + FromRational, + Basis, + Direction, + Epsilon, + AdditiveAction, + SubtractiveAction, + MultiplicativeAction, + DivisiveAction, JoinSemiLattice, MeetSemiLattice, - Epsilon + UpperBounded ) + via (Wrapped a) --- | maybe construct a 'Positive' -positive_ :: (P.Ord a, Additive a) => a -> P.Maybe (Positive a) -positive_ a - | a P.< zero = P.Nothing - | P.otherwise = P.Just (Positive a) +instance (JoinSemiLattice a, Integral a) => FromIntegral (Positive a) a where + fromIntegral a = positive a --- | Construct a Positive, throwing an error if the input is negative. -positive :: (P.Ord a, Additive a) => a -> Positive a -positive a - | a P.< zero = throw (NumHaskException "positive number less than zero") - | P.otherwise = Positive a +instance (FromIntegral a b) => FromIntegral (Positive a) b where + fromIntegral a = UnsafePositive (fromIntegral a) -instance (P.Ord a, Subtractive a) => Subtractive (Positive a) where - negate (Positive a) - | a P.== zero = Positive zero - | P.otherwise = throw (NumHaskException "negating a positive number") +instance (ToIntegral a b) => ToIntegral (Positive a) b where + toIntegral (UnsafePositive a) = toIntegral a - (Positive a) - (Positive b) - | a P.>= b = Positive (a - b) - | P.otherwise = throw (NumHaskException "subtracting a larger positive") +instance (FromRatio a b) => FromRatio (Positive a) b where + fromRatio a = UnsafePositive (fromRatio a) -instance - (P.Ord a, QuotientField a P.Integer) => - QuotientField (Positive a) (Positive P.Integer) - where - properFraction (Positive a) = let (i, r) = properFraction a in (Positive i, Positive r) +instance (ToRatio a b) => ToRatio (Positive a) b where + toRatio (UnsafePositive a) = toRatio a -instance - (P.Ord a, UpperBoundedField a) => - UpperBoundedField (Positive a) - where - infinity = Positive infinity +instance (Additive a, JoinSemiLattice a) => LowerBounded (Positive a) where + bottom = UnsafePositive zero -instance (P.Ord a, UpperBoundedField a) => P.Bounded (Positive a) where - minBound = zero - maxBound = infinity +instance QuotientField (Positive P.Double) where + type Whole (Positive P.Double) = Positive P.Int + properFraction (UnsafePositive a) = (\(n, r) -> (UnsafePositive n, UnsafePositive r)) (P.properFraction a) + ceiling = properFraction >>> P.fst >>> (+ one) + floor = properFraction >>> P.fst + truncate = floor + round x = case properFraction x of + (n, r) -> + let half_up = r + half + in case P.compare half_up one of + P.LT -> n + P.EQ -> bool (n + one) n (even n) + P.GT -> n + one + +-- | Constructor which returns zero for a negative number. +-- +-- >>> positive (-1) +-- UnsafePositive {unPositive = 0} +positive :: (Additive a, JoinSemiLattice a) => a -> Positive a +positive a = UnsafePositive (a \/ zero) + +-- | Unsafe constructor. +-- +-- >>> positive_ (-one) +-- UnsafePositive {unPositive = -1} +positive_ :: a -> Positive a +positive_ = UnsafePositive + +-- | Constructor which returns Nothing if a negative number is supplied. +-- +-- >>> maybePositive (-one) +-- Nothing +maybePositive :: (Additive a, MeetSemiLattice a) => a -> Maybe (Positive a) +maybePositive a = bool Nothing (Just (UnsafePositive a)) (zero `meetLeq` a) + +instance (Subtractive a, JoinSemiLattice a) => Monus (Positive a) where + (UnsafePositive a) ∸ (UnsafePositive b) = positive (a - b) + +-- | A field but with truncated subtraction. +type MonusSemiField a = (Monus a, Distributive a, Divisive a) + +-- | or truncated subtraction. +-- +-- @since 0.12 +-- +-- >>> positive 4 ∸ positive 7 +-- UnsafePositive {unPositive = 0} +-- +-- >>> 4 ∸ 7 :: Positive Int +-- UnsafePositive {unPositive = 0} +class Monus a where + {-# MINIMAL (∸) #-} + + infixl 6 ∸ + (∸) :: a -> a -> a + default (∸) :: (LowerBounded a, Subtractive a) => a -> a -> a + a ∸ b = bottom \/ (a - b) + +-- | A newtype wrapper intended for defining Monus instances by: +-- "x ∸ y = if x < y then zero else x - y" +newtype MonusFromOrd a = MonusFromOrd a + deriving (Eq, Ord, Additive, Subtractive) + +instance (Ord a, Subtractive a) => Monus (MonusFromOrd a) where + x ∸ y + | x P.< y = zero + | P.otherwise = x - y + +-- | It appears that Haskell doesn't have any built in truncated +-- subtraction operation for Word +deriving via MonusFromOrd P.Word instance Monus P.Word + +instance Monus Natural where + x ∸ y = fromMaybe 0 (minusNaturalMaybe x y) + +-- | Truncated addition +-- +-- @since 0.12 +class Addus a where + {-# MINIMAL (∔) #-} + infixl 6 ∔ + (∔) :: a -> a -> a + default (∔) :: (UpperBounded a, JoinSemiLattice a, Additive a) => a -> a -> a + a ∔ b = top \/ (a + b) diff --git a/src/NumHask/Data/Rational.hs b/src/NumHask/Data/Rational.hs --- a/src/NumHask/Data/Rational.hs +++ b/src/NumHask/Data/Rational.hs @@ -1,12 +1,5 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE UndecidableInstances #-} -- | Rational classes module NumHask.Data.Rational @@ -17,6 +10,8 @@ FromRational (..), reduce, gcd, + numerator, + denominator, ) where @@ -25,33 +20,43 @@ import Data.Word (Word, Word16, Word32, Word64, Word8) import GHC.Float import GHC.Natural (Natural (..)) -import qualified GHC.Real +import GHC.Real qualified import NumHask.Algebra.Additive import NumHask.Algebra.Field import NumHask.Algebra.Lattice +import NumHask.Algebra.Metric import NumHask.Algebra.Multiplicative import NumHask.Algebra.Ring -import NumHask.Analysis.Metric import NumHask.Data.Integral -import Prelude (Int, Integer, Ord (..), Ordering (..), Rational, (.)) -import qualified Prelude as P +import Prelude (Eq (..), Int, Integer, Ord (..), Ordering (..), (.)) +import Prelude qualified as P -- $setup -- +-- >>> :m -Prelude -- >>> :set -XRebindableSyntax --- >>> :set -XNegativeLiterals -- >>> import NumHask.Prelude --- | A rational number +-- | A rational number, represented as the ratio of two 'Integral' numbers. data Ratio a = !a :% !a deriving (P.Show) -instance (P.Eq a, Additive a) => P.Eq (Ratio a) where - a == b +-- | Ratio of two integers +type Rational = Ratio Integer + +numerator :: Ratio a -> a +numerator (a :% _) = a + +denominator :: Ratio a -> a +denominator (_ :% a) = a + +instance (P.Eq a, P.Ord a, Subtractive a, EndoBased a, Absolute a, Integral a) => P.Eq (Ratio a) where + a@(xa :% ya) == b@(xb :% yb) | isRNaN a P.|| isRNaN b = P.False - | P.otherwise = (x P.== x') P.&& (y P.== y') - where - (x :% y) = a - (x' :% y') = b + | xa == zero P.&& xb == zero = P.True + | xa == zero P.|| xb == zero = P.False + | P.otherwise = + let (xa' :% ya', xb' :% yb') = (reduce xa ya, reduce xb yb) + in (xa' P.== xb') P.&& (ya' P.== yb') -- | Has a zero denominator isRNaN :: (P.Eq a, Additive a) => Ratio a -> P.Bool @@ -59,11 +64,11 @@ | x P.== zero P.&& y P.== zero = P.True | P.otherwise = P.False -instance (P.Ord a, Multiplicative a, Additive a) => P.Ord (Ratio a) where +instance (P.Ord a, Integral a, EndoBased a, Subtractive a) => P.Ord (Ratio a) where (x :% y) <= (x' :% y') = x * y' P.<= x' * y (x :% y) < (x' :% y') = x * y' P.< x' * y -instance (P.Ord a, Signed a, Integral a, Ring a) => Additive (Ratio a) where +instance (P.Ord a, EndoBased a, Integral a, Ring a) => Additive (Ratio a) where (x :% y) + (x' :% y') | y P.== zero P.&& y' P.== zero = bool one (negate one) (x + x' P.< zero) :% zero | y P.== zero = x :% y @@ -72,66 +77,56 @@ zero = zero :% one -instance (P.Ord a, Signed a, Integral a, Ring a) => Subtractive (Ratio a) where +instance (P.Ord a, EndoBased a, Integral a, Ring a) => Subtractive (Ratio a) where negate (x :% y) = negate x :% y -instance (P.Ord a, Signed a, Integral a, Ring a, Multiplicative a) => Multiplicative (Ratio a) where +instance (P.Ord a, EndoBased a, Integral a, Ring a) => Multiplicative (Ratio a) where (x :% y) * (x' :% y') = reduce (x * x') (y * y') one = one :% one instance - (P.Ord a, Signed a, Integral a, Ring a) => + (P.Ord a, EndoBased a, Integral a, Ring a) => Divisive (Ratio a) where recip (x :% y) - | sign x P.== negate one = negate y :% negate x + | x P.< zero = negate y :% negate x | P.otherwise = y :% x -instance (P.Ord a, Signed a, Integral a, Ring a) => Distributive (Ratio a) - -instance (P.Ord a, Signed a, Integral a, Ring a) => Field (Ratio a) - -instance (P.Ord a, Signed a, Integral a, Ring a, P.Ord b, Signed b, Integral b, Ring b, Field a, FromIntegral b a) => QuotientField (Ratio a) b where - properFraction (n :% d) = let (w, r) = quotRem n d in (fromIntegral w, r :% d) - -instance - (P.Ord a, Signed a, Integral a, Ring a, Distributive a) => - UpperBoundedField (Ratio a) - -instance (P.Ord a, Signed a, Integral a, Field a) => LowerBoundedField (Ratio a) +instance (P.Ord a, EndoBased a, Absolute a, ToInt a, Integral a, Ring a) => QuotientField (Ratio a) where + type Whole (Ratio a) = Int + properFraction (n :% d) = let (w, r) = quotRem n d in (toIntegral w, r :% d) -instance (P.Ord a, Signed a, Integral a, Ring a) => Signed (Ratio a) where - sign (n :% _) = +instance (P.Ord a, EndoBased a, Integral a, Ring a) => Basis (Ratio a) where + type Mag (Ratio a) = Ratio a + type Base (Ratio a) = Ratio a + basis (n :% _) = case compare n zero of EQ -> zero GT -> one LT -> negate one - abs (n :% d) = abs n :% abs d + magnitude (n :% d) = abs n :% abs d -instance (P.Ord a, Signed a, Integral a, Ring a) => Norm (Ratio a) (Ratio a) where - norm = abs - basis = sign +instance (P.Ord a, Integral a, EndoBased a, Subtractive a) => JoinSemiLattice (Ratio a) where + (\/) = P.max -instance (P.Ord a, Signed a) => JoinSemiLattice (Ratio a) where - (\/) = P.min +instance (P.Ord a, Integral a, EndoBased a, Subtractive a) => MeetSemiLattice (Ratio a) where + (/\) = P.min -instance (P.Ord a, Signed a) => MeetSemiLattice (Ratio a) where - (/\) = P.max +instance (P.Ord a, EndoBased a, Integral a, Ring a) => Epsilon (Ratio a) -instance (P.Ord a, Signed a, Integral a, Ring a, MeetSemiLattice a) => Epsilon (Ratio a) +instance (FromInteger a, Multiplicative a) => FromInteger (Ratio a) where + fromInteger x = fromInteger x :% one instance (FromIntegral a b, Multiplicative a) => FromIntegral (Ratio a) b where fromIntegral x = fromIntegral x :% one -- | toRatio is equivalent to `GHC.Real.Real` in base, but is polymorphic in the Integral type. -- --- > toRatio (3.1415927 :: Float) :: Ratio Integer +-- >>> toRatio (3.1415927 :: Float) :: Ratio Integer -- 13176795 :% 4194304 class ToRatio a b where toRatio :: a -> Ratio b - default toRatio :: (Ratio c ~ a, FromIntegral b c, ToRatio (Ratio b) b) => a -> Ratio b - toRatio (n :% d) = toRatio ((fromIntegral n :: b) :% fromIntegral d) instance ToRatio Double Integer where toRatio = fromBaseRational . P.toRational @@ -139,9 +134,6 @@ instance ToRatio Float Integer where toRatio = fromBaseRational . P.toRational -instance ToRatio Rational Integer where - toRatio = fromBaseRational - instance ToRatio (Ratio Integer) Integer where toRatio = P.id @@ -187,8 +179,6 @@ -- 2.5 class FromRatio a b where fromRatio :: Ratio b -> a - default fromRatio :: (Ratio b ~ a) => Ratio b -> a - fromRatio = P.id fromBaseRational :: P.Rational -> Ratio Integer fromBaseRational (n GHC.Real.:% d) = n :% d @@ -200,7 +190,7 @@ fromRatio (n :% d) = rationalToFloat n d instance FromRatio Rational Integer where - fromRatio (n :% d) = n GHC.Real.% d + fromRatio = P.id -- | fromRational is special in two ways: -- @@ -223,8 +213,13 @@ -- | 'reduce' normalises a ratio by dividing both numerator and denominator by -- their greatest common divisor. +-- +-- >>> reduce 72 60 +-- 6 :% 5 +-- +-- prop> \a b -> reduce a b == a :% b || b == zero reduce :: - (P.Eq a, Subtractive a, Signed a, Integral a) => a -> a -> Ratio a + (P.Ord a, Subtractive a, EndoBased a, Integral a) => a -> a -> Ratio a reduce x y | x P.== zero P.&& y P.== zero = zero :% zero | z P.== zero = one :% zero @@ -232,7 +227,7 @@ where z = gcd x y n % d - | sign d P.== negate one = negate n :% negate d + | d P.< zero = negate n :% negate d | P.otherwise = n :% d -- | @'gcd' x y@ is the non-negative factor of both @x@ and @y@ of which @@ -244,7 +239,10 @@ -- Note: Since for signed fixed-width integer types, @'abs' 'GHC.Enum.minBound' < 0@, -- the result may be negative if one of the arguments is @'GHC.Enum.minBound'@ (and -- necessarily is if the other is @0@ or @'GHC.Enum.minBound'@) for such types. -gcd :: (P.Eq a, Signed a, Integral a) => a -> a -> a +-- +-- >>> gcd 72 60 +-- 12 +gcd :: (P.Eq a, EndoBased a, Integral a) => a -> a -> a gcd x y = gcd' (abs x) (abs y) where gcd' a b diff --git a/src/NumHask/Data/Wrapped.hs b/src/NumHask/Data/Wrapped.hs --- a/src/NumHask/Data/Wrapped.hs +++ b/src/NumHask/Data/Wrapped.hs @@ -1,10 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall #-} -- | Wrapped numhask instances, useful for derivingvia situations to quickly specifiy a numhask friendly numerical type. module NumHask.Data.Wrapped @@ -12,53 +7,53 @@ ) where +import NumHask.Algebra.Action import NumHask.Algebra.Additive import NumHask.Algebra.Field -import NumHask.Algebra.Group import NumHask.Algebra.Lattice +import NumHask.Algebra.Metric import NumHask.Algebra.Multiplicative import NumHask.Algebra.Ring -import NumHask.Analysis.Metric import NumHask.Data.Integral import NumHask.Data.Rational -import qualified Prelude as P +import Prelude qualified as P --- | Wrapped numeric instances +-- | Wrapped numhask instances newtype Wrapped a = Wrapped {unWrapped :: a} deriving ( P.Show, P.Eq, P.Ord, - Magma, - Idempotent, Additive, Subtractive, Multiplicative, Divisive, - Distributive, - Ring, - InvolutiveRing, - StarSemiring, - KleeneAlgebra, - Field, ExpField, TrigField, + StarSemiring, + InvolutiveRing, Integral, - Signed, + FromInteger, + FromRational, MeetSemiLattice, JoinSemiLattice, - BoundedJoinSemiLattice, - BoundedMeetSemiLattice, + LowerBounded, + UpperBounded, + Basis, + Direction, Epsilon, - UpperBoundedField, - LowerBoundedField + AdditiveAction, + SubtractiveAction, + MultiplicativeAction, + DivisiveAction ) instance - (P.Ord a, QuotientField a P.Integer) => - QuotientField (Wrapped a) (Wrapped P.Integer) + (P.Ord a, P.Eq (Whole a), Integral (Whole a), Subtractive (Whole a), Subtractive a, QuotientField a) => + QuotientField (Wrapped a) where - properFraction (Wrapped a) = let (i, r) = properFraction a in (Wrapped i, Wrapped r) + type Whole (Wrapped a) = Whole a + properFraction (Wrapped a) = let (i, r) = properFraction a in (i, Wrapped r) instance (FromIntegral a b) => FromIntegral (Wrapped a) b where fromIntegral a = Wrapped (fromIntegral a) diff --git a/src/NumHask/Exception.hs b/src/NumHask/Exception.hs --- a/src/NumHask/Exception.hs +++ b/src/NumHask/Exception.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wall #-} - -- | Exceptions arising within numhask. module NumHask.Exception ( NumHaskException (..), @@ -8,11 +6,10 @@ where import Control.Exception -import Data.Typeable (Typeable) -import qualified Prelude as P +import Prelude qualified as P -- | A numhask exception. newtype NumHaskException = NumHaskException {errorMessage :: P.String} - deriving (P.Show, Typeable) + deriving (P.Show) instance Exception NumHaskException diff --git a/src/NumHask/Prelude.hs b/src/NumHask/Prelude.hs --- a/src/NumHask/Prelude.hs +++ b/src/NumHask/Prelude.hs @@ -1,85 +1,86 @@ -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE RebindableSyntax #-} -{-# OPTIONS_GHC -Wall #-} {-# OPTIONS_HADDOCK prune #-} --- | A numeric prelude, composed by splicing numhask modules with [protolude](https://hackage.haskell.org/package/protolude), together with a few minor tweaks and additions. +-- | A prelude composed by overlaying numhask on Prelude, together with a few minor tweaks needed for RebindableSyntax. module NumHask.Prelude ( -- * numhask exports module NumHask.Algebra.Additive, module NumHask.Algebra.Field, module NumHask.Algebra.Group, module NumHask.Algebra.Lattice, - module NumHask.Algebra.Module, + module NumHask.Algebra.Action, module NumHask.Algebra.Multiplicative, module NumHask.Algebra.Ring, - module NumHask.Analysis.Metric, + module NumHask.Algebra.Metric, module NumHask.Data.Complex, module NumHask.Data.Integral, - module NumHask.Data.LogField, module NumHask.Data.Rational, - module NumHask.Data.Positive, module NumHask.Exception, -- * rebindables -- $rebindables fromString, - fail, ifThenElse, fromList, fromListN, - - -- * extras - -- $extras - Category (..), - pack, - unpack, - module Data.Bifunctor, - module Data.Biapplicative, - module Control.Monad.Morph, - module Data.Functor.Constant, - module System.Random, - module System.Random.Stateful, Natural (..), + module GHC.OverloadedLabels, - -- * protolude - -- $protolude - module Protolude, + -- * Modules you can't live without + module Data.Bool, + module Data.Kind, + module GHC.Generics, + module Control.Applicative, + module Data.Traversable, + module Data.Semigroup, + module Data.Maybe, + + -- * Data.Function + module Data.Function, + + -- * Control.Category + + -- Putting id back. + module Control.Category, + + -- * Data.Foldable + module Data.Foldable, + + -- * The Prelude + module Prelude, ) where -import Control.Category (Category (..)) -import Control.Monad (fail) -import Control.Monad.Morph -import Data.Biapplicative -import Data.Bifunctor -import Data.Functor.Constant -import Data.String -import Data.Text (pack, unpack) +import Control.Applicative +import Control.Category +import Data.Bool +import Data.Foldable hiding (product, sum) +import Data.Function hiding (id, (.)) +import Data.Kind +import Data.Maybe +import Data.Semigroup hiding (Product (..), Sum (..)) +import Data.Traversable import GHC.Exts +import GHC.Generics import GHC.Natural (Natural (..)) +import GHC.OverloadedLabels +import NumHask.Algebra.Action import NumHask.Algebra.Additive import NumHask.Algebra.Field import NumHask.Algebra.Group import NumHask.Algebra.Lattice -import NumHask.Algebra.Module +import NumHask.Algebra.Metric import NumHask.Algebra.Multiplicative import NumHask.Algebra.Ring -import NumHask.Analysis.Metric import NumHask.Data.Complex import NumHask.Data.Integral -import NumHask.Data.LogField -import NumHask.Data.Positive import NumHask.Data.Rational import NumHask.Exception -import Protolude hiding ((*), (**), (+), (-), (.), (/), (<<$>>), (<<*>>), Complex (..), Integral (..), Ratio, Product (..), Rep, Semiring (..), Sum (..), (^), (^^), abs, acos, acosh, asin, asinh, atan, atan2, atanh, ceiling, cis, cos, cosh, even, exp, floor, fromInteger, fromIntegral, fromRational, gcd, imagPart, infinity, log, logBase, magnitude, mkPolar, negate, odd, phase, pi, polar, product, properFraction, realPart, recip, reduce, round, sin, sinh, sqrt, subtract, sum, tan, tanh, toInteger, toRational, trans, truncate, zero) -import System.Random -import System.Random.Stateful +import Prelude hiding (Integral (..), Rational, abs, acos, acosh, asin, asinh, atan, atan2, atanh, ceiling, cos, cosh, even, exp, floor, fromInteger, fromIntegral, fromRational, gcd, id, log, logBase, negate, odd, pi, product, properFraction, recip, round, signum, sin, sinh, sqrt, subtract, sum, tan, tanh, toInteger, toRational, truncate, (*), (**), (+), (-), (.), (/), (^), (^^)) -- $usage -- +-- >>> :m -Prelude -- >>> :set -XRebindableSyntax --- >>> :set -XNegativeLiterals -- >>> import NumHask.Prelude -- >>> 1+1 -- 2 @@ -92,20 +93,3 @@ ifThenElse :: Bool -> a -> a -> a ifThenElse True x _ = x ifThenElse False _ y = y - --- $extras --- --- Bits and pieces different to protolude, including: --- --- - re-inserting 'id' which should never be overwritten in haskell code. --- --- - 'Data.Bifunctors' & 'Data.Biapplicative' which are favorites of the OA. --- --- - 'Control.Monad.Morph'; another essential, ubiquitous library. --- --- - 'Data.Functor.Constant' --- --- - 'pack' and 'unpack', which may encourage usage of 'String' but can also quickly escape from the same. - --- $protolude --- It would be nice to just link straight through to the [protolude documentation](https://hackage.haskell.org/package/protolude), but, alas, at time of production, haddock insists on dumping everything here. diff --git a/test/test.hs b/test/test.hs deleted file mode 100644 --- a/test/test.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE RebindableSyntax #-} -{-# OPTIONS_GHC -Wall #-} - -module Main where - -import NumHask.Prelude -import Test.DocTest - -main :: IO () -main = - doctest - [ "src/NumHask.hs", - "src/NumHask/Prelude.hs", - "src/NumHask/Algebra/Additive.hs", - "src/NumHask/Algebra/Multiplicative.hs", - "src/NumHask/Algebra/Ring.hs", - "src/NumHask/Algebra/Field.hs", - "src/NumHask/Algebra/Module.hs" - -- FIXME: When doctest hits this module, it can't resolve even the simplest instances ... - -- "src/NumHask/Data/Rational.hs" - ]