diff --git a/CHANGELOG.md b/CHANGELOG.md index 5b846154..b35ef72c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -39,8 +39,10 @@ vNext from RealFloat and IEEE for inspecting floating point quantities. * Added an `AEq` instance for `Quantity`. * Added `Eq1` and `Ord1` instances for `Quantity`. +* Added `Eq` and `Eq1` instances for `Unit`. * Exposed the name of an 'AnyUnit' without promoting it to a 'Unit' first. * Exposed a way to convert atomic 'UnitName's back into 'NameAtom's. +* Added dynamic selection of metric prefixes based on the magnitude of a quantity to be displayed. * Added the `btu`, a unit of energy. * Added the `gauss`, a unit of magnetic flux density. * Added the `angstrom`, a unit of length. diff --git a/src/Numeric/Units/Dimensional/Internal.hs b/src/Numeric/Units/Dimensional/Internal.hs index a3ea17ef..20b6214c 100644 --- a/src/Numeric/Units/Dimensional/Internal.hs +++ b/src/Numeric/Units/Dimensional/Internal.hs @@ -50,8 +50,8 @@ import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed.Base as U import Prelude ( Show, Eq(..), Ord, Bounded(..), Num, Fractional, Functor, Real(..) - , String, Maybe(..), Double - , (.), ($), (++), (+), (/) + , String, Maybe(..), Double, Bool(..) + , (.), ($), (++), (+), (/), (&&) , show, otherwise, undefined, error, fmap, realToFrac ) import qualified Prelude as P @@ -131,6 +131,18 @@ instance Ord1 (SQuantity s d) where liftCompare = coerce #endif +instance (Eq a) => Eq (Unit m d a) where + (==) = areEqualUnitsBy (==) + +#if MIN_VERSION_base(4,9,0) +instance Eq1 (Unit m d) where + liftEq = areEqualUnitsBy +#endif + +-- define this here so that it is usable even when we are not conditionally compiling a Eq1 instance to define the Eq instance +areEqualUnitsBy :: (a -> b -> Bool) -> Unit m d a -> Unit m d b -> Bool +areEqualUnitsBy f (Unit n1 e1 x1) (Unit n2 e2 x2) = n1 == n2 && areExactlyEqual e1 e2 && f x1 x2 + instance HasInterchangeName (Unit m d a) where interchangeName (Unit n _ _) = interchangeName n diff --git a/src/Numeric/Units/Dimensional/SIUnits.hs b/src/Numeric/Units/Dimensional/SIUnits.hs index 8535d75c..e4236960 100644 --- a/src/Numeric/Units/Dimensional/SIUnits.hs +++ b/src/Numeric/Units/Dimensional/SIUnits.hs @@ -57,19 +57,19 @@ module Numeric.Units.Dimensional.SIUnits -- $submultiples deci, centi, milli, micro, nano, pico, femto, atto, zepto, yocto, -- $reified-prefixes - Prefix, applyPrefix, siPrefixes + Prefix, applyPrefix, siPrefixes, appropriatePrefix, withAppropriatePrefix, appropriatePrefix', withAppropriatePrefix' ) where import Data.Ratio import Numeric.Units.Dimensional import Numeric.Units.Dimensional.Quantities -import Numeric.Units.Dimensional.UnitNames (Prefix, siPrefixes) +import Numeric.Units.Dimensional.UnitNames (Prefix, PrefixSet, siPrefixes, selectPrefix) import qualified Numeric.Units.Dimensional.UnitNames as N import Numeric.Units.Dimensional.UnitNames.Internal (ucum, ucumMetric) import qualified Numeric.Units.Dimensional.UnitNames.Internal as I import Numeric.NumType.DK.Integers ( pos3 ) -import Prelude ( Eq(..), ($), Num, Fractional, Floating, otherwise, error) +import Prelude ( Eq(..), ($), Num, Fractional, Floating, RealFrac(..), otherwise, error) import qualified Prelude {- $multiples @@ -109,6 +109,7 @@ yotta = applyMultiple I.yotta Then the submultiples. -} +-- | Applies a 'Prefix' to a 'Metric' 'Unit', creating a 'NonMetric' unit. applyPrefix :: (Fractional a) => Prefix -> Unit 'Metric d a -> Unit 'NonMetric d a applyPrefix p u = mkUnitQ n' x u where @@ -135,6 +136,49 @@ list of all prefixes defined by the SI. -} +-- | Selects the appropriate 'Prefix' to use with a 'Metric' unit when using it to display +-- a particular 'Quantity', or 'Nothing' if the supplied unit should be used without a prefix. +-- +-- The appropriate prefix is defined to be the largest SI prefix such that the resulting value +-- of the quantity, expressed in the prefixed unit, is greater than or equal to one. +-- +-- Note that the supplied unit need not be 'Metric'. This is intended for use to compute a prefix to insert +-- somewhere in the denominator of a composite (and hence 'NonMetric') unit. +appropriatePrefix :: (Floating a, RealFrac a) => Unit m d a -> Quantity d a -> Prefix +appropriatePrefix = appropriatePrefix' siPrefixes + +-- | Selects the appropriate 'Prefix' to use with a 'Metric' unit when using it to display +-- a particular 'Quantity', or 'Nothing' if the supplied unit should be used without a prefix. +-- +-- The appropriate prefix is defined to be the largest prefix in the supplied 'PrefixSet' such that the resulting value +-- of the quantity, expressed in the prefixed unit, is greater than or equal to one. Only those prefixes +-- whose 'scaleExponent' is a multiple of @3@ are considered. +-- +-- Note that the supplied unit need not be 'Metric'. This is intended for use to compute a prefix to insert +-- somewhere in the denominator of a composite (and hence 'NonMetric') unit. +appropriatePrefix' :: (Floating a, RealFrac a) => PrefixSet -> Unit m d a -> Quantity d a -> Prefix +appropriatePrefix' ps u q = selectPrefix ps e + where + val = abs q /~ u + e = Prelude.floor $ Prelude.logBase 10 val :: Prelude.Int + +-- | Constructs a version of a 'Metric' unit, by possibly applying a 'Prefix' to it, appropriate +-- for display of a particular 'Quantity'. +-- +-- The appropriate prefix is defined to be the largest SI prefix such that the resulting value +-- of the quantity, expressed in the prefixed unit, is greater than or equal to one. +withAppropriatePrefix :: (Floating a, RealFrac a) => Unit 'Metric d a -> Quantity d a -> Unit 'NonMetric d a +withAppropriatePrefix = withAppropriatePrefix' siPrefixes + +-- | Constructs a version of a 'Metric' unit, by possibly applying a 'Prefix' to it, appropriate +-- for display of a particular 'Quantity'. +-- +-- The appropriate prefix is defined to be the largest prefix in the supplied 'PrefixSet' such that the resulting value +-- of the quantity, expressed in the prefixed unit, is greater than or equal to one. Only those prefixes +-- whose 'scaleExponent' is a multiple of @3@ are considered. +withAppropriatePrefix' :: (Floating a, RealFrac a) => PrefixSet -> Unit 'Metric d a -> Quantity d a -> Unit 'NonMetric d a +withAppropriatePrefix' ps u q = applyPrefix (appropriatePrefix' ps u q) u + {- $base-units These are the base units from section 4.1. To avoid a myriad of one-letter functions that would doubtlessly cause clashes diff --git a/src/Numeric/Units/Dimensional/UnitNames.hs b/src/Numeric/Units/Dimensional/UnitNames.hs index b2cf9fd7..a7d7b671 100644 --- a/src/Numeric/Units/Dimensional/UnitNames.hs +++ b/src/Numeric/Units/Dimensional/UnitNames.hs @@ -21,9 +21,11 @@ module Numeric.Units.Dimensional.UnitNames -- * Construction of Unit Names atom, applyPrefix, (*), (/), (^), product, reduce, grouped, -- * Standard Names - baseUnitName, siPrefixes, nOne, + baseUnitName, nOne, -- * Inspecting Prefixes - prefixName, scaleFactor, + prefixName, scaleExponent, scaleFactor, + -- * Sets of Prefixes + PrefixSet, prefixSet, unPrefixSet, filterPrefixSet, selectPrefix, siPrefixes, majorSiPrefixes, -- * Convenience Type Synonyms for Unit Name Transformations UnitNameTransformer, UnitNameTransformer2, -- * Forgetting Unwanted Phantom Types @@ -35,3 +37,6 @@ where import Numeric.Units.Dimensional.UnitNames.Internal import Numeric.Units.Dimensional.Variants import Prelude hiding ((*), (/), (^), product) + +scaleFactor :: Prefix -> Rational +scaleFactor p = 10 ^^ (scaleExponent p) diff --git a/src/Numeric/Units/Dimensional/UnitNames/Internal.hs b/src/Numeric/Units/Dimensional/UnitNames/Internal.hs index 9f8d00dd..f0b883e0 100644 --- a/src/Numeric/Units/Dimensional/UnitNames/Internal.hs +++ b/src/Numeric/Units/Dimensional/UnitNames/Internal.hs @@ -25,6 +25,8 @@ import Data.Foldable (toList) #else import Data.Foldable (Foldable, toList) #endif +import Data.Function (on) +import Data.List (sortBy, nubBy) import Data.Ord import GHC.Generics hiding (Prefix) import Numeric.Units.Dimensional.Dimensions.TermLevel (Dimension', asList, HasDimension(..)) @@ -139,20 +141,17 @@ type PrefixName = NameAtom 'PrefixAtom data Prefix = Prefix { -- | The name of a metric prefix. - prefixName :: PrefixName, + prefixName :: Maybe PrefixName, -- | The scale factor denoted by a metric prefix. - scaleFactor :: Rational + scaleExponent :: Int } deriving (Eq, Data, Typeable, Generic) instance Ord Prefix where - compare = comparing scaleFactor + compare = comparing scaleExponent instance NFData Prefix where -- instance is derived from Generic instance -instance HasInterchangeName Prefix where - interchangeName = interchangeName . prefixName - -- | The name of the unit of dimensionless values. nOne :: UnitName 'NonMetric nOne = One @@ -189,36 +188,76 @@ baseUnitName d = let powers = asList $ dimension d baseUnitNames :: [UnitName 'NonMetric] baseUnitNames = [weaken nMeter, nKilogram, weaken nSecond, weaken nAmpere, weaken nKelvin, weaken nMole, weaken nCandela] +-- | This is the SI 'Prefix' that is no prefix at all, and that consequently doesn't alter the value of the base unit to +-- which it is applied. +emptyPrefix :: Prefix +emptyPrefix = Prefix Nothing 0 + deka, hecto, kilo, mega, giga, tera, peta, exa, zetta, yotta :: Prefix -deka = prefix "da" "da" "deka" 1e1 -hecto = prefix "h" "h" "hecto" 1e2 -kilo = prefix "k" "k" "kilo" 1e3 -mega = prefix "M" "M" "mega" 1e6 -giga = prefix "G" "G" "giga" 1e9 -tera = prefix "T" "T" "tera" 1e12 -peta = prefix "P" "P" "peta" 1e15 -exa = prefix "E" "E" "exa" 1e18 -zetta = prefix "Z" "Z" "zetta" 1e21 -yotta = prefix "Y" "Y" "yotta" 1e24 +deka = prefix "da" "da" "deka" 1 +hecto = prefix "h" "h" "hecto" 2 +kilo = prefix "k" "k" "kilo" 3 +mega = prefix "M" "M" "mega" 6 +giga = prefix "G" "G" "giga" 9 +tera = prefix "T" "T" "tera" 12 +peta = prefix "P" "P" "peta" 15 +exa = prefix "E" "E" "exa" 18 +zetta = prefix "Z" "Z" "zetta" 21 +yotta = prefix "Y" "Y" "yotta" 24 deci, centi, milli, micro, nano, pico, femto, atto, zepto, yocto :: Prefix -deci = prefix "d" "d" "deci" 1e-1 -centi = prefix "c" "c" "centi" 1e-2 -milli = prefix "m" "m" "milli" 1e-3 -micro = prefix "u" "μ" "micro" 1e-6 -nano = prefix "n" "n" "nano" 1e-9 -pico = prefix "p" "p" "pico" 1e-12 -femto = prefix "f" "f" "femto" 1e-15 -atto = prefix "a" "a" "atto" 1e-18 -zepto = prefix "z" "z" "zepto" 1e-21 -yocto = prefix "y" "y" "yocto" 1e-24 - --- | A list of all 'Prefix'es defined by the SI. -siPrefixes :: [Prefix] -siPrefixes = [yocto, zepto, atto, femto, pico, nano, micro, milli, centi, deci, deka, hecto, kilo, mega, giga, tera, peta, exa, zetta, yotta] +deci = prefix "d" "d" "deci" $ -1 +centi = prefix "c" "c" "centi" $ -2 +milli = prefix "m" "m" "milli" $ -3 +micro = prefix "u" "μ" "micro" $ -6 +nano = prefix "n" "n" "nano" $ -9 +pico = prefix "p" "p" "pico" $ -12 +femto = prefix "f" "f" "femto" $ -15 +atto = prefix "a" "a" "atto" $ -18 +zepto = prefix "z" "z" "zepto" $ -21 +yocto = prefix "y" "y" "yocto" $ -24 + +-- | A set of 'Prefix'es which necessarily includes the 'emptyPrefix'. +newtype PrefixSet = PrefixSet { unPrefixSet :: [Prefix] } + deriving (Eq, Data, Typeable) + +-- | Constructs a 'PrefixSet' from a list of 'Prefix'es by ensuring that the 'emptyPrefix' is present, +-- removing duplicates, and sorting the prefixes. +prefixSet :: [Prefix] -> PrefixSet +prefixSet = PrefixSet . sortBy (comparing $ Down . scaleExponent) . nubBy ((==) `on` scaleExponent) . (emptyPrefix :) + +-- | Filters a 'PrefixSet', retaining only those 'Prefix'es which match a supplied predicate. +-- +-- The 'emptyPrefix' is always retained, as it must be a member of every 'PrefixSet'. +filterPrefixSet :: (Prefix -> Bool) -> PrefixSet -> PrefixSet +filterPrefixSet p = prefixSet . filter p . unPrefixSet + +-- | Chooses a 'Prefix' from a 'PrefixSet', given a scale exponent. The resulting prefix will be that in the prefix set +-- whose 'scaleExponent' is least, while still greater than the supplied scale exponent. If no prefix in the set has a +-- 'scaleExponent' greater than the supplied scale exponent, then the member with the least 'scaleExponent' will be returned. +selectPrefix :: PrefixSet -> Int -> Prefix +selectPrefix ps e = go ((<= e) . scaleExponent) ps' + where + go _ (x:[]) = x + go f (x:xs) | f x = x + | otherwise = go f xs + go _ _ = emptyPrefix + ps' = unPrefixSet ps + +-- | The set of all 'Prefix'es defined by the SI. +siPrefixes :: PrefixSet +siPrefixes = prefixSet [yocto, zepto, atto, femto, pico, nano, micro, milli, centi, deci, deka, hecto, kilo, mega, giga, tera, peta, exa, zetta, yotta] + +-- | The set of all major 'Prefix'es defined by the SI. +-- +-- A major prefix is one whose scale exponent is a multiple of three. +majorSiPrefixes :: PrefixSet +majorSiPrefixes = filterPrefixSet ((== 0) . (`mod` 3) . scaleExponent) siPrefixes -- | Forms a 'UnitName' from a 'Metric' name by applying a metric prefix. applyPrefix :: Prefix -> UnitName 'Metric -> UnitName 'NonMetric -applyPrefix = Prefixed . prefixName +applyPrefix p = case prefixName p of + Just n -> Prefixed n + Nothing -> Weaken {- We will reuse the operators and function names from the Prelude. @@ -319,10 +358,10 @@ instance HasInterchangeName (UnitName m) where in InterchangeName { name = n', authority = authority . interchangeName $ n, I.isAtomic = False } interchangeName (Weaken n) = interchangeName n -prefix :: String -> String -> String -> Rational -> Prefix +prefix :: String -> String -> String -> Int -> Prefix prefix i a f q = Prefix n q where - n = NameAtom (InterchangeName i UCUM True) a f + n = Just $ NameAtom (InterchangeName i UCUM True) a f ucumMetric :: String -> String -> String -> UnitName 'Metric ucumMetric i a f = MetricAtomic $ NameAtom (InterchangeName i UCUM True) a f diff --git a/tests/Numeric/Units/Dimensional/SIUnitsSpec.hs b/tests/Numeric/Units/Dimensional/SIUnitsSpec.hs new file mode 100644 index 00000000..90ac7376 --- /dev/null +++ b/tests/Numeric/Units/Dimensional/SIUnitsSpec.hs @@ -0,0 +1,18 @@ +module Numeric.Units.Dimensional.SIUnitsSpec where + +import Numeric.Units.Dimensional.Prelude +import Test.Hspec + +spec :: Spec +spec = do + describe "Dynamic prefix selection" $ do + it "selects no prefix when appropriate" $ do + withAppropriatePrefix meter ((1.3 :: Double) *~ meter) `shouldBe` weaken meter + it "selects kilo as a prefix when appropriate" $ do + withAppropriatePrefix newton ((-1742.1 :: Double) *~ newton) `shouldBe` kilo newton + it "selects yotta as a prefix when appropriate" $ do + withAppropriatePrefix gram ((875 :: Double) *~ yotta gram) `shouldBe` yotta gram + it "selects atto as a prefix when appropriate" $ do + withAppropriatePrefix second ((85.4 :: Double) *~ atto second) `shouldBe` atto second + it "selects yocto as a prefix when appropriate" $ do + withAppropriatePrefix watt ((1e-7 :: Double) *~ yocto watt) `shouldBe` yocto watt