{-# LANGUAGE RebindableSyntax #-}
{- |
Tools for creating a data base of physical units
and for extracting data from it
-}

module Number.Physical.UnitDatabase where

import qualified Number.Physical.Unit as Unit
import qualified Algebra.Field as Field

import Algebra.NormedSpace.Sum(norm)

import Data.Maybe.HT (toMaybe)
import Data.List (findIndices, partition, unfoldr, find, minimumBy)

import NumericPrelude.Base
import NumericPrelude.Numeric

type T i a = [UnitSet i a]

-- since field names are reused for accessor functions
-- they are global identifiers and can't be reused
data InitUnitSet i a =
  InitUnitSet {
    InitUnitSet i a -> T i
initUnit        :: Unit.T i,
    InitUnitSet i a -> Bool
initIndependent :: Bool,
    InitUnitSet i a -> [InitScale a]
initScales      :: [InitScale a]
  }

data InitScale a =
  InitScale {
    InitScale a -> String
initSymbol  :: String,
    InitScale a -> a
initMag     :: a,
    InitScale a -> Bool
initIsUnit  :: Bool,
    InitScale a -> Bool
initDefault :: Bool
  }

-- | An entry for a unit and there scalings.
data UnitSet i a =
  UnitSet {
    UnitSet i a -> T i
unit        :: Unit.T i,
    UnitSet i a -> Bool
independent :: Bool,
    UnitSet i a -> Int
defScaleIx  :: Int,
    UnitSet i a -> Bool
reciprocal  :: Bool,  {-^ If True the symbols must be preceded with a '/'.
                              Though it sounds like an attribute of Scale
                              it must be the same for all scales and we need it
                              to sort positive powered unitsets to the front
                              of the list of unit components. -}
    UnitSet i a -> [Scale a]
scales      :: [Scale a]
  }
  deriving Int -> UnitSet i a -> ShowS
[UnitSet i a] -> ShowS
UnitSet i a -> String
(Int -> UnitSet i a -> ShowS)
-> (UnitSet i a -> String)
-> ([UnitSet i a] -> ShowS)
-> Show (UnitSet i a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall i a. (Show i, Show a) => Int -> UnitSet i a -> ShowS
forall i a. (Show i, Show a) => [UnitSet i a] -> ShowS
forall i a. (Show i, Show a) => UnitSet i a -> String
showList :: [UnitSet i a] -> ShowS
$cshowList :: forall i a. (Show i, Show a) => [UnitSet i a] -> ShowS
show :: UnitSet i a -> String
$cshow :: forall i a. (Show i, Show a) => UnitSet i a -> String
showsPrec :: Int -> UnitSet i a -> ShowS
$cshowsPrec :: forall i a. (Show i, Show a) => Int -> UnitSet i a -> ShowS
Show

-- | A common scaling for a unit.
data Scale a =
  Scale {
    Scale a -> String
symbol     :: String,
    Scale a -> a
magnitude  :: a
  }
  deriving Int -> Scale a -> ShowS
[Scale a] -> ShowS
Scale a -> String
(Int -> Scale a -> ShowS)
-> (Scale a -> String) -> ([Scale a] -> ShowS) -> Show (Scale a)
forall a. Show a => Int -> Scale a -> ShowS
forall a. Show a => [Scale a] -> ShowS
forall a. Show a => Scale a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Scale a] -> ShowS
$cshowList :: forall a. Show a => [Scale a] -> ShowS
show :: Scale a -> String
$cshow :: forall a. Show a => Scale a -> String
showsPrec :: Int -> Scale a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Scale a -> ShowS
Show


-- extract the element from a list containing exact one element
-- fails if there are zero or more than one element
-- 'head' fails only if there are zero elements
extractOne :: [a] -> a
extractOne :: [a] -> a
extractOne (a
x:[]) = a
x
extractOne [a]
_      = String -> a
forall a. HasCallStack => String -> a
error String
"There must be exactly one default unit in the data base."

initScale   :: String -> a -> Bool -> Bool -> InitScale a
initScale :: String -> a -> Bool -> Bool -> InitScale a
initScale   = String -> a -> Bool -> Bool -> InitScale a
forall a. String -> a -> Bool -> Bool -> InitScale a
InitScale
initUnitSet :: Unit.T i -> Bool -> [InitScale a] -> InitUnitSet i a
initUnitSet :: T i -> Bool -> [InitScale a] -> InitUnitSet i a
initUnitSet = T i -> Bool -> [InitScale a] -> InitUnitSet i a
forall i a. T i -> Bool -> [InitScale a] -> InitUnitSet i a
InitUnitSet

createScale :: InitScale a -> Scale a
createScale :: InitScale a -> Scale a
createScale (InitScale String
sym a
mg Bool
_ Bool
_) = (String -> a -> Scale a
forall a. String -> a -> Scale a
Scale String
sym a
mg)

createUnitSet :: InitUnitSet i a -> UnitSet i a
createUnitSet :: InitUnitSet i a -> UnitSet i a
createUnitSet (InitUnitSet T i
u Bool
ind [InitScale a]
scs) = (T i -> Bool -> Int -> Bool -> [Scale a] -> UnitSet i a
forall i a. T i -> Bool -> Int -> Bool -> [Scale a] -> UnitSet i a
UnitSet T i
u Bool
ind
    ([Int] -> Int
forall a. [a] -> a
extractOne ((InitScale a -> Bool) -> [InitScale a] -> [Int]
forall a. (a -> Bool) -> [a] -> [Int]
findIndices InitScale a -> Bool
forall a. InitScale a -> Bool
initDefault [InitScale a]
scs))
    Bool
False
    ((InitScale a -> Scale a) -> [InitScale a] -> [Scale a]
forall a b. (a -> b) -> [a] -> [b]
map InitScale a -> Scale a
forall a. InitScale a -> Scale a
createScale [InitScale a]
scs)
  )

{- Filter out all scales intended for showing.
   If there is none return Nothing. -}
showableUnit :: InitUnitSet i a -> Maybe (InitUnitSet i a)
showableUnit :: InitUnitSet i a -> Maybe (InitUnitSet i a)
showableUnit (InitUnitSet T i
u Bool
ind [InitScale a]
scs) =
   let sscs :: [InitScale a]
sscs = (InitScale a -> Bool) -> [InitScale a] -> [InitScale a]
forall a. (a -> Bool) -> [a] -> [a]
filter InitScale a -> Bool
forall a. InitScale a -> Bool
initIsUnit [InitScale a]
scs
   in  Bool -> InitUnitSet i a -> Maybe (InitUnitSet i a)
forall a. Bool -> a -> Maybe a
toMaybe (Bool -> Bool
not ([InitScale a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InitScale a]
sscs)) (T i -> Bool -> [InitScale a] -> InitUnitSet i a
forall i a. T i -> Bool -> [InitScale a] -> InitUnitSet i a
InitUnitSet T i
u Bool
ind [InitScale a]
sscs)


{- | Raise all scales of a unit and the unit itself to the n-th power -}
powerOfUnitSet :: (Ord i, Field.C a) => Int -> UnitSet i a -> UnitSet i a
powerOfUnitSet :: Int -> UnitSet i a -> UnitSet i a
powerOfUnitSet Int
n us :: UnitSet i a
us@UnitSet { unit :: forall i a. UnitSet i a -> T i
unit = T i
u, reciprocal :: forall i a. UnitSet i a -> Bool
reciprocal = Bool
rec, scales :: forall i a. UnitSet i a -> [Scale a]
scales = [Scale a]
scs } =
   UnitSet i a
us { unit :: T i
unit = Int
n Int -> T i -> T i
forall a v. C a v => a -> v -> v
*> T i
u,
        reciprocal :: Bool
reciprocal = Bool
rec Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0),  -- flip sign
        scales :: [Scale a]
scales = (Scale a -> Scale a) -> [Scale a] -> [Scale a]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Scale a -> Scale a
forall a. C a => Int -> Scale a -> Scale a
powerOfScale Int
n) [Scale a]
scs }


powerOfScale :: Field.C a => Int -> Scale a -> Scale a
powerOfScale :: Int -> Scale a -> Scale a
powerOfScale Int
n Scale { symbol :: forall a. Scale a -> String
symbol = String
sym, magnitude :: forall a. Scale a -> a
magnitude = a
mag } =
   if Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0
   then Scale :: forall a. String -> a -> Scale a
Scale { symbol :: String
symbol = String
sym String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
showExp   Int
n,  magnitude :: a
magnitude = Int -> a -> a
forall a b. (C a, C b) => b -> a -> a
ringPower  Int
n a
mag }
   else Scale :: forall a. String -> a -> Scale a
Scale { symbol :: String
symbol = String
sym String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
showExp (-Int
n), magnitude :: a
magnitude = Int -> a -> a
forall a b. (C a, C b) => b -> a -> a
fieldPower Int
n a
mag }

showExp :: Int -> String
showExp :: Int -> String
showExp Int
1    = String
""
--showExp 2    = "²"
--showExp 3    = "³"
showExp Int
expo = String
"^" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
expo


{- | Reorder the unit components in a way
     that the units with positive exponents lead the list. -}
positiveToFront :: [UnitSet i a] -> [UnitSet i a]
positiveToFront :: [UnitSet i a] -> [UnitSet i a]
positiveToFront = ([UnitSet i a] -> [UnitSet i a] -> [UnitSet i a])
-> ([UnitSet i a], [UnitSet i a]) -> [UnitSet i a]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [UnitSet i a] -> [UnitSet i a] -> [UnitSet i a]
forall a. [a] -> [a] -> [a]
(++) (([UnitSet i a], [UnitSet i a]) -> [UnitSet i a])
-> ([UnitSet i a] -> ([UnitSet i a], [UnitSet i a]))
-> [UnitSet i a]
-> [UnitSet i a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitSet i a -> Bool)
-> [UnitSet i a] -> ([UnitSet i a], [UnitSet i a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Bool -> Bool
not (Bool -> Bool) -> (UnitSet i a -> Bool) -> UnitSet i a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitSet i a -> Bool
forall i a. UnitSet i a -> Bool
reciprocal)

-- | Decompose a complex unit into common ones
decompose :: (Ord i, Field.C a) => Unit.T i -> T i a -> [UnitSet i a]
decompose :: T i -> T i a -> T i a
decompose T i
u T i a
db =
   case (T i -> T i a -> Maybe (UnitSet i a)
forall i a. Eq i => T i -> T i a -> Maybe (UnitSet i a)
findIndep T i
u T i a
db) of
      Just UnitSet i a
us -> [UnitSet i a
us]
      Maybe (UnitSet i a)
Nothing ->
        (T i -> Maybe (UnitSet i a, T i)) -> T i -> T i a
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (\T i
urem ->
          Bool -> (UnitSet i a, T i) -> Maybe (UnitSet i a, T i)
forall a. Bool -> a -> Maybe a
toMaybe (Bool -> Bool
not (T i -> Bool
forall i. T i -> Bool
Unit.isScalar T i
urem))
                  (let us :: UnitSet i a
us = T i -> T i a -> UnitSet i a
forall i a. (Ord i, C a) => T i -> T i a -> UnitSet i a
findClosest T i
urem T i a
db
                   in  (UnitSet i a
us, T i -> T i -> T i
forall a. C a => a -> a -> a
subtract (UnitSet i a -> T i
forall i a. UnitSet i a -> T i
unit UnitSet i a
us) T i
urem))
        ) T i
u

findIndep :: (Eq i) => Unit.T i -> T i a -> Maybe (UnitSet i a)
findIndep :: T i -> T i a -> Maybe (UnitSet i a)
findIndep T i
u = (UnitSet i a -> Bool) -> T i a -> Maybe (UnitSet i a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\UnitSet {unit :: forall i a. UnitSet i a -> T i
unit=T i
un} -> T i
uT i -> T i -> Bool
forall a. Eq a => a -> a -> Bool
==T i
un) (T i a -> Maybe (UnitSet i a))
-> (T i a -> T i a) -> T i a -> Maybe (UnitSet i a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitSet i a -> Bool) -> T i a -> T i a
forall a. (a -> Bool) -> [a] -> [a]
filter UnitSet i a -> Bool
forall i a. UnitSet i a -> Bool
independent

findClosest :: (Ord i, Field.C a) => Unit.T i -> T i a -> UnitSet i a
findClosest :: T i -> T i a -> UnitSet i a
findClosest T i
u =
   (UnitSet i a, Int) -> UnitSet i a
forall a b. (a, b) -> a
fst ((UnitSet i a, Int) -> UnitSet i a)
-> (T i a -> (UnitSet i a, Int)) -> T i a -> UnitSet i a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UnitSet i a, Int) -> (UnitSet i a, Int) -> Ordering)
-> [(UnitSet i a, Int)] -> (UnitSet i a, Int)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (\(UnitSet i a
_,Int
dist0) (UnitSet i a
_,Int
dist1) -> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
dist0 Int
dist1) ([(UnitSet i a, Int)] -> (UnitSet i a, Int))
-> (T i a -> [(UnitSet i a, Int)]) -> T i a -> (UnitSet i a, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            T i -> T i a -> [(UnitSet i a, Int)]
forall i a. (Ord i, C a) => T i -> T i a -> [(UnitSet i a, Int)]
evalDist T i
u (T i a -> [(UnitSet i a, Int)])
-> (T i a -> T i a) -> T i a -> [(UnitSet i a, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitSet i a -> Bool) -> T i a -> T i a
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> (UnitSet i a -> Bool) -> UnitSet i a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.UnitSet i a -> Bool
forall i a. UnitSet i a -> Bool
independent)

evalDist :: (Ord i, Field.C a)
   => Unit.T i
   -> T i a
   -> [(UnitSet i a, Int)] {-^ (UnitSet,distance)   the UnitSet may contain powered units -}
evalDist :: T i -> T i a -> [(UnitSet i a, Int)]
evalDist T i
target = (UnitSet i a -> (UnitSet i a, Int))
-> T i a -> [(UnitSet i a, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\UnitSet i a
us->
    let (Int
expo,Int
dist)=T i -> T i -> (Int, Int)
forall i. Ord i => T i -> T i -> (Int, Int)
findBestExp T i
target (UnitSet i a -> T i
forall i a. UnitSet i a -> T i
unit UnitSet i a
us)
    in  (Int -> UnitSet i a -> UnitSet i a
forall i a. (Ord i, C a) => Int -> UnitSet i a -> UnitSet i a
powerOfUnitSet Int
expo UnitSet i a
us, Int
dist)
  )

findBestExp :: (Ord i) => Unit.T i -> Unit.T i -> (Int, Int)
findBestExp :: T i -> T i -> (Int, Int)
findBestExp T i
target T i
u =
  let bestl :: (Int, Int)
bestl = [(Int, Int)] -> (Int, Int)
findMinExp (T i -> [(Int, T i)] -> [(Int, Int)]
forall i. Ord i => T i -> [(Int, T i)] -> [(Int, Int)]
distances T i
target ((T i -> T i) -> Int -> [(Int, T i)]
forall i. (T i -> T i) -> Int -> [(Int, T i)]
listMultiples (T i -> T i -> T i
forall a. C a => a -> a -> a
subtract T i
u) (-Int
1)))
      bestr :: (Int, Int)
bestr = [(Int, Int)] -> (Int, Int)
findMinExp (T i -> [(Int, T i)] -> [(Int, Int)]
forall i. Ord i => T i -> [(Int, T i)] -> [(Int, Int)]
distances T i
target ((T i -> T i) -> Int -> [(Int, T i)]
forall i. (T i -> T i) -> Int -> [(Int, T i)]
listMultiples (T i -> T i -> T i
forall a. C a => a -> a -> a
(+)      T i
u)   Int
1 ))
  in  if (Int, Int) -> (Int, Int) -> Bool
distLE (Int, Int)
bestl (Int, Int)
bestr
      then (Int, Int)
bestl
      else (Int, Int)
bestr

{-|
  Find the exponent that lead to minimal distance
  Since the list is infinite 'maximum' will fail
  but the sequence is convex
  and thus we can abort when the distance stop falling
-}
findMinExp :: [(Int, Int)] -> (Int, Int)
findMinExp :: [(Int, Int)] -> (Int, Int)
findMinExp ((Int, Int)
x0:(Int, Int)
x1:[(Int, Int)]
rest) =
  if (Int, Int) -> (Int, Int) -> Bool
distLE (Int, Int)
x0 (Int, Int)
x1
  then (Int, Int)
x0
  else [(Int, Int)] -> (Int, Int)
findMinExp ((Int, Int)
x1(Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:[(Int, Int)]
rest)
findMinExp [(Int, Int)]
_ = String -> (Int, Int)
forall a. HasCallStack => String -> a
error String
"List of unit approximations with respect to the unit exponent must be infinite."

distLE :: (Int, Int) -> (Int, Int) -> Bool
distLE :: (Int, Int) -> (Int, Int) -> Bool
distLE (Int
_,Int
dist0) (Int
_,Int
dist1) = Int
dist0Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=Int
dist1
--distLE (exp0,dist0) (exp1,dist1) = (dist0<dist1) || (dist0==dist1 && (abs exp0) <= (abs exp1))

-- [(exponent,unit)] -> [(exponent,distance)]
distances :: (Ord i) => Unit.T i -> [(Int, Unit.T i)] -> [(Int, Int)]
distances :: T i -> [(Int, T i)] -> [(Int, Int)]
distances T i
targetu = ((Int, T i) -> (Int, Int)) -> [(Int, T i)] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
expo,T i
u)->(Int
expo, T i -> Int
forall a v. C a v => v -> a
norm (T i -> T i -> T i
forall a. C a => a -> a -> a
subtract T i
u T i
targetu)))

listMultiples :: (Unit.T i -> Unit.T i) -> Int -> [(Int, Unit.T i)]
listMultiples :: (T i -> T i) -> Int -> [(Int, T i)]
listMultiples T i -> T i
f Int
dir = ((Int, T i) -> (Int, T i)) -> (Int, T i) -> [(Int, T i)]
forall a. (a -> a) -> a -> [a]
iterate (\(Int
expo,T i
u)->(Int
expoInt -> Int -> Int
forall a. C a => a -> a -> a
+Int
dir,T i -> T i
f T i
u)) (Int
0,T i
forall i. T i
Unit.scalar)