Dynamic prefix selection

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.

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
 

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

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)

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

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