diff --git a/numhask.cabal b/numhask.cabal --- a/numhask.cabal +++ b/numhask.cabal @@ -1,5 +1,5 @@ name: numhask -version: 0.3.0.0 +version: 0.3.1 synopsis: numeric classes description: @@ -23,7 +23,7 @@ build-type: Simple cabal-version: - 1.18 + 2.0 extra-doc-files: other/*.svg diff --git a/src/NumHask/Algebra/Abstract/Field.hs b/src/NumHask/Algebra/Abstract/Field.hs --- a/src/NumHask/Algebra/Abstract/Field.hs +++ b/src/NumHask/Algebra/Abstract/Field.hs @@ -1,5 +1,10 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -Wall #-} -- | Field classes @@ -20,6 +25,7 @@ import NumHask.Algebra.Abstract.Ring import NumHask.Data.Integral import qualified Prelude as P +import Prelude ((.)) -- | A is an -- Integral domain in which every non-zero element has a multiplicative @@ -54,7 +60,7 @@ instance Field P.Float --- instance Field b => Field (a -> b) +instance Field b => Field (a -> b) -- | A hyperbolic field class -- @@ -82,26 +88,21 @@ log = P.log (**) = (P.**) -{- instance ExpField b => ExpField (a -> b) where exp f = exp . f log f = log . f - logBase f f' = \a -> logBase (f a) (f' a) + logBase f f' a = logBase (f a) (f' a) f ** f' = \a -> f a ** f' a sqrt f = sqrt . f --} --- | quotient fields explode constraints if they allow for polymorphic integral types --- -- > a - one < floor a <= a <= ceiling a < a + one -- > round a == floor (a + one/(one+one)) -- --- fixme: had to redefine Signed operators here because of the Field import in Metric, itself due to Complex being defined there -class (Field a, Subtractive a, Integral b) => QuotientField a b where +class (Field a, Subtractive a, Multiplicative b, Additive b) => QuotientField a b where properFraction :: a -> (b, a) round :: a -> b - default round ::(P.Ord a, P.Ord b, Subtractive b) => a -> b + default round ::(P.Ord a, P.Ord b, Subtractive b, Integral b) => a -> b round x = case properFraction x of (n,r) -> let m = bool (n+one) (n-one) (r P.< zero) @@ -135,10 +136,9 @@ instance QuotientField P.Double P.Integer where properFraction = P.properFraction -{- instance QuotientField b c => QuotientField (a -> b) (a -> c) where - properFraction f = (fst . frac, snd . frac) - where + properFraction f = (P.fst . frac, P.snd . frac) + where frac a = properFraction @b @c (f a) round f = round . f @@ -149,8 +149,6 @@ truncate f = truncate . f --} - -- | A bounded field includes the concepts of infinity and NaN, thus moving away from error throwing. -- -- > one / zero + infinity == infinity @@ -167,22 +165,14 @@ nan :: a nan = zero / zero - isNaN :: a -> P.Bool - -instance UpperBoundedField P.Float where - isNaN = P.isNaN +instance UpperBoundedField P.Float -instance UpperBoundedField P.Double where - isNaN = P.isNaN +instance UpperBoundedField P.Double -{- instance UpperBoundedField b => UpperBoundedField (a -> b) where infinity _ = infinity nan _ = nan - isNaN = P.undefined --} - class (Subtractive a, Field a) => LowerBoundedField a where @@ -193,19 +183,9 @@ instance LowerBoundedField P.Double -{- instance LowerBoundedField b => LowerBoundedField (a -> b) where negInfinity _ = negInfinity --} - --- | todo: work out boundings for complex --- as it stands now, complex is different eg --- --- > one / (zero :: Complex Float) == nan --- instance (UpperBoundedField a) => --- UpperBoundedField (Complex a) - -- | Trigonometric Field class (Field a) => TrigField a where @@ -251,7 +231,6 @@ acosh = P.acosh atanh = P.atanh -{- instance TrigField b => TrigField (a -> b) where pi _ = pi sin f = sin . f @@ -264,7 +243,6 @@ asinh f = asinh . f acosh f = acosh . f atanh f = atanh . f --} half :: (Field a) => a half = one / two diff --git a/src/NumHask/Algebra/Abstract/Ring.hs b/src/NumHask/Algebra/Abstract/Ring.hs --- a/src/NumHask/Algebra/Abstract/Ring.hs +++ b/src/NumHask/Algebra/Abstract/Ring.hs @@ -51,7 +51,7 @@ -- | A is a ring without, -- necessarily, negative elements. -- --- TODO: rule zero' = zero. Is this somehow expressible in haskell? +-- FIXME: rule zero' = zero. Is this somehow expressible in haskell? class (Distributive a) => Semiring a where instance (Distributive a) => diff --git a/src/NumHask/Algebra/Abstract/TensorProduct.hs b/src/NumHask/Algebra/Abstract/TensorProduct.hs --- a/src/NumHask/Algebra/Abstract/TensorProduct.hs +++ b/src/NumHask/Algebra/Abstract/TensorProduct.hs @@ -1,11 +1,13 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -Wall #-} -- | TensorProduct module NumHask.Algebra.Abstract.TensorProduct ( TensorProduct(..) + , TensorProduct'(..) , type (><) ) where @@ -66,3 +68,14 @@ outer = (><) timesleft :: a -> (a >< a) -> a timesright :: (a >< a) -> a -> a + +-- | generalised outer product +-- +-- > a>< b +-- > a>< (b+c) +-- > a *. (b> (a> b -> (a >< b) + timesleft' :: a -> (a >< b) -> b + timesright' :: (a >< b) -> a -> b diff --git a/src/NumHask/Algebra/Linear/Hadamard.hs b/src/NumHask/Algebra/Linear/Hadamard.hs --- a/src/NumHask/Algebra/Linear/Hadamard.hs +++ b/src/NumHask/Algebra/Linear/Hadamard.hs @@ -20,13 +20,13 @@ -- -- > (a .*. b) .*. c == a .*. (b .*. c) -- > singleton one .*. a = a --- > a .*. singelton one = a +-- > a .*. singleton one = a -- > a .*. b == b .*. a class (Multiplicative a) => HadamardMultiplication m a where infixl 7 .*. (.*.) :: m a -> m a -> m a - (.*.) = coerce ((.*.) @m @a) + -- (.*.) = coerce ((.*.) @m @a) -- | element by element division diff --git a/src/NumHask/Analysis/Metric.hs b/src/NumHask/Analysis/Metric.hs --- a/src/NumHask/Analysis/Metric.hs +++ b/src/NumHask/Analysis/Metric.hs @@ -273,7 +273,7 @@ epsilon = zero nearZero :: a -> Bool - nearZero a = a `meetLeq` epsilon && negate a `meetLeq` epsilon + nearZero a = epsilon `meetLeq` a && epsilon `meetLeq` negate a aboutEqual :: a -> a -> Bool aboutEqual a b = nearZero $ a - b 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 @@ -5,6 +5,7 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wall #-} module NumHask.Data.Complex where @@ -18,9 +19,8 @@ import NumHask.Algebra.Abstract.Ring import NumHask.Analysis.Metric import NumHask.Data.Integral - import Prelude - hiding (Num(..), (**), (/), atan, cos, exp, log, negate, pi, recip, sin, sqrt, isNaN) + hiding (Num(..), (/), atan, cos, exp, log, negate, pi, recip, sin, sqrt) import qualified Prelude as P (Ord(..), (&&), (<), (<=), (==), (>), otherwise) -- ----------------------------------------------------------------------------- @@ -78,9 +78,9 @@ where d = recip ((rx * rx) + (ix * ix)) -instance (Additive a, FromInteger a) => - FromInteger (Complex a) where - fromInteger x = fromInteger x :+ zero +instance (Additive a, FromIntegral a b) => + FromIntegral (Complex a) b where + fromIntegral_ x = fromIntegral_ x :+ zero instance (Multiplicative a, ExpField a, Normed a a) => Normed (Complex a) a where @@ -118,8 +118,7 @@ instance (Distributive a, Subtractive a) => InvolutiveRing (Complex a) where adj (a :+ b) = a :+ negate b -instance (UpperBoundedField a, IntegralDomain a, Subtractive a) => UpperBoundedField (Complex a) where - isNaN (a :+ b) = isNaN a || isNaN b +instance (UpperBoundedField a, IntegralDomain a, Subtractive a) => UpperBoundedField (Complex a) instance (LowerBoundedField a) => LowerBoundedField (Complex a) 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,9 +1,19 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall #-} -- | Integral classes module NumHask.Data.Integral ( Integral(..) - , ToInteger(..) + , ToIntegral(..) + , ToInteger + , toInteger + , FromIntegral(..) , FromInteger(..) , fromIntegral , even @@ -98,100 +108,199 @@ 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)) --- | toInteger is kept separate from Integral to help with compatability issues. -class ToInteger a where - toInteger :: a -> Integer +-- | toIntegral is kept separate from Integral to help with compatability issues. +-- > toIntegral a == a +class ToIntegral a b where + toIntegral :: a -> b + default toIntegral :: (a ~ b) => a -> b + toIntegral = P.id -instance ToInteger Int where - toInteger = P.toInteger +type ToInteger a = ToIntegral a Integer -instance ToInteger Integer where - toInteger = P.toInteger +-- fitting in with legacy naming conventions. +toInteger :: (ToInteger a) => a -> Integer +toInteger = toIntegral -instance ToInteger Natural where - toInteger = P.toInteger +instance ToIntegral Integer Integer where + toIntegral = P.id -instance ToInteger Int8 where - toInteger = P.toInteger +instance ToIntegral Int Integer where + toIntegral = P.toInteger -instance ToInteger Int16 where - toInteger = P.toInteger +instance ToIntegral Natural Integer where + toIntegral = P.toInteger -instance ToInteger Int32 where - toInteger = P.toInteger +instance ToIntegral Int8 Integer where + toIntegral = P.toInteger -instance ToInteger Int64 where - toInteger = P.toInteger +instance ToIntegral Int16 Integer where + toIntegral = P.toInteger -instance ToInteger Word where - toInteger = P.toInteger +instance ToIntegral Int32 Integer where + toIntegral = P.toInteger -instance ToInteger Word8 where - toInteger = P.toInteger +instance ToIntegral Int64 Integer where + toIntegral = P.toInteger -instance ToInteger Word16 where - toInteger = P.toInteger +instance ToIntegral Word Integer where + toIntegral = P.toInteger -instance ToInteger Word32 where - toInteger = P.toInteger +instance ToIntegral Word8 Integer where + toIntegral = P.toInteger -instance ToInteger Word64 where - toInteger = P.toInteger +instance ToIntegral Word16 Integer where + toIntegral = P.toInteger --- | fromInteger is the most problematic of the 'Num' class operators. Particularly heinous, it is assumed that any number type can be constructed from an Integer, so that the broad classes of objects that are composed of multiple elements is avoided in haskell. -class FromInteger a where - fromInteger :: Integer -> a +instance ToIntegral Word32 Integer where + toIntegral = P.toInteger -instance FromInteger b => FromInteger (a -> b) where - fromInteger i _ = fromInteger i +instance ToIntegral Word64 Integer where + toIntegral = P.toInteger --- | coercion of 'Integral's +instance ToIntegral Int Int where + toIntegral = P.id + +instance ToIntegral Natural Natural where + toIntegral = P.id + +instance ToIntegral Int8 Int8 where + toIntegral = P.id + +instance ToIntegral Int16 Int16 where + toIntegral = P.id + +instance ToIntegral Int32 Int32 where + toIntegral = P.id + +instance ToIntegral Int64 Int64 where + toIntegral = P.id + +instance ToIntegral Word Word where + toIntegral = P.id + +instance ToIntegral Word8 Word8 where + toIntegral = P.id + +instance ToIntegral Word16 Word16 where + toIntegral = P.id + +instance ToIntegral Word32 Word32 where + toIntegral = P.id + +instance ToIntegral Word64 Word64 where + toIntegral = P.id + +-- | fromIntegral abstracts the codomain type, compared with the preludes Integral type. +-- > fromIntegral_ a == a -- --- > fromIntegral a == a -fromIntegral :: (ToInteger a, FromInteger b) => a -> b +-- fromIntegral is widely used as general coercion, hence the underscore for the operator. +class FromIntegral a b where + fromIntegral_ :: b -> a + default fromIntegral_ :: (a ~ b) => b -> a + fromIntegral_ = P.id + +-- | general coercion via Integer +fromIntegral :: (FromInteger b, ToInteger a) => a -> b fromIntegral = fromInteger . toInteger -instance FromInteger Double where - fromInteger = P.fromInteger +instance (FromIntegral a b) => FromIntegral (c -> a) b where + fromIntegral_ i _ = fromIntegral_ i -instance FromInteger Float where - fromInteger = P.fromInteger +instance FromIntegral Double Integer where + fromIntegral_ = P.fromInteger -instance FromInteger Int where - fromInteger = P.fromInteger +instance FromIntegral Float Integer where + fromIntegral_ = P.fromInteger -instance FromInteger Integer where - fromInteger = P.fromInteger +instance FromIntegral Int Integer where + fromIntegral_ = P.fromInteger -instance FromInteger Natural where - fromInteger = P.fromInteger +instance FromIntegral Integer Integer where + fromIntegral_ = P.id -instance FromInteger Int8 where - fromInteger = P.fromInteger +instance FromIntegral Natural Integer where + fromIntegral_ = P.fromInteger -instance FromInteger Int16 where - fromInteger = P.fromInteger +instance FromIntegral Int8 Integer where + fromIntegral_ = P.fromInteger -instance FromInteger Int32 where - fromInteger = P.fromInteger +instance FromIntegral Int16 Integer where + fromIntegral_ = P.fromInteger -instance FromInteger Int64 where - fromInteger = P.fromInteger +instance FromIntegral Int32 Integer where + fromIntegral_ = P.fromInteger -instance FromInteger Word where - fromInteger = P.fromInteger +instance FromIntegral Int64 Integer where + fromIntegral_ = P.fromInteger -instance FromInteger Word8 where - fromInteger = P.fromInteger +instance FromIntegral Word Integer where + fromIntegral_ = P.fromInteger -instance FromInteger Word16 where - fromInteger = P.fromInteger +instance FromIntegral Word8 Integer where + fromIntegral_ = P.fromInteger -instance FromInteger Word32 where - fromInteger = P.fromInteger +instance FromIntegral Word16 Integer where + fromIntegral_ = P.fromInteger -instance FromInteger Word64 where - fromInteger = P.fromInteger +instance FromIntegral Word32 Integer where + fromIntegral_ = P.fromInteger + +instance FromIntegral Word64 Integer where + fromIntegral_ = P.fromInteger + +instance FromIntegral Int Int where + fromIntegral_ = P.id + +instance FromIntegral Natural Natural where + fromIntegral_ = P.id + +instance FromIntegral Int8 Int8 where + fromIntegral_ = P.id + +instance FromIntegral Int16 Int16 where + fromIntegral_ = P.id + +instance FromIntegral Int32 Int32 where + fromIntegral_ = P.id + +instance FromIntegral Int64 Int64 where + fromIntegral_ = P.id + +instance FromIntegral Word Word where + fromIntegral_ = P.id + +instance FromIntegral Word8 Word8 where + fromIntegral_ = P.id + +instance FromIntegral Word16 Word16 where + fromIntegral_ = P.id + +instance FromIntegral Word32 Word32 where + fromIntegral_ = P.id + +instance FromIntegral Word64 Word64 where + fromIntegral_ = P.id + +-- | ghc defaulting rules and, it seems, -XExtendedDefaultRules do not permit multiple parameter typeclasses to be in the mix when types are resolved, hence the simpler `type FromInteger a = FromIntegral a Integer` does not suffice. +class FromInteger a where + fromInteger :: Integer -> a + default fromInteger :: (FromIntegral a Integer) => Integer -> a + fromInteger = fromIntegral_ + +instance FromInteger Integer +instance FromInteger Int +instance FromInteger Double +instance FromInteger Float +instance FromInteger Natural +instance FromInteger Int8 +instance FromInteger Int16 +instance FromInteger Int32 +instance FromInteger Int64 +instance FromInteger Word +instance FromInteger Word8 +instance FromInteger Word16 +instance FromInteger Word32 +instance FromInteger Word64 -- $operators diff --git a/src/NumHask/Data/LogField.hs b/src/NumHask/Data/LogField.hs --- a/src/NumHask/Data/LogField.hs +++ b/src/NumHask/Data/LogField.hs @@ -3,6 +3,8 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wall #-} @@ -31,7 +33,7 @@ import NumHask.Analysis.Metric import NumHask.Data.Integral import NumHask.Data.Rational -import Prelude hiding (Num(..), exp, log, negate, toInteger, isNaN) +import Prelude hiding (Num(..), exp, log, negate) import qualified Data.Foldable as F -- LogField is adapted from LogFloat @@ -124,7 +126,6 @@ {-# INLINE [0] logField #-} logField = LogField . log --- TODO: figure out what to do here, removed guards -- | Constructor which assumes the argument is already in the -- log-domain. logToLogField :: a -> LogField a @@ -205,16 +206,16 @@ log (LogField x) = LogField $ log x (**) x (LogField y) = pow x $ exp y -instance (FromInteger a, ExpField a) => FromInteger (LogField a) where - fromInteger = logField . fromInteger +instance (FromIntegral a b, ExpField a) => FromIntegral (LogField a) b where + fromIntegral_ = logField . fromIntegral_ -instance (ToInteger a, ExpField a) => ToInteger (LogField a) where - toInteger = toInteger . fromLogField +instance (ToIntegral a b, ExpField a) => ToIntegral (LogField a) b where + toIntegral = toIntegral . fromLogField -instance (FromRatio a, ExpField a) => FromRatio (LogField a) where +instance (FromRatio a b, ExpField a) => FromRatio (LogField a) b where fromRatio = logField . fromRatio -instance (ToRatio a, ExpField a) => ToRatio (LogField a) where +instance (ToRatio a b, ExpField a) => ToRatio (LogField a) b where toRatio = toRatio . fromLogField instance (Ord a) => JoinSemiLattice (LogField a) where @@ -238,8 +239,7 @@ IntegralDomain (LogField a) where instance (Ord a, ExpField a, LowerBoundedField a, UpperBoundedField a) => - UpperBoundedField (LogField a) where - isNaN (LogField a) = isNaN a + UpperBoundedField (LogField a) instance (Ord a, LowerBoundedField a, UpperBoundedField a, ExpField a) => Signed (LogField a) where @@ -248,8 +248,6 @@ | otherwise = one abs = id - - ---------------------------------------------------------------- -- | /O(1)/. Compute powers in the log-domain; that is, the following -- equivalence holds (modulo underflow and all that): @@ -306,38 +304,3 @@ t' = t + y c' = (t' - t) - y in (t', c') --- This version *completely* eliminates rounding errors and loss --- of significance due to catastrophic cancellation during summation. --- Also see the other --- implementations given there. For Python's actual C implementation, --- see math_fsum in --- --- --- For merely *mitigating* errors rather than completely eliminating --- them, see . --- --- A good test case is @msum([1, 1e100, 1, -1e100] * 10000) == 20000.0@ -{- --- For proof of correctness, see --- -def msum(xs): - partials = [] # sorted, non-overlapping partial sums - # N.B., the actual C implementation uses a 32 array, doubling size as needed - for x in xs: - i = 0 - for y in partials: # for(i = j = 0; j < n; j++) - if abs(x) < abs(y): - x, y = y, x - hi = x + y - lo = y - (hi - x) - if lo != 0.0: - partials[i] = lo - i += 1 - x = hi - # does an append of x while dropping all the partials after - # i. The C version does n=i; and leaves the garbage in place - partials[i:] = [x] - # BUG: this last step isn't entirely correct and can lose - # precision - return sum(partials, 0.0) --} diff --git a/src/NumHask/Data/Pair.hs b/src/NumHask/Data/Pair.hs --- a/src/NumHask/Data/Pair.hs +++ b/src/NumHask/Data/Pair.hs @@ -15,7 +15,7 @@ ) where import qualified Prelude as P -import Prelude (Foldable, Traversable, Applicative, Monad, Functor(..), Semigroup(..), Monoid(..), Bounded(..), Eq(..), (<$>), (<*>), (&&), (||)) +import Prelude (Foldable, Traversable, Applicative, Monad, Functor(..), Semigroup(..), Monoid(..), Bounded(..), Eq(..), (<$>), (<*>), (&&)) import GHC.Generics (Generic) import Data.Functor.Classes import NumHask.Algebra.Abstract @@ -168,8 +168,6 @@ log = unaryOp log instance (UpperBoundedField a) => UpperBoundedField (Pair a) - where - isNaN (Pair a b) = isNaN a || isNaN b instance (LowerBoundedField a) => LowerBoundedField (Pair a) @@ -200,10 +198,10 @@ instance (BoundedMeetSemiLattice a) => BoundedMeetSemiLattice (Pair a) where top = Pair top top -instance (FromInteger a) => FromInteger (Pair a) where - fromInteger x = P.pure (fromInteger x) +instance (FromIntegral a b) => FromIntegral (Pair a) b where + fromIntegral_ x = P.pure (fromIntegral_ x) -instance (FromRatio a) => FromRatio (Pair a) where +instance (FromRatio a b) => FromRatio (Pair a) b where fromRatio x = P.pure (fromRatio x) instance (Normed a a) => 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 @@ -66,7 +66,6 @@ instance (UpperBoundedField a) => UpperBoundedField (Positive a) where infinity = Positive infinity - isNaN (Positive a) = isNaN a instance (UpperBoundedField a) => P.Bounded (Positive a) where minBound = zero 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,6 +1,11 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wall #-} -- | Integral classes @@ -8,8 +13,13 @@ ( Ratio(..) , Rational , ToRatio(..) + , ToRational + , toRational , FromRatio(..) + , FromRational , fromRational + , fromRational' + , fromBaseRational -- * $integral_functionality , reduce , gcd @@ -28,7 +38,7 @@ import NumHask.Algebra.Abstract.Lattice import NumHask.Analysis.Metric import NumHask.Data.Integral -import Prelude (Double, Float, Int, Integer, (.)) +import Prelude (Double, Float, Int, Integer, Rational, (.)) import qualified GHC.Real import qualified Prelude as P @@ -47,10 +57,7 @@ | x P.== zero P.&& y P.== zero = P.True | P.otherwise = P.False - -type Rational = Ratio Integer - -instance (P.Ord a, Multiplicative a, Integral a) => P.Ord (Ratio a) where +instance (P.Ord a, Multiplicative a, Additive a) => P.Ord (Ratio a) where (x:%y) <= (x':%y') = x * y' P.<= x' * y (x:%y) < (x':%y') = x * y' P.< x' * y @@ -86,12 +93,11 @@ instance (GCDConstraints a) => Field (Ratio a) -instance (GCDConstraints a, GCDConstraints b, ToInteger a, Field a, FromInteger b) => QuotientField (Ratio a) b where - properFraction (n :% d) = let (w,r) = quotRem n d in (fromIntegral w,r:%d) +instance (GCDConstraints a, GCDConstraints b, ToInteger a, 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 (GCDConstraints a, Distributive a, IntegralDomain a) => - UpperBoundedField (Ratio a) where - isNaN (a :% b) = (a P.== zero) P.&& (b P.== zero) + UpperBoundedField (Ratio a) instance (GCDConstraints a, Field a) => LowerBoundedField (Ratio a) @@ -112,90 +118,112 @@ instance (GCDConstraints a, MeetSemiLattice a) => Epsilon (Ratio a) -instance (FromInteger a, Multiplicative a) => FromInteger (Ratio a) where - fromInteger x = fromInteger x :% one - --- | toRatio is equivalent to `Real` in base. -class ToRatio a where - toRatio :: a -> Ratio Integer +instance (FromIntegral a b, Multiplicative a) => FromIntegral (Ratio a) b where + fromIntegral_ x = fromIntegral_ x :% one -instance (ToInteger a) => ToRatio (Ratio a) where - toRatio (n :% d) = toInteger n :% toInteger d +-- | toRatio is equivalent to `Real` in base, but is polymorphic in the Integral type. +class ToRatio a b where + toRatio :: a -> Ratio b + default toRatio :: (Ratio c ~ a, ToIntegral c Integer, ToRatio (Ratio b) b, FromInteger b) => a -> Ratio b + toRatio (n :% d) = toRatio ((fromIntegral n :: b) :% fromIntegral d) --- | `Fractional` in base splits into fromRatio and Field -class FromRatio a where - fromRatio :: Ratio Integer -> a +type ToRational a = ToRatio a Integer -instance (FromInteger a) => FromRatio (Ratio a) where - fromRatio (n :% d) = fromInteger n :% fromInteger d +toRational :: (ToRatio a Integer) => a -> Ratio Integer +toRational = toRatio --- | coercion of 'Rational's --- --- > fromRational a == a -fromRational :: (ToRatio a, FromRatio b) => a -> b -fromRational = fromRatio . toRatio +instance ToRatio Double Integer where + toRatio = fromBaseRational . P.toRational --- | fixme: use coerce -fromBaseRational :: P.Rational -> Ratio Integer -fromBaseRational (n GHC.Real.:% d) = n :% d +instance ToRatio Float Integer where + toRatio = fromBaseRational . P.toRational -instance FromRatio Double where - fromRatio (n:%d)= rationalToDouble n d +instance ToRatio Rational Integer where + toRatio = fromBaseRational -instance FromRatio Float where - fromRatio (n:%d)= rationalToFloat n d +instance ToRatio (Ratio Integer) Integer where + toRatio = P.id -instance ToRatio Double where +instance ToRatio Int Integer where toRatio = fromBaseRational . P.toRational -instance ToRatio Float where +instance ToRatio Integer Integer where toRatio = fromBaseRational . P.toRational -instance ToRatio Int where +instance ToRatio Natural Integer where toRatio = fromBaseRational . P.toRational -instance ToRatio Integer where +instance ToRatio Int8 Integer where toRatio = fromBaseRational . P.toRational -instance ToRatio Natural where +instance ToRatio Int16 Integer where toRatio = fromBaseRational . P.toRational -instance ToRatio P.Rational where +instance ToRatio Int32 Integer where toRatio = fromBaseRational . P.toRational -instance ToRatio Int8 where +instance ToRatio Int64 Integer where toRatio = fromBaseRational . P.toRational -instance ToRatio Int16 where +instance ToRatio Word Integer where toRatio = fromBaseRational . P.toRational -instance ToRatio Int32 where +instance ToRatio Word8 Integer where toRatio = fromBaseRational . P.toRational -instance ToRatio Int64 where +instance ToRatio Word16 Integer where toRatio = fromBaseRational . P.toRational -instance ToRatio Word where +instance ToRatio Word32 Integer where toRatio = fromBaseRational . P.toRational -instance ToRatio Word8 where +instance ToRatio Word64 Integer where toRatio = fromBaseRational . P.toRational -instance ToRatio Word16 where - toRatio = fromBaseRational . P.toRational +-- | `Fractional` in base splits into fromRatio and Field +-- FIXME: work out why the default type isn't firing so that an explicit instance is needed +-- for `FromRatio (Ratio Integer) Integer` +class FromRatio a b where + fromRatio :: Ratio b -> a + -- default fromRatio :: (a ~ Ratio c, ToIntegral b c) => Ratio b -> a + -- fromRatio (n :% d) = toIntegral n :% toIntegral d + default fromRatio :: (Ratio b ~ a) => Ratio b -> a + fromRatio = P.id -instance ToRatio Word32 where - toRatio = fromBaseRational . P.toRational +fromBaseRational :: P.Rational -> Ratio Integer +fromBaseRational (n GHC.Real.:% d) = n :% d -instance ToRatio Word64 where - toRatio = fromBaseRational . P.toRational +instance FromRatio Double Integer where + fromRatio (n:%d)= rationalToDouble n d +instance FromRatio Float Integer where + fromRatio (n:%d)= rationalToFloat n d + +instance FromRatio Rational Integer where + fromRatio (n:%d) = n GHC.Real.% d + +instance FromRatio (Ratio Integer) Integer where + fromRatio = P.id + +-- | with RebindableSyntax the literal '1.0' mean exactly `fromRational (1.0::GHC.Real.Rational)`. +class FromRational a where + fromRational :: P.Rational -> a + default fromRational :: (FromRatio a Integer) => P.Rational -> a + fromRational = fromRatio . fromBaseRational + +instance FromRational Double +instance FromRational Float +instance FromRational Rational + +-- | Given that fromRational is reserved, fromRational' provides general conversion between numhask rationals. +fromRational' :: (FromRatio b Integer, ToRatio a Integer) => a -> b +fromRational' a = fromRatio (toRatio a :: Ratio Integer) + instance (GCDConstraints a) => JoinSemiLattice (Ratio a) where (\/) = P.min instance (GCDConstraints a) => MeetSemiLattice (Ratio a) where (/\) = P.max - -- * $integral_functions -- integral functionality is largely based on GHC.Real 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 @@ -12,6 +12,7 @@ import NumHask.Algebra.Abstract.Multiplicative import NumHask.Algebra.Abstract.Ring import NumHask.Algebra.Abstract.Lattice +import NumHask.Algebra.Abstract.Group import NumHask.Analysis.Metric import NumHask.Data.Integral import NumHask.Data.Rational @@ -22,26 +23,27 @@ ( P.Show , P.Eq , P.Ord + , Magma + , Idempotent , Additive , Subtractive , Multiplicative , Divisive , Distributive , IntegralDomain + , InvolutiveRing + , StarSemiring + , KleeneAlgebra , Field , ExpField , TrigField , Integral , Signed - , JoinSemiLattice , MeetSemiLattice + , JoinSemiLattice , Epsilon , UpperBoundedField , LowerBoundedField - , ToInteger - , FromInteger - , FromRatio - , ToRatio ) -- not sure if this is correct or needed @@ -51,3 +53,22 @@ QuotientField (Wrapped a) (Wrapped P.Integer) where properFraction (Wrapped a) = let (i,r) = properFraction a in (Wrapped i, Wrapped r) +instance (FromIntegral a b) => FromIntegral (Wrapped a) b where + fromIntegral_ a = Wrapped (fromIntegral_ a) + +instance (ToIntegral a b) => ToIntegral (Wrapped a) b where + toIntegral (Wrapped a) = toIntegral a + +instance (FromRatio a b) => FromRatio (Wrapped a) b where + fromRatio a = Wrapped (fromRatio a) + +instance (ToRatio a b) => ToRatio (Wrapped a) b where + toRatio (Wrapped a) = toRatio a + +instance (Normed a b) => Normed (Wrapped a) (Wrapped b) where + normL1 (Wrapped a) = Wrapped (normL1 a) + normL2 (Wrapped a) = Wrapped (normL2 a) + +instance (Metric a b) => Metric (Wrapped a) (Wrapped b) where + distanceL1 (Wrapped a) (Wrapped b) = Wrapped (distanceL1 a b) + distanceL2 (Wrapped a) (Wrapped b) = Wrapped (distanceL2 a b)