From 67e42f9da90822b4bfe18f0020a287141defb63d Mon Sep 17 00:00:00 2001 From: Douglas McClean Date: Thu, 14 Jul 2016 14:43:30 -0400 Subject: [PATCH] Added dynamic prefix selection. Fixes #163. --- src/Numeric/Units/Dimensional/SIUnits.hs | 63 ++++++++++++++++++- src/Numeric/Units/Dimensional/UnitNames.hs | 5 +- .../Units/Dimensional/UnitNames/Internal.hs | 46 +++++++------- 3 files changed, 87 insertions(+), 27 deletions(-) diff --git a/src/Numeric/Units/Dimensional/SIUnits.hs b/src/Numeric/Units/Dimensional/SIUnits.hs index 8535d75c..603f852b 100644 --- a/src/Numeric/Units/Dimensional/SIUnits.hs +++ b/src/Numeric/Units/Dimensional/SIUnits.hs @@ -57,19 +57,22 @@ module Numeric.Units.Dimensional.SIUnits -- $submultiples deci, centi, milli, micro, nano, pico, femto, atto, zepto, yocto, -- $reified-prefixes - Prefix, applyPrefix, siPrefixes + Prefix, applyPrefix, applyOptionalPrefix, siPrefixes, appropriatePrefix, withAppropriatePrefix, appropriatePrefix', withAppropriatePrefix' ) where +import Control.Monad (join) import Data.Ratio +import Data.List (sortBy, find) +import Data.Ord (comparing, Down(..)) import Numeric.Units.Dimensional import Numeric.Units.Dimensional.Quantities -import Numeric.Units.Dimensional.UnitNames (Prefix, siPrefixes) +import Numeric.Units.Dimensional.UnitNames (Prefix, siPrefixes, scaleExponent) 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(..), Maybe(..), otherwise, error, Ord(..), fst, snd, Int, Bool, fmap, mod, (&&)) import qualified Prelude {- $multiples @@ -109,12 +112,18 @@ 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 n' = N.applyPrefix p (name u) x = N.scaleFactor p +-- | Applies an optional 'Prefix' to a 'Metric' 'Unit', creating a 'NonMetric' unit. +applyOptionalPrefix :: (Fractional a) => Maybe Prefix -> Unit 'Metric d a -> Unit 'NonMetric d a +applyOptionalPrefix Nothing = weaken +applyOptionalPrefix (Just p) = applyPrefix p + deci, centi, milli, micro, nano, pico, femto, atto, zepto, yocto :: Fractional a => Unit 'Metric d a -> Unit 'NonMetric d a deci = applyPrefix I.deci @@ -135,6 +144,54 @@ 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 prefix such that the resulting value +-- of the quantity, expressed in the prefixed unit, is greater than or equal to one. +appropriatePrefix :: (Floating a, RealFrac a) => Unit 'Metric d a -> Quantity d a -> Maybe Prefix +appropriatePrefix u q = selectPrefix (<= e) + where + val = q /~ u + e = Prelude.floor $ Prelude.logBase 10 val :: Prelude.Int + +-- | 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 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. +appropriatePrefix' :: (Floating a, RealFrac a) => Unit 'Metric d a -> Quantity d a -> Maybe Prefix +appropriatePrefix' u q = selectPrefix (\x -> x `mod` 3 == 0 && x <= e) + where + val = q /~ u + e = Prelude.floor $ Prelude.logBase 10 val :: Prelude.Int + +-- Selects the first prefix in the list of prefix candidates whose scale exponent matches the supplied predicate. +selectPrefix :: (Int -> Bool) -> Maybe Prefix +selectPrefix p = join $ fmap snd $ find (p . fst) prefixCandidates + +-- This is a list of candidate prefixes and the least scale exponent at which each applies. +prefixCandidates :: [(Int, Maybe Prefix)] +prefixCandidates = sortBy (comparing $ Down . fst) $ (0, Nothing) : fmap (\x -> (scaleExponent x, Just x)) 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 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 u q = applyOptionalPrefix (appropriatePrefix u q) u + +-- | 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 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) => Unit 'Metric d a -> Quantity d a -> Unit 'NonMetric d a +withAppropriatePrefix' u q = applyOptionalPrefix (appropriatePrefix' 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..a5f894e0 100644 --- a/src/Numeric/Units/Dimensional/UnitNames.hs +++ b/src/Numeric/Units/Dimensional/UnitNames.hs @@ -23,7 +23,7 @@ module Numeric.Units.Dimensional.UnitNames -- * Standard Names baseUnitName, siPrefixes, nOne, -- * Inspecting Prefixes - prefixName, scaleFactor, + prefixName, scaleExponent, scaleFactor, -- * Convenience Type Synonyms for Unit Name Transformations UnitNameTransformer, UnitNameTransformer2, -- * Forgetting Unwanted Phantom Types @@ -35,3 +35,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..0128d4fa 100644 --- a/src/Numeric/Units/Dimensional/UnitNames/Internal.hs +++ b/src/Numeric/Units/Dimensional/UnitNames/Internal.hs @@ -141,12 +141,12 @@ data Prefix = Prefix -- | The name of a metric prefix. prefixName :: 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 @@ -190,27 +190,27 @@ baseUnitNames :: [UnitName 'NonMetric] baseUnitNames = [weaken nMeter, nKilogram, weaken nSecond, weaken nAmpere, weaken nKelvin, weaken nMole, weaken nCandela] 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 +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 list of all 'Prefix'es defined by the SI. siPrefixes :: [Prefix] @@ -319,7 +319,7 @@ 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