{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{- |
Physical expressions track the operations made on physical values
so we are able to give detailed information on how to resolve
unit violations.
-}

module Number.OccasionallyScalarExpression where

import qualified Algebra.Transcendental      as Trans
import qualified Algebra.Algebraic           as Algebraic
import qualified Algebra.Field               as Field
import qualified Algebra.Absolute                as Absolute
import qualified Algebra.Ring                as Ring
import qualified Algebra.Additive            as Additive
import qualified Algebra.ZeroTestable        as ZeroTestable

import qualified Algebra.OccasionallyScalar as OccScalar

import Data.Maybe(fromMaybe)
import Data.Array(listArray,(!))

import NumericPrelude.Base
import NumericPrelude.Numeric


{- | A value of type 'T' stores information on how to resolve unit violations.
     The main application of the module are certainly
     Number.Physical type instances
     but in principle it can also be applied to other occasionally scalar types. -}
data T a v = Cons (Term a v) v

data Term a v =
     Const
   | Add (T a v) (T a v)
   | Mul (T a v) (T a v)
   | Div (T a v) (T a v)

fromValue :: v -> T a v
fromValue :: v -> T a v
fromValue = Term a v -> v -> T a v
forall a v. Term a v -> v -> T a v
Cons Term a v
forall a v. Term a v
Const


makeLine :: Int -> String -> String
makeLine :: Int -> String -> String
makeLine Int
indent String
str = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
indent Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"

showUnitError :: (Show v) => Bool -> Int -> v -> T a v -> String
showUnitError :: Bool -> Int -> v -> T a v -> String
showUnitError Bool
divide Int
indent v
x (Cons Term a v
expr v
y) =
  let indent' :: Int
indent'   = Int
indentInt -> Int -> Int
forall a. C a => a -> a -> a
+Int
2
      showSub :: Bool -> T a v -> String
showSub Bool
d = Bool -> Int -> v -> T a v -> String
forall v a. Show v => Bool -> Int -> v -> T a v -> String
showUnitError Bool
d (Int
indent'Int -> Int -> Int
forall a. C a => a -> a -> a
+Int
2) v
x
      mulDivArr :: Array Bool String
mulDivArr = (Bool, Bool) -> [String] -> Array Bool String
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Bool
False, Bool
True) [String
"multiply", String
"divide"]
  in  Int -> String -> String
makeLine Int
indent
         (Array Bool String
mulDivArr Array Bool String -> Bool -> String
forall i e. Ix i => Array i e -> i -> e
! Bool
divide String -> String -> String
forall a. [a] -> [a] -> [a]
++
          String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ v -> String
forall a. Show a => a -> String
show v
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" by " String -> String -> String
forall a. [a] -> [a] -> [a]
++ v -> String
forall a. Show a => a -> String
show v
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++
      case Term a v
expr of
        (Term a v
Const) -> String
""
        (Add T a v
y0 T a v
y1) ->
          Int -> String -> String
makeLine Int
indent' String
"e.g." String -> String -> String
forall a. [a] -> [a] -> [a]
++
          Bool -> T a v -> String
forall a. Bool -> T a v -> String
showSub Bool
divide T a v
y0 String -> String -> String
forall a. [a] -> [a] -> [a]
++
          Int -> String -> String
makeLine Int
indent' String
"and " String -> String -> String
forall a. [a] -> [a] -> [a]
++
          Bool -> T a v -> String
forall a. Bool -> T a v -> String
showSub Bool
divide T a v
y1
        (Mul T a v
y0 T a v
y1) ->
          Int -> String -> String
makeLine Int
indent' String
"e.g." String -> String -> String
forall a. [a] -> [a] -> [a]
++
          Bool -> T a v -> String
forall a. Bool -> T a v -> String
showSub Bool
divide T a v
y0 String -> String -> String
forall a. [a] -> [a] -> [a]
++
          Int -> String -> String
makeLine Int
indent' String
"or  " String -> String -> String
forall a. [a] -> [a] -> [a]
++
          Bool -> T a v -> String
forall a. Bool -> T a v -> String
showSub Bool
divide T a v
y1
        (Div T a v
y0 T a v
y1) ->
          Int -> String -> String
makeLine Int
indent' String
"e.g." String -> String -> String
forall a. [a] -> [a] -> [a]
++
          Bool -> T a v -> String
forall a. Bool -> T a v -> String
showSub Bool
divide T a v
y0 String -> String -> String
forall a. [a] -> [a] -> [a]
++
          Int -> String -> String
makeLine Int
indent' String
"or  " String -> String -> String
forall a. [a] -> [a] -> [a]
++
          Bool -> T a v -> String
forall a. Bool -> T a v -> String
showSub (Bool -> Bool
not Bool
divide) T a v
y1


lift :: (v -> v) -> (T a v -> T a v)
lift :: (v -> v) -> T a v -> T a v
lift v -> v
f (Cons Term a v
xe v
x) = Term a v -> v -> T a v
forall a v. Term a v -> v -> T a v
Cons Term a v
xe (v -> v
f v
x)

fromScalar :: (Show v, OccScalar.C a v) =>
   a -> T a v
fromScalar :: a -> T a v
fromScalar = a -> T a v
forall a v. C a v => a -> v
OccScalar.fromScalar

scalarMap :: (Show v, OccScalar.C a v) =>
   (a -> a) -> (T a v -> T a v)
scalarMap :: (a -> a) -> T a v -> T a v
scalarMap a -> a
f T a v
x = a -> T a v
forall a v. C a v => a -> v
OccScalar.fromScalar (a -> a
f (T a v -> a
forall a v. C a v => v -> a
OccScalar.toScalar T a v
x))

scalarMap2 :: (Show v, OccScalar.C a v) =>
   (a -> a -> a) -> (T a v -> T a v -> T a v)
scalarMap2 :: (a -> a -> a) -> T a v -> T a v -> T a v
scalarMap2 a -> a -> a
f T a v
x T a v
y = a -> T a v
forall a v. C a v => a -> v
OccScalar.fromScalar (a -> a -> a
f (T a v -> a
forall a v. C a v => v -> a
OccScalar.toScalar T a v
x) (T a v -> a
forall a v. C a v => v -> a
OccScalar.toScalar T a v
y))


instance (Show v) => Show (T a v) where
  show :: T a v -> String
show (Cons Term a v
_ v
x) = v -> String
forall a. Show a => a -> String
show v
x

instance (Eq v) => Eq (T a v) where
  (Cons Term a v
_ v
x) == :: T a v -> T a v -> Bool
== (Cons Term a v
_ v
y) = v
xv -> v -> Bool
forall a. Eq a => a -> a -> Bool
==v
y

instance (Ord v) => Ord (T a v) where
  compare :: T a v -> T a v -> Ordering
compare (Cons Term a v
_ v
x) (Cons Term a v
_ v
y) = v -> v -> Ordering
forall a. Ord a => a -> a -> Ordering
compare v
x v
y

instance (Additive.C v) => Additive.C (T a v) where
  zero :: T a v
zero = Term a v -> v -> T a v
forall a v. Term a v -> v -> T a v
Cons Term a v
forall a v. Term a v
Const v
forall a. C a => a
zero
  xe :: T a v
xe@(Cons Term a v
_ v
x) + :: T a v -> T a v -> T a v
+ ye :: T a v
ye@(Cons Term a v
_ v
y) = Term a v -> v -> T a v
forall a v. Term a v -> v -> T a v
Cons (T a v -> T a v -> Term a v
forall a v. T a v -> T a v -> Term a v
Add T a v
xe T a v
ye) (v
xv -> v -> v
forall a. C a => a -> a -> a
+v
y)
  xe :: T a v
xe@(Cons Term a v
_ v
x) - :: T a v -> T a v -> T a v
- ye :: T a v
ye@(Cons Term a v
_ v
y) = Term a v -> v -> T a v
forall a v. Term a v -> v -> T a v
Cons (T a v -> T a v -> Term a v
forall a v. T a v -> T a v -> Term a v
Add T a v
xe T a v
ye) (v
xv -> v -> v
forall a. C a => a -> a -> a
-v
y)
  negate :: T a v -> T a v
negate = (v -> v) -> T a v -> T a v
forall v a. (v -> v) -> T a v -> T a v
lift v -> v
forall a. C a => a -> a
negate

instance (Ring.C v) => Ring.C (T a v) where
  xe :: T a v
xe@(Cons Term a v
_ v
x) * :: T a v -> T a v -> T a v
* ye :: T a v
ye@(Cons Term a v
_ v
y) = Term a v -> v -> T a v
forall a v. Term a v -> v -> T a v
Cons (T a v -> T a v -> Term a v
forall a v. T a v -> T a v -> Term a v
Mul T a v
xe T a v
ye) (v
xv -> v -> v
forall a. C a => a -> a -> a
*v
y)

  fromInteger :: Integer -> T a v
fromInteger = v -> T a v
forall v a. v -> T a v
fromValue (v -> T a v) -> (Integer -> v) -> Integer -> T a v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> v
forall a. C a => Integer -> a
fromInteger

instance (Field.C v) => Field.C (T a v) where
  xe :: T a v
xe@(Cons Term a v
_ v
x) / :: T a v -> T a v -> T a v
/ ye :: T a v
ye@(Cons Term a v
_ v
y) = Term a v -> v -> T a v
forall a v. Term a v -> v -> T a v
Cons (T a v -> T a v -> Term a v
forall a v. T a v -> T a v -> Term a v
Div T a v
xe T a v
ye) (v
xv -> v -> v
forall a. C a => a -> a -> a
/v
y)
  fromRational' :: Rational -> T a v
fromRational' = v -> T a v
forall v a. v -> T a v
fromValue (v -> T a v) -> (Rational -> v) -> Rational -> T a v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> v
forall a. C a => Rational -> a
fromRational'

instance (ZeroTestable.C v) => ZeroTestable.C (T a v) where
  isZero :: T a v -> Bool
isZero (Cons Term a v
_ v
x) = v -> Bool
forall a. C a => a -> Bool
isZero v
x

instance (Absolute.C v) => Absolute.C (T a v) where
  {- are these definitions sensible? -}
  abs :: T a v -> T a v
abs    = (v -> v) -> T a v -> T a v
forall v a. (v -> v) -> T a v -> T a v
lift v -> v
forall a. C a => a -> a
abs
  signum :: T a v -> T a v
signum = (v -> v) -> T a v -> T a v
forall v a. (v -> v) -> T a v -> T a v
lift v -> v
forall a. C a => a -> a
signum


{- This instance is not quite satisfying.
   The expression data structure should also keep track of powers
   in order to report according errors. -}
instance (Algebraic.C a, Field.C v, Show v, OccScalar.C a v) =>
    Algebraic.C (T a v) where
  sqrt :: T a v -> T a v
sqrt    = (a -> a) -> T a v -> T a v
forall v a. (Show v, C a v) => (a -> a) -> T a v -> T a v
scalarMap  a -> a
forall a. C a => a -> a
sqrt
  T a v
x ^/ :: T a v -> Rational -> T a v
^/ Rational
y  = (a -> a) -> T a v -> T a v
forall v a. (Show v, C a v) => (a -> a) -> T a v -> T a v
scalarMap  (a -> Rational -> a
forall a. C a => a -> Rational -> a
^/ Rational
y) T a v
x

instance (Trans.C a, Field.C v, Show v, OccScalar.C a v) =>
    Trans.C (T a v) where
  pi :: T a v
pi      = a -> T a v
forall v a. (Show v, C a v) => a -> T a v
fromScalar a
forall a. C a => a
pi
  log :: T a v -> T a v
log     = (a -> a) -> T a v -> T a v
forall v a. (Show v, C a v) => (a -> a) -> T a v -> T a v
scalarMap  a -> a
forall a. C a => a -> a
log
  exp :: T a v -> T a v
exp     = (a -> a) -> T a v -> T a v
forall v a. (Show v, C a v) => (a -> a) -> T a v -> T a v
scalarMap  a -> a
forall a. C a => a -> a
exp
  logBase :: T a v -> T a v -> T a v
logBase = (a -> a -> a) -> T a v -> T a v -> T a v
forall v a.
(Show v, C a v) =>
(a -> a -> a) -> T a v -> T a v -> T a v
scalarMap2 a -> a -> a
forall a. C a => a -> a -> a
logBase
  ** :: T a v -> T a v -> T a v
(**)    = (a -> a -> a) -> T a v -> T a v -> T a v
forall v a.
(Show v, C a v) =>
(a -> a -> a) -> T a v -> T a v -> T a v
scalarMap2 a -> a -> a
forall a. C a => a -> a -> a
(**)
  cos :: T a v -> T a v
cos     = (a -> a) -> T a v -> T a v
forall v a. (Show v, C a v) => (a -> a) -> T a v -> T a v
scalarMap  a -> a
forall a. C a => a -> a
cos
  tan :: T a v -> T a v
tan     = (a -> a) -> T a v -> T a v
forall v a. (Show v, C a v) => (a -> a) -> T a v -> T a v
scalarMap  a -> a
forall a. C a => a -> a
tan
  sin :: T a v -> T a v
sin     = (a -> a) -> T a v -> T a v
forall v a. (Show v, C a v) => (a -> a) -> T a v -> T a v
scalarMap  a -> a
forall a. C a => a -> a
sin
  acos :: T a v -> T a v
acos    = (a -> a) -> T a v -> T a v
forall v a. (Show v, C a v) => (a -> a) -> T a v -> T a v
scalarMap  a -> a
forall a. C a => a -> a
acos
  atan :: T a v -> T a v
atan    = (a -> a) -> T a v -> T a v
forall v a. (Show v, C a v) => (a -> a) -> T a v -> T a v
scalarMap  a -> a
forall a. C a => a -> a
atan
  asin :: T a v -> T a v
asin    = (a -> a) -> T a v -> T a v
forall v a. (Show v, C a v) => (a -> a) -> T a v -> T a v
scalarMap  a -> a
forall a. C a => a -> a
asin
  cosh :: T a v -> T a v
cosh    = (a -> a) -> T a v -> T a v
forall v a. (Show v, C a v) => (a -> a) -> T a v -> T a v
scalarMap  a -> a
forall a. C a => a -> a
cosh
  tanh :: T a v -> T a v
tanh    = (a -> a) -> T a v -> T a v
forall v a. (Show v, C a v) => (a -> a) -> T a v -> T a v
scalarMap  a -> a
forall a. C a => a -> a
tanh
  sinh :: T a v -> T a v
sinh    = (a -> a) -> T a v -> T a v
forall v a. (Show v, C a v) => (a -> a) -> T a v -> T a v
scalarMap  a -> a
forall a. C a => a -> a
sinh
  acosh :: T a v -> T a v
acosh   = (a -> a) -> T a v -> T a v
forall v a. (Show v, C a v) => (a -> a) -> T a v -> T a v
scalarMap  a -> a
forall a. C a => a -> a
acosh
  atanh :: T a v -> T a v
atanh   = (a -> a) -> T a v -> T a v
forall v a. (Show v, C a v) => (a -> a) -> T a v -> T a v
scalarMap  a -> a
forall a. C a => a -> a
atanh
  asinh :: T a v -> T a v
asinh   = (a -> a) -> T a v -> T a v
forall v a. (Show v, C a v) => (a -> a) -> T a v -> T a v
scalarMap  a -> a
forall a. C a => a -> a
asinh


instance (OccScalar.C a v, Show v)
      => OccScalar.C a (T a v) where
   toScalar :: T a v -> a
toScalar xe :: T a v
xe@(Cons Term a v
_ v
x) =
      a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe
         (String -> a
forall a. HasCallStack => String -> a
error (T a v -> String
forall a. Show a => a -> String
show T a v
xe String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a scalar value.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 Bool -> Int -> v -> T a v -> String
forall v a. Show v => Bool -> Int -> v -> T a v -> String
showUnitError Bool
True Int
0 v
x T a v
xe))
         (v -> Maybe a
forall a v. C a v => v -> Maybe a
OccScalar.toMaybeScalar v
x)
   toMaybeScalar :: T a v -> Maybe a
toMaybeScalar (Cons Term a v
_ v
x) = v -> Maybe a
forall a v. C a v => v -> Maybe a
OccScalar.toMaybeScalar v
x
   fromScalar :: a -> T a v
fromScalar = v -> T a v
forall v a. v -> T a v
fromValue (v -> T a v) -> (a -> v) -> a -> T a v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> v
forall a v. C a v => a -> v
OccScalar.fromScalar


{-
  I would like to use OccasionallyScalar.toScalar
  in fmap and (>>=) to allow more sophisticated error messages
  for types that support more descriptive error messages.
  But this requires constraints to the type arguments of
  Functor and Monad.
-}


{- Operators for lifting scalar operations to
   operations on physical values -}
{-
instance Functor (T i) where
  fmap f (Cons xu x) =
    if Unit.isScalar xu
    then OccScalar.fromScalar (f x)
    else error "Physics.Quantity.Value.fmap: function for scalars, only"

instance Monad (T i) where
  (>>=) (Cons xu x) f =
    if Unit.isScalar xu
    then f x
    else error "Physics.Quantity.Value.(>>=): function for scalars, only"
  return = OccScalar.fromScalar
-}