ideas-math-1.1: src/Domain/Math/Power/Equation/NormViews.hs
-----------------------------------------------------------------------------
-- Copyright 2014, Open Universiteit Nederland. This file is distributed
-- under the terms of the GNU General Public License. For more information,
-- see the file "LICENSE.txt", which is included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : alex.gerdes@ou.nl
-- Stability : provisional
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
-- $Id: NormViews.hs 6548 2014-05-16 10:34:18Z bastiaan $
module Domain.Math.Power.Equation.NormViews
( normPowerEqApproxView, normExpEqView, normLogEqView
, normPowerEqView, normPowerEqView'
) where
import Control.Applicative
import Control.Monad
import Data.List
import Data.Maybe
import Data.Ratio
import Domain.Math.Approximation
import Domain.Math.CleanUp
import Domain.Math.Data.OrList
import Domain.Math.Data.PrimeFactors
import Domain.Math.Data.Relation
import Domain.Math.Expr
import Domain.Math.Numeric.Views
import Domain.Math.Polynomial.Views
import Domain.Math.Power.NormViews
import Domain.Math.Power.Utils
import Domain.Math.Power.Views
import Domain.Math.Simplification hiding (simplify, simplifyWith)
import Ideas.Common.Rewriting
import Ideas.Common.Utils.Uniplate
import Ideas.Common.View
import Prelude hiding ((^))
import qualified Data.Traversable as T
import qualified Prelude
normPowerEqApproxView :: Int -> View (Relation Expr) (Expr, Expr)
normPowerEqApproxView d = makeView f (uncurry (.~=.))
where
f rel = case relationType rel of
EqualTo -> second (simplifyWith (precision d) doubleView) <$>
match (equationView >>> normPowerEqView) rel
Approximately -> return (leftHandSide rel, rightHandSide rel)
_ -> Nothing
normPowerEqView :: View (Equation Expr) (Expr, Expr) -- with x>0!
normPowerEqView = makeView f (uncurry (:==:))
where
f expr = do
-- selected var to the left, the rest to the right
(lhs :==: rhs) <- varLeft hasSomeVar expr >>= constRight hasSomeVar
-- match power
let simpl = simplify normPowerView lhs
(c, ax) = fromMaybe (1, simpl) (match timesView simpl)
(a, x) = fromMaybe (simpl, 1) $
match powerView ax
`mplus` do
(h, k) <- match rootView ax
return (h, 1 ./. k)
-- simplify, scale and take root
guard $ c /= 0 && x /= 0
let y = cleanUpExpr $ (rhs ./. c) .^. (1 ./. x)
return (a, simplify rationalView y)
normPowerEqView' :: (Expr -> Bool) -> View (OrList (Equation Expr)) (OrList (Equation Expr))
normPowerEqView' isVar = makeView f id
where -- general clean up, write root as power, try to simplify powers
f = fmap ( fmap (fmap (cleanUpExpr . root2power . simplerPower))
. catOrList
)
. T.mapM takeRoot' -- power to left and take root
root2power (Sym s [x, y])
| isRootSymbol s = x .^. (1 ./. y)
root2power expr = expr
takeRoot' expr = do
-- selected var to the left, the rest to the right
(lhs :==: rhs) <- varLeft isVar expr >>= constRight isVar
-- match power
(c, (a, x)) <- match unitPowerView lhs
-- simplify, scale and take root
let rhs' = simplify rationalView $ cleanUpExpr $ rhs ./. c
y <- maybe (Just [rhs' .^. (1 ./. x)]) (tr rhs') $ match integerView x
return $ toOrList $ map (a :==:) y
tr :: Expr -> Integer -> Maybe [Expr]
tr n x | odd x = case n of
Negate n' -> Just [neg (n' .^. (1 ./. x'))]
_ -> Just [n .^. (1 ./. x')]
| otherwise = case n of
Negate _ -> Nothing
_ -> Just $ let e = n .^. (1 ./. x') in [e, neg e]
where x' = fromInteger x
constRight :: (Expr -> Bool) -> Equation Expr -> Maybe (Equation Expr)
constRight isVar (lhs :==: rhs) = do
(vs, cs) <- fmap (partition isVar) (match sumView lhs)
let rhs' = rhs .+. build sumView (map neg cs)
return $ negateEq $ build sumView vs :==: simplifyWith mergeAlikeSum sumView rhs'
negateEq :: Equation Expr -> Equation Expr
negateEq (lhs :==: rhs) =
case lhs of
Negate lhs' -> lhs' :==: neg rhs
_ -> lhs :==: rhs
varLeft :: (Expr -> Bool) -> Equation Expr -> Maybe (Equation Expr)
varLeft isVar (lhs :==: rhs) = do
(vs, cs) <- fmap (partition isVar) (match sumView rhs)
return $ lhs .+. build sumView (map neg vs) :==: build sumView cs
scaleLeft :: Equation Expr -> Maybe (Equation Expr)
scaleLeft (lhs :==: rhs) =
match timesView lhs >>= \(c, x) -> return $
x :==: simplifyWith (second mergeAlikeProduct) productView (rhs ./. c)
normExpEqView :: View (Equation Expr) (String, Rational)
normExpEqView = makeView f id >>> linearEquationView
where
try g a = fromMaybe a $ g a
f e = do
let (l :==: r) = try scaleLeft $ try (constRight hasSomeVar) e
return $ case match powerView l of
Just (b, x) -> x :==: simplify normLogView (logBase b r)
Nothing -> l :==: r
normLogEqView :: View (OrList (Equation Expr)) (OrList (Equation Expr))
normLogEqView = makeView (liftM g . T.mapM f) id
where
f expr@(lhs :==: rhs) = return $
case match logView lhs of
Just (b, x) -> x :==: b .^. rhs
Nothing -> expr
g = simplify orSetView . fmap (fmap cleaner) . simplify (normPowerEqView' hasSomeVar)
. simplify higherDegreeEquationsView
-- Quick fix: 4^(3/2) should be simplified to sqrt (4^3), which is 8
cleaner = cleanUpExpr . transform h . cleanUpExpr
h expr@(Sym s [a, b]) | isPowerSymbol s =
case (match rationalView a, match rationalView b) of
(Just x, Just y) | denominator y /= 1 ->
root (fromRational (x Prelude.^ numerator y)) (fromInteger $ denominator y)
_ -> expr
h expr = expr
normLogView :: View Expr Expr
normLogView = makeView g id
where
g expr =
case expr of
Sym s [x, y]
| isLogSymbol s -> do
b <- match integerView x
let divExp (be, n) = return $ f be y ./. fromInteger n
maybe (Just $ f b y) divExp $ greatestPower b
| otherwise -> Nothing
_ -> Nothing
f b expr=
case expr of
Nat 1 -> 0
Nat n
| n == b -> 1
| otherwise -> maybe (logBase (fromInteger b) (fromInteger n)) fromInteger
$ lookup b (allPowers n)
e1 :*: e2 -> f b e1 .+. f b e2
e1 :/: e2 -> f b e1 .-. f b e2
Sqrt e -> f b (e .^. (1 ./. 2))
Negate e -> Negate $ f b e
Sym s [x,y]
| isPowerSymbol s -> y .*. f b x
| isRootSymbol s -> f b (x .^. (1 ./. y))
_ -> expr
simplerPower :: Expr -> Expr
simplerPower expr =
case expr of
Sqrt x -> x ^ (1/2)
Sym s [x, y]
| isRootSymbol s -> x ^ (1/y)
| isPowerSymbol s -> f x y
_ -> expr
where
f x y
| y == 0 = 1
| y == 1 = x
| x == 0 = 0
| otherwise = fromMaybe expr $
-- geheel getal
liftM fromRational (match rationalView expr)
`mplus` do
-- breuk
ry <- match rationalView y
rx <- match rationalView x
guard $ denominator rx == 1 && denominator ry /= 1
fromInteger <$>
takeRoot (numerator rx Prelude.^ numerator ry) (denominator ry)
`mplus` do
-- (a/b)^y -> a^y/b^y
(a, b) <- match divView x
return $ build divView (a .^. y, b .^. y)