diff --git a/CharArray.hs b/CharArray.hs new file mode 100644 --- /dev/null +++ b/CharArray.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE FlexibleContexts #-} +module CharArray where + +import Data.Array.IArray + +lineOfArray :: (Enum i, Ix i, IArray a Char) + => a (i,i) Char -> i -> String +lineOfArray a i = [ a ! (x, i) | x <- [xMin .. xMax]] + where ((xMin,_),(xMax,_)) = bounds a + +linesOfArray :: (Enum i, Ix i, IArray a Char) + => a (i,i) Char -> [String] +linesOfArray a = map (lineOfArray a) [yMin .. yMax] + where ((_,yMin),(_, yMax)) = bounds a diff --git a/Eq.cabal b/Eq.cabal new file mode 100644 --- /dev/null +++ b/Eq.cabal @@ -0,0 +1,95 @@ +Name: Eq +Version: 1.0 +Synopsis: Render math formula in ASCII, and perform some simplifications +Build-Type: Simple +Category: Language, Math +Cabal-Version: >= 1.4 +Description: Haskell formula manipulation program +Author: Vincent Berthoux +Maintainer: Vincent Berthoux +License: BSD3 + +Flag Debug + Description: Enable debug prints + Default: False + +Flag TestProject + Description: Enable compilation of the test project + Default: False + +Flag StaticLinking + Description: Try to link statically on Linux + Default: False + +Flag optimize + Description: turn on optimisation + Default: True + +Executable eq + Main-Is: formulaMain.hs + Extensions: CPP + Ghc-options:-Wall + + -- Special static linking only required + -- in linux so far. + if !os(darwin) && !os(windows) && flag(StaticLinking) + Ghc-options:-static -optl-static -optl-pthread + + if flag(debug) + cpp-options:-D_DEBUG + + if flag(optimize) + Ghc-options:-O3 + + Other-Modules: EqManips.Algorithm.Cleanup + , EqManips.Algorithm.Derivative + , EqManips.Algorithm.EmptyMonad + , EqManips.Algorithm.Eval + , EqManips.Algorithm.Eval.Complex + , EqManips.Algorithm.Eval.Floating + , EqManips.Algorithm.Eval.GenericEval + , EqManips.Algorithm.Eval.GlobalStatement + , EqManips.Algorithm.Eval.Meta + , EqManips.Algorithm.Eval.Polynomial + , EqManips.Algorithm.Eval.Ratio + , EqManips.Algorithm.Eval.Types + , EqManips.Algorithm.Eval.Utils + , EqManips.Algorithm.Expand + , EqManips.Algorithm.Inject + , EqManips.Algorithm.Simplify + , EqManips.Algorithm.Unification + , EqManips.Algorithm.Utils + , EqManips.BaseLibrary + , EqManips.Conf + , EqManips.Domain + , EqManips.ErrorMessages + , EqManips.EvaluationContext + , EqManips.FormulaIterator + , EqManips.InputParser.EqCode + , EqManips.InputParser.MathML + , EqManips.Linker + , EqManips.Polynome + , EqManips.Preprocessor + , EqManips.Propreties + , EqManips.Renderer.Ascii + , EqManips.Renderer.CharRender + , EqManips.Renderer.Cpp + , EqManips.Renderer.EqCode + , EqManips.Renderer.Latex + , EqManips.Renderer.Mathml + , EqManips.Renderer.Placer + , EqManips.Renderer.RenderConf + , EqManips.Renderer.Sexpr + , EqManips.Types + , EqManips.UnicodeSymbols + , CharArray + , Repl + + Build-Depends: base >= 4.1 && < 5.0 + , parsec >= 3.0 && < 4.0 + , HaXml >= 1.9 && < 2.0 + , array + , mtl + , containers + , filepath + diff --git a/EqManips/Algorithm/Cleanup.hs b/EqManips/Algorithm/Cleanup.hs new file mode 100644 --- /dev/null +++ b/EqManips/Algorithm/Cleanup.hs @@ -0,0 +1,235 @@ +module EqManips.Algorithm.Cleanup ( cleanup + , cleanupFormulaPrim + , cleanupRules ) where + +import EqManips.Types +import EqManips.Polynome +import EqManips.FormulaIterator +import EqManips.Algorithm.Utils +import Data.Ratio + +import qualified EqManips.ErrorMessages as Err + +type BiRuler = FormulaPrim -> FormulaPrim -> Either FormulaPrim (FormulaPrim, FormulaPrim) + +cleanup :: Formula anyForm -> Formula anyForm +cleanup = depthFirstFormula `asAMonad` (Formula . rules . unTagFormula) + +cleanupFormulaPrim :: FormulaPrim -> FormulaPrim +cleanupFormulaPrim = depthFormulaPrimTraversal `asAMonad` rules + +cleanupRules :: Formula anyForm -> Formula anyForm +cleanupRules (Formula a) = Formula $ rules a + +int :: Integer -> FormulaPrim +int = CInteger + +zero :: FormulaPrim -> Bool +zero f = f == int 0 || f == CFloat 0.0 + +---------------------------------------------- +---- '+' +---------------------------------------------- +-- | Addition rules, everything +-- concerning the '+' operator +add :: BiRuler +-- What's the point? +add (CInteger 0) x = Left x +add x (CInteger 0) = Left x +add (CFloat 0) x = Left x +add x (CFloat 0) = Left x + +add (CInteger a) (CInteger b) = Left . int $ a + b +-- x + (-y) <=> x - y +{-rules (BinOp OpAdd x (UnOp OpNegate y)) = return $ x - y-} +add x y = Right (x,y) + +---------------------------------------------- +---- '-' +---------------------------------------------- +-- | Substraction rules +sub :: BiRuler +sub x (CInteger 0) = Left x +sub (CInteger 0) x = Left $ negate x +sub (CInteger i1) (CInteger i2) = Left . int $ i1 - i2 +-- x - (-y) <=> x + y +{-rules (BinOp OpSub x (UnOp OpNegate y)) = return $ x + y-} +sub x y = Right (x,y) + +---------------------------------------------- +---- '*' +---------------------------------------------- +mul :: BiRuler +-- Eq:format (1/denom) * x = x / denom +mul (BinOp _ OpDiv [CInteger 1, denom]) x = Left $ x / denom +-- Eq:format x * (1/denom) = x / denom +mul x (BinOp _ OpDiv [CInteger 1, denom]) = Left $ x / denom + +-- Eq:format (-1/denom) * x = -x / denom +mul (BinOp _ OpDiv [UnOp _ OpNegate (CInteger 1), denom]) x = Left $ negate x / denom +-- Eq:format x * (-1/denom) = -x / denom +mul x (BinOp _ OpDiv [UnOp _ OpNegate (CInteger 1), denom]) = Left $ negate x / denom + +-- Eq:format a ^ n * a ^ m = a ^ (n + m) +mul (BinOp _ OpPow [a, n]) (BinOp _ OpPow [b, m]) | a == b = Left $ a ** (n + m) +mul (CInteger 1) x = Left x +mul x (CInteger 1) = Left x +mul (CFloat 1.0) x = Left x +mul x (CFloat 1.0) = Left x +mul (CInteger i1) (CInteger i2) = Left . int $ i1 * i2 +mul (BinOp _ OpDiv [a,b]) (BinOp _ OpDiv [c,d]) + | b == d = Left $ (a * c) / d +mul x y = Right (x,y) + +---------------------------------------------- +---- '**' +---------------------------------------------- +power :: BiRuler +power _ (CInteger 0) = Left $ int 1 +power x (CInteger 1) = Left x +power x y = Right (x,y) + +---------------------------------------------- +---- '/' +---------------------------------------------- +divide :: BiRuler +divide (CInteger 0) _ = Left $ int 0 +divide x (CInteger 1) = Left x +divide f1@(CInteger i1) f2@(CInteger i2) + | i1 `mod` i2 == 0 = Left . int $ i1 `div` i2 + | otherwise = if greatestCommonDenominator > 1 + then Left $ int (i1 `quot` greatestCommonDenominator) + / int (i2 `quot` greatestCommonDenominator) + else Right (f1,f2) + where greatestCommonDenominator = gcd i1 i2 +divide x y = Right (x,y) + +---------------------------------------------- +---- 'sinus' +---------------------------------------------- +sinus :: FormulaPrim -> FormulaPrim +sinus (CInteger 0) = int 0 +sinus (NumEntity Pi) = int 0 +sinus (BinOp _ OpDiv [NumEntity Pi, CInteger 6]) = int 1 / int 2 +sinus (BinOp _ OpMul [NumEntity Pi, CInteger _]) = int 0 +sinus (BinOp _ OpMul [CInteger _, NumEntity Pi]) = int 0 +-- TODO : add more complex simplifications one day :] +{-sinus (BinOp OpMul [Pi, BinOp OpDiv [Pi, CInteger i]])-} +sinus i = sin i + +---------------------------------------------- +---- 'cosinus' +---------------------------------------------- +cosinus :: FormulaPrim -> FormulaPrim +cosinus (CInteger 0) = int 1 +cosinus (NumEntity Pi) = int (-1) +cosinus (BinOp _ OpDiv [NumEntity Pi, CInteger 6]) = sqrt 3 / int 3 +cosinus (BinOp _ OpMul [NumEntity Pi, CInteger i]) + | i `mod` 2 == 0 = int 1 + | otherwise = int (-1) +cosinus (BinOp _ OpMul [CInteger i, NumEntity Pi]) + | i `mod` 2 == 0 = int 1 + | otherwise = int (-1) +cosinus i = cos i + +-------------------------------------------------- +---- 'tan' +-------------------------------------------------- +tangeant :: FormulaPrim -> FormulaPrim +tangeant (BinOp _ OpDiv [NumEntity Pi, CInteger 4]) = int 1 +tangeant i = tan i + +-------------------------------------------------- +---- 'asinh' +-------------------------------------------------- +sinush :: FormulaPrim -> FormulaPrim +sinush (CInteger 0) = int 0 +sinush (UnOp _ OpNegate x) = negate $ sinh x +sinush (CFloat f) | f < 0 = negate . sinh $ CFloat (-f) +sinush (CInteger i) | i < 0 = negate . sinh $ CInteger (-i) +sinush i = sinh i + +-------------------------------------------------- +---- 'cosinush' +-------------------------------------------------- +cosinush :: FormulaPrim -> FormulaPrim +cosinush (CInteger 0) = int 0 +cosinush (UnOp _ OpNegate x) = cosh x +cosinush (CFloat f) | f < 0 = cosh $ CFloat (-f) +cosinush (CInteger i) | i < 0 = cosh $ CInteger (-i) +cosinush i = cosh i + +-------------------------------------------------- +---- 'exp' +-------------------------------------------------- +exponential :: FormulaPrim -> FormulaPrim +exponential (CInteger 0) = int 1 +exponential (CFloat 0.0) = int 1 +exponential f = exp f + +reOp :: BinOperator -> [FormulaPrim] -> FormulaPrim +reOp _ [] = error Err.reOp +reOp _ [x] = x +reOp op lst = binOp op lst + +polyclean :: Polynome -> FormulaPrim +polyclean p = resulter $ pclean p + where pclean (Polynome var lst) = packPoly . Polynome var $ foldr reducer [] lst + pclean rest@(PolyRest _) = rest + + reducer ( _, PolyRest r) acc | isCoeffNull r = acc + reducer (deg, p'@(Polynome _ _)) acc = (deg, pclean p') : acc + reducer a acc = a : acc + + packPoly (Polynome _ [(deg, rest@(PolyRest _))]) | isCoeffNull deg = rest + packPoly (Polynome _ []) = 0 + packPoly a = a + + resulter (PolyRest c) = coefToFormula c + resulter (Polynome _ [(deg, PolyRest c)]) | isCoeffNull deg = coefToFormula c + resulter l = poly l + +--------------------------------------------- +---- Linking all the rules together +--------------------------------------------- +rules :: FormulaPrim -> FormulaPrim +rules (CFloat 0.0) = CInteger 0 +rules (Complex _ (re, CInteger 0)) = re +rules (Complex _ (re, CFloat 0.0)) = re +rules (Fraction f) + | numerator f == 0 = CInteger 0 + | denominator f == 1 = CInteger $ numerator f + +rules (Poly _ (PolyRest r)) = coefToFormula r +rules (Poly _ p) = polyclean p +rules (UnOp _ OpSin f) = sinus f +rules (UnOp _ OpCos f) = cosinus f +rules (UnOp _ OpTan f) = tangeant f +rules (UnOp _ OpSinh f) = sinush f +rules (UnOp _ OpCosh f) = cosinush f +rules (UnOp _ OpExp f) = exponential f +rules (BinOp _ OpAdd fs) = reOp OpAdd $ biAssoc add add fs +rules (BinOp _ OpSub fs) = reOp OpSub $ biAssoc sub add fs +rules (BinOp _ OpDiv [CInteger a, CInteger b]) = Fraction (a % b) +rules (BinOp _ OpDiv [UnOp _ OpNegate (CInteger a), CInteger b]) = unOp OpNegate $ Fraction (a % b) + +rules (BinOp _ OpDiv fs) = reOp OpDiv $ biAssoc divide mul fs +rules (BinOp _ OpPow fs) = reOp OpPow $ biAssoc power mul fs +rules (BinOp _ OpMul fs) + -- 0 * x or x * 0 in a multiplication result in 0 + | any zero fs = int 0 + | otherwise = reOp OpMul $ biAssoc mul mul fs + +-- Favor positive integer and a negate operator +-- to be able to pattern match more easily +rules cf@(CInteger i) | i < 0 = negate . CInteger $ negate i + | otherwise = cf +-- -(-x) = x +rules (UnOp _ OpNegate (UnOp _ OpNegate x)) = x + +-- -(0) = 0 +rules (UnOp _ OpNegate f) | zero f = int 0 + + +rules f = f + diff --git a/EqManips/Algorithm/Derivative.hs b/EqManips/Algorithm/Derivative.hs new file mode 100644 --- /dev/null +++ b/EqManips/Algorithm/Derivative.hs @@ -0,0 +1,219 @@ +module EqManips.Algorithm.Derivative( derivateFormula + , Var ) where + +import Control.Applicative +import Control.Monad( foldM ) +import Data.Monoid( Monoid( .. ), Any( .. ) ) + +import qualified EqManips.ErrorMessages as Err + +import EqManips.Types +import EqManips.Polynome +import EqManips.EvaluationContext +import EqManips.Algorithm.Inject +import EqManips.Algorithm.Utils + +type Var = String + +-- | just an helper function +int :: Integer -> FormulaPrim +int = CInteger + +-- | Public function to perform a derivation on a +-- variable. +derivateFormula :: Var -> Formula ListForm + -> EqContext (Formula ListForm) +derivateFormula v f = + Formula <$> derivationRules v f + +eqError :: FormulaPrim -> String -> EqContext FormulaPrim +eqError f msg = unTagFormula <$> eqFail (Formula f) msg + +-- | real function for derivation, d was choosen +-- because I'm too lasy to type something else :] +derivationRules :: String -> Formula ListForm + -> EqContext FormulaPrim +derivationRules variable (Formula func) = d func variable + where -- Poloynome with only ^ 0, degenerated case, but + -- must handle it + d (Poly _ (PolyRest _)) _ = pure $ int 0 + d f@(Poly _ (Polynome _ [])) _ = eqError f Err.polynome_empty + + -- Eq:format derivate( sum( a_i * x^i ), x ) = sum( a_i * i * x ^ (i-1)) + d (Poly _ p) var = case polyDerivate p var of + PolyRest r -> return $ coefToFormula r + p' -> return $ poly p' + + + d (Variable v) var + | v == var = return $ int 1 + | otherwise = return $ int 0 + d (Fraction _) _ = return $ int 0 + d (CInteger _) _ = return $ int 0 + d (Indexes _ _ _) _ = return $ int 0 + + d (CFloat _) _ = return $ int 0 + d (NumEntity _) _ = return $ int 0 + d (App _ f [g]) var = + (\f' -> (app f' [g] *)) <$> d f var <*> d g var + + d f@(Complex _ _) _ = eqError f "No complex derivation yet" + d f@(App _ _ _) _ = eqError f Err.deriv_no_multi_app + d f@(BinOp _ _ []) _ = eqError f (Err.empty_binop "derivate - ") + d f@(BinOp _ _ [_]) _ = eqError f (Err.single_binop "derivate - ") + d f@(BinOp _ OpEq _) _ = eqError f Err.deriv_no_eq_expr + d f@(BinOp _ OpAttrib _) _ = eqError f Err.deriv_no_attrib_expr + + -- Eq:format derivate(f + g, x) = derivate( f, x ) + + -- derivate( g, x ) + d (BinOp _ OpAdd formulas) var = + binOp OpAdd <$> mapM (flip d var) formulas + + -- Eq:format derivate(f - g, x) = derivate( f, x ) - + -- derivate( g, x ) + d (BinOp _ OpSub formulas) var = + binOp OpSub <$> mapM (flip d var) formulas + + -- Eq:format derivate( f * g, x ) = + -- derivate( f, x ) * g + f * derivate( g, x ) + d (BinOp _ OpMul (f1:lst)) var = do + f1' <- d f1 var + (_,_, subTrees) <- foldM mulDeriver (f1', f1, []) lst + return $ binOp OpAdd subTrees + where mulDeriver (previousDerivation, previous, rezLst) f = + (\derived -> ( derived + , f + , previousDerivation * f : previous * derived : rezLst)) <$> d f var + + -- Eq:format derivate( 1 / f, x ) = + -- -derivate( f, x ) / f ^ 2 + d (BinOp _ OpDiv [(CInteger 1),f]) var = + (\f' -> negate f' / f ** int 2) <$> d f var + + -- Eq:format derivate( f / g, x ) = + -- (derivate( f, x) * g - f * derivate( g, x )) + -- / g ^ 2 + d (BinOp _ OpDiv (f1:lst)) var = do + f1' <- d f1 var + (_,_, subTrees) <- foldM divDeriver (f1', f1, []) lst + return $ binOp OpDiv $ reverse subTrees + where derivableDenumerator = getAny . foldf notConst (Any False) + notConst (Variable v) acc = Any (v == var) `mappend` acc + notConst _ acc = acc + + divDeriver (previousDerivation, previous, rezLst) f + | derivableDenumerator f = do + derived <- d f var + let nume = (previousDerivation * f - previous * derived) + denom = (f ** int 2) + return ( nume / denom, f, denom : nume : rezLst) + + divDeriver (previousDerivation, _, rezLst) f = + return ( previousDerivation / f, f + , f : previousDerivation : rezLst) + + -- Eq:format derivate( f ^ n, x ) = + -- n * derivate( f, x ) * f ^ (n - 1) + d (BinOp _ OpPow (f1:rest)) var = + (\f1' -> f2 * f1' * f1 ** (f2 - int 1)) <$> d f1 var + where f2 = if length rest > 1 + then binOp OpPow rest + else head rest + + d f@(BinOp _ _ _) _ = + eqError f "Bad binary operator biduling" + + -- Eq:format derivate( -f, x ) = - derivate( f, x ) + d (UnOp _ OpNegate f) var = negate <$> d f var + + -- Eq:format derivate(exp( f ), x) = exp(f) * derivate( f, x ) + d (UnOp _ OpExp f) var = (* exp f) <$> d f var + + -- Eq:format derivate( sqrt(f),x) = derivate( f, x ) / (2 * sqrt(f)) + d (UnOp _ OpSqrt f) var = + (/ (int 2 * sqrt f)) <$> d f var + + -- Eq:format derivate(sin(f),x) = derivate(f,x) * cos(f) + d (UnOp _ OpSin f) var = (* cos f) <$> d f var + + -- Eq:format derivate(cos(f),x) = derivate(f,x) * -sin(f) + d (UnOp _ OpCos f) var = do + f' <- d f var + return $ f' * negate (sin f) + + -- Eq:format derivate(tan(f),x) = derivate(f,x) * 1 / cos(f) ^ 2 + d (UnOp _ OpTan f) var = + (* (int 1 / cos f ** 2)) <$> d f var + + -- Eq:format derivate( asin( f ), x) = derivate(f,x) + -- * 1/sqrt(1 - f^2) + d (UnOp _ OpASin f) var = + (* (int 1 / sqrt (int 1 - f ** int 2))) <$> d f var + + -- Eq:format derivate( acos( f ), x) = - derivate( f, x) * + -- (1/sqrt( 1 - f^2)) + d (UnOp _ OpACos f) var = + negate . (* (int 1 / sqrt (int 1 - f ** int 2))) <$> d f var + + -- Eq:format derivate( atan( f ),x ) = derivate( f, x) * + -- ( 1 / (1 + f^2) ) + d (UnOp _ OpATan f) var = (* (int 1 / (int 1 + f ** 2))) <$> d f var + d (UnOp _ OpSinh f) var = (* cosh f) <$> d f var + d (UnOp _ OpCosh f) var = (* sinh f) <$> d f var + d (UnOp _ OpTanh f) var = (* tanh f ** 2) <$> d f var + + d (UnOp _ OpASinh f) var = (* (int 1 / sqrt (f ** 2 + 1))) <$> d f var + d (UnOp _ OpACosh f) var = (* (int 1 / sqrt (f ** 2 - 1))) <$> d f var + d (UnOp _ OpATanh f) var = (* (int 1 / (int 1 - f ** 2))) <$> d f var + d (UnOp _ OpLn f) var = (/ f) <$> d f var + d (UnOp _ OpLog f) var = (/ (f * log 10))<$> d f var + + -- | We allow deriving of lambda with only one argument... + d (Lambda _ [([Variable v], body)]) var = do + pushContext + addSymbol v . Formula $ Variable var + body' <- inject . listifyFormula $ Formula body + popContext + let treeIfied = unTagFormula $ treeIfyFormula body' + body'' <- d treeIfied var + return $ lambda [([Variable var], body'')] + + d f@(Lambda _ _) _ = eqError f Err.deriv_lambda + + d f@(UnOp _ OpAbs _f) _var = unTagFormula <$> + eqFail (Formula f) Err.deriv_no_abs + + d f@(Meta _ _ _) _ = eqError f Err.deriv_no_meta + d f@(UnOp _ OpFactorial _) _ = eqError f Err.deriv_no_factorial + d f@(UnOp _ OpFloor _) _ = eqError f Err.deriv_floor_not_continuous + d f@(UnOp _ OpCeil _) _ = eqError f Err.deriv_ceil_not_continuous + d f@(UnOp _ OpFrac _) _ = eqError f Err.deriv_frac_not_continuous + d f@(Sum _ _i _e _w) _var = eqError f Err.deriv_no_sum + d f@(Product _ _i _e _w) _var = eqError f Err.deriv_no_product + d f@(Derivate _ _w _v) _var = eqError f Err.deriv_in_deriv + d f@(Integrate _ _i _e _w _v) _var = eqError f Err.deriv_no_integration + d f@(Matrix _ _ _ _formulas) _var = eqError f Err.deriv_no_matrix + d f@(Truth _) _ = eqError f Err.deriv_no_bool + d (Block _ _ _) _var = eqError (Block 0 1 1) Err.deriv_block + d (List _ _) _var = eqError (Block 0 1 1) Err.deriv_no_list + +polyDerivate :: Polynome -> String -> Polynome +polyDerivate (PolyRest _) _ = PolyRest $ CoeffInt 0 +polyDerivate (Polynome _ []) _ = error Err.polynome_empty +polyDerivate (Polynome v coefs@((c,_):xs)) var + | v /= var = + let innerDerivate (coef,subPoly) = (coef, polyDerivate subPoly var) + emptyCoeff (_, (PolyRest rest)) = isCoeffNull rest + emptyCoeff _ = True + in simplifyPolynome + . Polynome v + . filter emptyCoeff + $ map innerDerivate coefs + + | otherwise = simplifyPolynome . Polynome v $ map derivator coefHead + where coefHead = if isCoeffNull c then xs else coefs + + derivator (coef, subPoly@(Polynome _ _)) = (coef - CoeffInt 1, subPoly) + derivator (coef, PolyRest subCoeff) = + (coef - CoeffInt 1, PolyRest $ coef * subCoeff) + diff --git a/EqManips/Algorithm/EmptyMonad.hs b/EqManips/Algorithm/EmptyMonad.hs new file mode 100644 --- /dev/null +++ b/EqManips/Algorithm/EmptyMonad.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE Rank2Types #-} +module EqManips.Algorithm.EmptyMonad( fromEmptyMonad, asAMonad ) where + +import Control.Applicative +import Control.Monad.Identity + +instance Applicative Identity where + pure = return + f <*> a = do + f' <- f + a' <- a + return $ f' a' + +-- | a function to unwrap empty monad, just +-- to be able to compose easily. +fromEmptyMonad :: Identity a -> a +fromEmptyMonad = runIdentity + +-- | Perform a pure computation as a monad +asAMonad :: (forall m. (Applicative m, Monad m) => (a -> m b) -> a -> m b) -- ^ Monadic function + -> (a -> b) -- ^ Pure function + -> a + -> b +asAMonad f a = fromEmptyMonad . f (Identity . a) + diff --git a/EqManips/Algorithm/Eval.hs b/EqManips/Algorithm/Eval.hs new file mode 100644 --- /dev/null +++ b/EqManips/Algorithm/Eval.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE Rank2Types #-} +module EqManips.Algorithm.Eval( reduce + , exactReduce + , evalGlobalLossyStatement + , evalGlobalLosslessStatement + ) where + +import EqManips.Types + +import EqManips.Algorithm.Cleanup + +import EqManips.Algorithm.Eval.GenericEval +import EqManips.Algorithm.Eval.GlobalStatement +import EqManips.Algorithm.Eval.Floating +import EqManips.Algorithm.Eval.Polynomial +import EqManips.Algorithm.Eval.Ratio +import EqManips.Algorithm.Eval.Complex +import EqManips.Algorithm.Eval.Types + +import EqManips.Algorithm.Simplify + +evalGlobalLossyStatement, evalGlobalLosslessStatement :: FormulaEvaluator +evalGlobalLossyStatement = evalGlobalStatement reduce' +evalGlobalLosslessStatement = evalGlobalStatement exactReduce' + +-- | Main function to evaluate another function +reduce :: FormulaEvaluator +reduce = taggedEvaluator reduce' + +-- | Main function to evaluate raw formula +reduce' :: EvalFun +reduce' f = eval reduce' (cleaner f) + >>= ratioEvalRules + >>= complexEvalRules reduce' + >>= polyEvalRules reduce' . cleaner + >>= floatEvalRules . cleaner + >>= simplifyFormula reduce' + >>= return . cleaner + where cleaner = unTagFormula . cleanupRules . Formula + +-- | Only perform non-lossy transformations +exactReduce :: FormulaEvaluator +exactReduce = taggedEvaluator exactReduce' + +-- | same as exactReduce, but perform on raw formula. +exactReduce' :: EvalFun +exactReduce' f = eval exactReduce' (cleaner f) + >>= ratioEvalRules + >>= complexEvalRules exactReduce' + >>= polyEvalRules exactReduce' . cleaner + >>= simplifyFormula reduce' + where cleaner = unTagFormula . cleanupRules . Formula + diff --git a/EqManips/Algorithm/Eval/Complex.hs b/EqManips/Algorithm/Eval/Complex.hs new file mode 100644 --- /dev/null +++ b/EqManips/Algorithm/Eval/Complex.hs @@ -0,0 +1,112 @@ +module EqManips.Algorithm.Eval.Complex( complexEvalRules ) where + +{-import qualified EqManips.ErrorMessages as Err-} +import Control.Applicative( (<$>), (<*>) ) +import EqManips.Types +import EqManips.Algorithm.Utils +import EqManips.Algorithm.Eval.Utils +import EqManips.Algorithm.Eval.Types + +#ifdef _DEBUG +import EqManips.EvaluationContext +#endif + +reshape :: FormulaPrim -> FormulaPrim +reshape = unTagFormula . listifyFormula . Formula + +-- The two following rules can generate 0 in the polynomial +-- we have to clean them +----------------------------------------------- +---- '+' +----------------------------------------------- +add :: EvalFun -> EvalOp +add eval (Complex _ (r1,i1)) (Complex _ (r2, i2)) = + (\real imag -> Left $ complex (real, imag)) + <$> eval (reshape $ r1 + r2) + <*> eval (reshape $ i1 + i2) +add eval (Complex _ (r1,i1)) rightp | isFormulaScalar rightp = + (\real -> Left $ complex (real, i1)) <$> eval (reshape $ r1 + rightp) +add eval leftp (Complex _ (r1,i1)) | isFormulaScalar leftp = + (\real -> Left $ complex (real, i1)) <$> eval (reshape $ leftp + r1) +add _ a b = right (a, b) + +----------------------------------------------- +---- '-' +----------------------------------------------- +sub :: EvalFun -> EvalOp +sub eval (Complex _ (r1,i1)) (Complex _ (r2, i2)) = + (\real imag -> Left $ complex (real, imag)) + <$> eval (reshape $ r1 - r2) + <*> eval (reshape $ i1 - i2) +sub eval (Complex _ (r1,i1)) rightp | isFormulaScalar rightp = + (\real -> Left $ complex (real, i1)) <$> eval (reshape $ r1 - rightp) +sub eval leftp (Complex _ (r1,i1)) | isFormulaScalar leftp = + (\real -> Left $ complex (real, i1)) <$> eval (reshape $ leftp - r1) +sub _ a b = right (a, b) + +----------------------------------------------- +---- '*' +----------------------------------------------- +mul :: EvalFun -> EvalOp +-- (a + ib)(a' + ib') = a*a' - b*b' + a'*ib + a*ib' +mul eval (Complex _ (r1,i1)) (Complex _ (r2, i2)) = + (\real imag -> Left $ complex (real, imag)) + <$> eval (reshape $ r1 * r2 - i1 * i2) + <*> eval (reshape $ r2 * i1 + r1 * i2) +mul eval (Complex _ (r1,i1)) rightp | isFormulaScalar rightp = + (\real imag -> Left $ complex (real, imag)) + <$> eval (reshape $ r1 * rightp) + <*> eval (reshape $ i1 * rightp) +mul eval leftp (Complex _ (r1,i1)) | isFormulaScalar leftp = + (\real imag -> Left $ complex (real, imag)) + <$> eval (reshape $ leftp * r1) + <*> eval (reshape $ leftp * i1) +mul _ a b = right (a,b) + +----------------------------------------------- +---- '/' +----------------------------------------------- +-- | Handle the division operator. Nicely handle the case +-- of division by 0. +division :: EvalFun -> EvalOp +division eval (Complex _ (a,b)) (Complex _ (c, d)) = + (\real imag -> Left $ complex (real, imag)) + <$> eval (reshape $ realNumerator / denom) + <*> eval (reshape $ imagNumerator / denom) + where realNumerator = a * c + b * d + imagNumerator = b * c - a * d + denom = c ** CInteger 2 + d ** CInteger 2 + +division eval (Complex _ (r1,i1)) rightp | isFormulaScalar rightp = +#ifdef _DEBUG + do real <- eval (reshape $ r1 / rightp) + imag <- eval (reshape $ i1 / rightp) + addTrace ("MEH", Formula $ reshape $ r1 / rightp) + addTrace ("MEH", Formula $ reshape $ i1 / rightp) + addTrace ("MEH", Formula $ complex (r1 , i1)) + addTrace ("MEH", Formula $ complex (real, imag)) + return $ Left $ complex (real, imag) +#else + (\real imag -> Left $ complex (real, imag)) + <$> eval (reshape $ r1 / rightp) + <*> eval (reshape $ i1 / rightp) +#endif + +-- TODO : WRONG! +{-division eval leftp (Complex _ (r1,i1)) | isFormulaScalar leftp =-} + {-(\real imag -> Left $ complex (real, imag))-} + {-<$> eval (reshape $ leftp / r1)-} + {-<*> eval (reshape $ leftp / i1)-} +division _ a b = right (a,b) + +----------------------------------------------- +---- General evaluation +----------------------------------------------- +-- | General evaluation/reduction function +complexEvalRules :: EvalFun -> EvalFun +complexEvalRules f (BinOp _ OpAdd fs) = binEval OpAdd (add f) (add f) fs +complexEvalRules f (BinOp _ OpSub fs) = binEval OpSub (sub f) (add f) fs +complexEvalRules f (BinOp _ OpMul fs) = binEval OpMul (mul f) (mul f) fs +complexEvalRules f (BinOp _ OpDiv fs) = binEval OpDiv (division f) (mul f) fs +complexEvalRules _ end = return end + diff --git a/EqManips/Algorithm/Eval/Floating.hs b/EqManips/Algorithm/Eval/Floating.hs new file mode 100644 --- /dev/null +++ b/EqManips/Algorithm/Eval/Floating.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE Rank2Types #-} +-- | This module implements the rules to interpret all floating +-- points operations which are by nature lossy. So this set +-- of rules may or may not be used in the context of global +-- evaluation to preserve the "true" meaning of the formula. +module EqManips.Algorithm.Eval.Floating ( evalFloat, floatEvalRules ) where + +import Control.Applicative + +import Data.Maybe( fromMaybe ) +import Data.Ratio + +import qualified EqManips.ErrorMessages as Err +import EqManips.Algorithm.Eval.Types +import EqManips.Algorithm.Eval.Utils +import EqManips.EvaluationContext +import EqManips.Types + + +-- | General function favored to use the reduction rules +-- as it preserve meta information about the formula form. +evalFloat :: Formula anyForm -> EqContext (Formula anyForm) +evalFloat (Formula f) = Formula <$> floatEvalRules f + +floatCastingOperator :: (Double -> Double -> Double) -> EvalOp +floatCastingOperator f (CInteger i1) (CFloat f2) = + left . CFloat $ f (fromIntegral i1) f2 +floatCastingOperator f (UnOp _ OpNegate (CInteger i1)) (CFloat f2) = + left . CFloat $ f (fromIntegral $ negate i1) f2 +floatCastingOperator f (CFloat f1) (CInteger i2) = + left . CFloat $ f f1 (fromIntegral i2) +floatCastingOperator f (CFloat f1) (UnOp _ OpNegate (CInteger i2)) = + left . CFloat $ f f1 (fromIntegral $ negate i2) +floatCastingOperator f (CFloat f1) (CFloat f2) = + left . CFloat $ f f1 f2 +floatCastingOperator _ e e' = right (e, e') + +add, sub, mul, division, power :: EvalOp +add = floatCastingOperator (+) +sub = floatCastingOperator (-) +mul = floatCastingOperator (*) +division = floatCastingOperator (/) +power = floatCastingOperator (**) + +----------------------------------------------- +---- 'floor' +----------------------------------------------- +floorEval :: EvalFun +floorEval (CFloat f) = return . CInteger $ floor f +floorEval f = return $ unOp OpFloor f + +----------------------------------------------- +---- 'frac' +----------------------------------------------- +fracEval :: EvalFun +fracEval (CFloat f) = return . CFloat . snd $ (properFraction f :: (Int,Double)) +fracEval f = return $ unOp OpFrac f + +----------------------------------------------- +---- 'Ceil' +----------------------------------------------- +ceilEval :: EvalFun +ceilEval i@(CInteger _) = return i +ceilEval (CFloat f) = return . CInteger $ ceiling f +ceilEval f = return $ unOp OpCeil f + +----------------------------------------------- +---- 'negate' +----------------------------------------------- +fNegate :: EvalFun +fNegate (CFloat f) = return . CFloat $ negate f +fNegate f = return $ negate f + +----------------------------------------------- +---- 'abs' +----------------------------------------------- +fAbs :: EvalFun +fAbs (CFloat f) = return . CFloat $ abs f +fAbs f = return $ abs f + +----------------------------------------------- +---- General evaluation +----------------------------------------------- +-- | All the rules for floats +floatEvalRules :: EvalFun +floatEvalRules (Fraction f) = return . CFloat $ fromInteger (numerator f) + / fromInteger (denominator f) +floatEvalRules (NumEntity Pi) = return $ CFloat pi +floatEvalRules (BinOp _ OpAdd fs) = binEval OpAdd add add fs +floatEvalRules (BinOp _ OpSub fs) = binEval OpSub sub add fs +floatEvalRules (BinOp _ OpMul fs) = binEval OpMul mul mul fs +-- | Todo fix this, it's incorrect +floatEvalRules (BinOp _ OpPow fs) = binEval OpPow power power fs +floatEvalRules (BinOp _ OpDiv fs) = binEval OpDiv division mul fs + +floatEvalRules (UnOp _ OpFloor f) = floorEval f +floatEvalRules (UnOp _ OpCeil f) = ceilEval f +floatEvalRules (UnOp _ OpFrac f) = fracEval f + +floatEvalRules (UnOp _ OpNegate f) = fNegate f +floatEvalRules (UnOp _ OpAbs f) = fAbs f + +floatEvalRules formula@(UnOp _ op f) = + return . fromMaybe formula $ unOpReduce (funOf op) f + where funOf OpSqrt = sqrt + funOf OpSin = sin + funOf OpSinh = sinh + funOf OpASin = asin + funOf OpASinh = asinh + funOf OpCos = cos + funOf OpCosh = cosh + funOf OpACos = acos + funOf OpACosh = acosh + funOf OpTan = tan + funOf OpTanh = tanh + funOf OpATan = atan + funOf OpATanh = atanh + funOf OpLn = log + funOf OpLog = logBase 10.0 + funOf OpExp = exp + funOf OpAbs = error $ Err.not_here "unop : abs - " + funOf OpNegate = error $ Err.not_here "unop : negate - " + funOf OpFloor = error $ Err.not_here "unop : floor - " + funOf OpFrac = error $ Err.not_here "unop : frac - " + funOf OpCeil = error $ Err.not_here "unop : ceil - " + funOf OpFactorial = error $ Err.not_here "unop : Should - " + +floatEvalRules end = return end + +-------------------------------------------------------------- +---- Scalar related function +-------------------------------------------------------------- +unOpReduce :: (forall a. (Floating a) => a -> a) -> FormulaPrim -> Maybe FormulaPrim +unOpReduce f (Fraction r) = unOpReduce f . CFloat $ fromRational r +unOpReduce f (CInteger i) = unOpReduce f . CFloat $ fromInteger i +unOpReduce f (CFloat num) = Just . CFloat $ f num +unOpReduce _ _ = Nothing + diff --git a/EqManips/Algorithm/Eval/GenericEval.hs b/EqManips/Algorithm/Eval/GenericEval.hs new file mode 100644 --- /dev/null +++ b/EqManips/Algorithm/Eval/GenericEval.hs @@ -0,0 +1,547 @@ +{-# LANGUAGE Rank2Types #-} +module EqManips.Algorithm.Eval.GenericEval ( eval ) where + +import Data.Ratio + +import qualified EqManips.ErrorMessages as Err +import Control.Applicative +import EqManips.Types +import EqManips.Conf +import EqManips.EvaluationContext +import EqManips.Algorithm.Cleanup +import EqManips.Algorithm.Inject +import EqManips.Algorithm.Derivative +import EqManips.Algorithm.Utils +import EqManips.Algorithm.Eval.Meta + +import EqManips.Algorithm.Unification +import EqManips.Algorithm.Eval.Types +import EqManips.Algorithm.Eval.Utils + +import Data.List( transpose, foldl' ) + +----------------------------------------------- +---- '+' +----------------------------------------------- +add :: EvalFun -> EvalOp +add _ (CInteger i1) (CInteger i2) = left . CInteger $ i1 + i2 +-- Handle negation, as we may not know which cleaning has been performed +-- on the formula. +add _ (CInteger i1) (UnOp _ OpNegate (CInteger i2)) = left . CInteger $ i1 - i2 +add _ (UnOp _ OpNegate (CInteger i1)) (CInteger i2) = left . CInteger $ negate i1 + i2 +add _ (UnOp _ OpNegate (CInteger i1)) (UnOp _ OpNegate (CInteger i2)) = + left . CInteger $ negate i1 + negate i2 +add evaluator f1@(Matrix _ _ _ _) f2@(Matrix _ _ _ _) = + matrixMatrixSimple evaluator (+) f1 f2 +add _ f1@(Matrix _ _ _ _) f2 = do + _ <- eqPrimFail (f1+f2) Err.add_matrix + right (f1, f2) +add _ f1 f2@(Matrix _ _ _ _) = do + _ <- eqPrimFail (f1+f2) Err.add_matrix + right (f1, f2) +add _ e e' = right (e, e') + +----------------------------------------------- +---- '-' +----------------------------------------------- +sub :: EvalFun -> EvalOp +sub _ (CInteger i1) (CInteger i2) = left . CInteger $ i1 - i2 +sub _ (CInteger i1) (UnOp _ OpNegate (CInteger i2)) = left . CInteger $ i1 - negate i2 +sub _ (UnOp _ OpNegate (CInteger i1)) (CInteger i2) = left . CInteger $ negate i1 - i2 +sub _ (UnOp _ OpNegate (CInteger i1)) (UnOp _ OpNegate (CInteger i2)) = + left . CInteger $ negate i1 - negate i2 +sub evaluator f1@(Matrix _ _ _ _) f2@(Matrix _ _ _ _) = + matrixMatrixSimple evaluator (-) f1 f2 +sub _ f1@(Matrix _ _ _ _) f2 = do + _ <- eqPrimFail (f1-f2) Err.sub_matrix + right (f1, f2) +sub _ f1 f2@(Matrix _ _ _ _) = do + _ <- eqPrimFail (f1-f2) Err.sub_matrix + right (f1, f2) +sub _ e e' = right (e,e') + +----------------------------------------------- +---- '*' +----------------------------------------------- +mul :: EvalFun -> EvalOp +mul _ (CInteger i1) (CInteger i2) = left . CInteger $ i1 * i2 +mul _ (CInteger i1) (UnOp _ OpNegate (CInteger i2)) = left . CInteger $ i1 * negate i2 +mul _ (UnOp _ OpNegate (CInteger i1)) (CInteger i2) = left . CInteger $ negate i1 * i2 +mul _ (UnOp _ OpNegate (CInteger i1)) (UnOp _ OpNegate (CInteger i2)) = + left . CInteger $ i1 * i2 +mul evaluator f1@(Matrix _ _ _ _) f2@(Matrix _ _ _ _) = matrixMatrixMul evaluator f1 f2 +mul evaluator m@(Matrix _ _ _ _) s = matrixScalar evaluator (*) m s >>= left +mul evaluator s m@(Matrix _ _ _ _) = matrixScalar evaluator (*) m s >>= left +mul _ e e' = right (e, e') + +----------------------------------------------- +---- '/' +----------------------------------------------- +-- | Handle the division operator. Nicely handle the case +-- of division by 0. +division :: EvalFun -> EvalOp +division _ l@(Matrix _ _ _ _) r@(Matrix _ _ _ _) = do + _ <- eqPrimFail (l / r) Err.div_undefined_matrixes + left $ Block 1 1 1 + +division _ f1 f2@(CInteger 0) = do + _ <- eqPrimFail (f1 / f2) Err.div_by_0 + left $ Block 1 1 1 + +division _ f1 f2@(CFloat 0) = do + _ <- eqPrimFail (f1 / f2) Err.div_by_0 + left $ Block 1 1 1 + +division _ (CInteger i1) (CInteger i2) + | i1 `mod` i2 == 0 = left . CInteger $ i1 `div` i2 + +division _ (CInteger i1) (UnOp _ OpNegate (CInteger i2)) + | i1 `mod` i2 == 0 = left . negate . CInteger $ i1 `div` i2 + +division _ (UnOp _ OpNegate (CInteger i1)) (CInteger i2) + | i1 `mod` i2 == 0 = left . negate . CInteger $ i1 `div` i2 + +division _ (UnOp _ OpNegate (CInteger i1)) (UnOp _ OpNegate (CInteger i2)) + | i1 `mod` i2 == 0 = left . CInteger $ i1 `div` i2 + +division evaluator m@(Matrix _ _ _ _) s = matrixScalar evaluator (/) m s >>= left +division evaluator s m@(Matrix _ _ _ _) = matrixScalar evaluator (/) m s >>= left +division _ f1 f2 = right (f1, f2) + +----------------------------------------------- +---- '^' +----------------------------------------------- +-- | yeah handle all the power operation. +power :: EvalOp +power f1 (CInteger i2) | i2 < 0 = return . Left $ CInteger 1 / (f1 ** CInteger (-i2)) +power (CInteger i1) (CInteger i2) = return . Left . CInteger $ i1 ^ i2 +power f1 f2 = return . Right $ (f1, f2) + +----------------------------------------------- +---- '!' +----------------------------------------------- +factorial :: EvalFun +factorial f@(CFloat _) = eqPrimFail f Err.factorial_on_real +factorial (CInteger 0) = return $ CInteger 1 +factorial f@(CInteger i) | i > 0 = return . CInteger $ product [1 .. i] + | otherwise = eqPrimFail f Err.factorial_negative +factorial f@(Matrix _ _ _ _) = eqPrimFail f Err.factorial_matrix +factorial a = return $ unOp OpFactorial a + +----------------------------------------------- +---- 'floor' +----------------------------------------------- +floorEval :: EvalFun +floorEval i@(CInteger _) = return i +floorEval f = return $ unOp OpFloor f + +----------------------------------------------- +---- 'frac' +----------------------------------------------- +fracEval :: EvalFun +fracEval (CInteger _) = return $ CInteger 0 +fracEval f = return $ unOp OpFrac f + +----------------------------------------------- +---- 'Ceil' +----------------------------------------------- +ceilEval :: EvalFun +ceilEval i@(CInteger _) = return i +ceilEval f = return $ unOp OpCeil f + +----------------------------------------------- +---- 'negate' +----------------------------------------------- +fNegate :: EvalFun +fNegate (CInteger i) = return . CInteger $ negate i +fNegate (UnOp _ OpNegate f) = return f +fNegate f = return $ negate f + +----------------------------------------------- +---- 'abs' +----------------------------------------------- +fAbs :: EvalFun +fAbs (CInteger i) = return . CInteger $ abs i +fAbs (UnOp _ OpNegate (CInteger i)) = return . CInteger $ abs i +fAbs f = return $ abs f + +----------------------------------------------- +---- 'Comparison operators' +----------------------------------------------- +predicateList :: BinOperator -> EvalPredicate -> [FormulaPrim] -> EqContext FormulaPrim +predicateList _ _ [] = error $ Err.empty_binop "predicate list - " +predicateList _ _ [_] = error $ Err.single_binop "predicate list - " +predicateList op f (x:y:xs) = lastRez + {-. lastCase -} + $ foldl' transform ([], False, x) (y:xs) + where transform (acc@[Truth False],_,_) curr = (acc, False, curr) + transform (acc, allWritten, prev) curr = + case (f prev curr, allWritten) of + (Nothing, True) -> (acc ++ [curr], True, curr) + (Nothing, False) -> (acc ++ [prev, curr], True, curr) + (Just True, _) -> (acc, False, curr) + (Just False, _) -> ([Truth False], True, curr) + + lastRez ([],_,_) = return $ Truth True + lastRez ([e],_,_) = return e + lastRez (lst,_,_) = return $ binOp op lst + + +equality, inequality :: [FormulaPrim] -> EqContext FormulaPrim +equality = eqApplying (==) OpEq +inequality = eqApplying (/=) OpNe + +eqApplying :: (forall a. Eq a => a -> a -> Bool) -> BinOperator + -> [FormulaPrim] -> EqContext FormulaPrim +eqApplying _ _ [] = return $ Block 1 1 1 +eqApplying f op (x:xs) = return . reOp . fst $ foldr applyer (Just [x], x) xs + where reOp Nothing = Truth False + reOp (Just [_]) = Truth True + reOp (Just a) = binOp op a + + applyer val (Nothing, _) = (Nothing, val) + applyer val (Just acc, prev) = case equalityOperator f prev val of + Nothing -> (Just $ val : acc, val) + Just False -> (Nothing, val) + Just True -> (Just acc, val) + +-- | In charge of implementing the casting for '=' and '/=' +-- operators. +equalityOperator :: (forall a. Eq a => a -> a -> Bool) + -> FormulaPrim -> FormulaPrim + -> Maybe Bool +equalityOperator f (CInteger a) (CInteger b) = Just $ f a b + +-- Fraction/Int +equalityOperator f (Fraction a) (Fraction b) = Just $ f a b +equalityOperator f (CInteger a) (Fraction b) = Just $ f (a % 1) b +equalityOperator f (Fraction a) (CInteger b) = Just $ f a (b % 1) + +-- Float/Int +equalityOperator f (CFloat a) (CFloat b) = Just $ f a b +equalityOperator f a@(CFloat _) (CInteger b) = + equalityOperator f a . CFloat $ fromIntegral b +equalityOperator f (CInteger a) b@(CFloat _) = + equalityOperator f (CFloat $ fromIntegral a) b + +-- Complex/Other +equalityOperator f (Complex _ (r1, i1)) (Complex _ (r2, i2)) = + (&&) <$> equalityOperator f r1 r2 + <*> equalityOperator f i1 i2 + +equalityOperator f number a@(Complex _ (r, i)) + | isFormulaScalar a = (&&) <$> equalityOperator f number r + <*> equalityOperator f (CInteger 0) i +equalityOperator _ _ _ = Nothing + + +-- | Casting for comparaison operator. +compOperator :: (forall a. Ord a => a -> a -> Bool) + -> FormulaPrim -> FormulaPrim + -> Maybe Bool +compOperator f (CInteger a) (CInteger b) = Just $ f a b +compOperator f (CFloat a) (CFloat b) = Just $ f a b +compOperator f (Fraction a) (Fraction b) = Just $ f a b +compOperator f (CInteger a) (Fraction b) = Just $ f (a % 1) b +compOperator f (Fraction a) (CInteger b) = Just $ f a (b % 1) +compOperator f a@(CFloat _) (CInteger b) = + compOperator f a . CFloat $ fromIntegral b +compOperator f (CInteger a) b@(CFloat _) = + compOperator f (CFloat $ fromIntegral a) b +compOperator _ _ _ = Nothing + +----------------------------------------------- +---- AND +----------------------------------------------- +binand :: EvalOp +binand (Truth True) (Truth True) = return . Left $ Truth True +binand (Truth False) _ = return . Left $ Truth False +binand _ (Truth False) = return . Left $ Truth False +binand (Truth True) l = return . Left $ l +binand l (Truth True) = return . Left $ l +binand a b = return $ Right (a,b) + +----------------------------------------------- +---- OR +----------------------------------------------- +binor :: EvalOp +binor (Truth False) (Truth False) = return . Left $ Truth False +binor (Truth True) _ = return . Left $ Truth True +binor _ (Truth True) = return . Left $ Truth True +binor (Truth False) l = return . Left $ l +binor l (Truth False) = return . Left $ l +binor a b = return $ Right (a,b) + +----------------------------------------------- +---- lalalal operators +----------------------------------------------- +metaEvaluation :: EvalFun -> MetaOperation -> EvalFun +metaEvaluation evaluator m f = unTagFormula + <$> metaEval (taggedEvaluator evaluator) m (Formula f) + +-- | Used to create matrix from lists +matrixCreate :: [FormulaPrim] -> EqContext FormulaPrim +matrixCreate [List _ whole@(List _ subList:rest)] + | and $ map isAllList rest = + pure . matrix rowCount columnsCount $ map subListExtract whole + where columnsCount = length subList + rowCount = length rest + 1 + + isAllList (List _ lst) = length lst == columnsCount + isAllList _ = False + + subListExtract (List _ lst) = lst + subListExtract _ = error "Extracting sublist of non-list" + +matrixCreate [(List _ elems)] = pure $ matrix 1 (length elems) [elems] + +matrixCreate [CInteger 1, CInteger m, List _ elems] + | length elems == (fromInteger m) = + return $ matrix 1 (fromInteger m) [elems] + +matrixCreate [CInteger n, CInteger 1, List _ elems] + | length elems == (fromInteger n) = + return . matrix (fromInteger n) 1 $ map (:[]) elems + +matrixCreate args = pure $ app (Variable "matrix") args + +-------------------------------------------------- +---- Indexation +-------------------------------------------------- +indexCompute :: FormulaPrim -> [FormulaPrim] -> EqContext FormulaPrim +indexCompute a [] = return a +indexCompute n@(CInteger _) idx = eqPrimFail (indexes n idx) Err.integer_not_indexable +indexCompute n@(CFloat _) idx = eqPrimFail (indexes n idx) Err.float_not_indexable + +indexCompute mm@(Matrix _ 1 m lst) idxs@(CInteger i : rest) + | i >= 1 && m >= fromInteger i = indexCompute (lst !! (fromInteger i - 1) !! 0) rest + | otherwise = eqPrimFail (indexes mm idxs) Err.out_of_bound_index + +indexCompute mm@(Matrix _ n 1 lst) idxs@(CInteger i : rest) + | i >= 1 && n >= fromInteger i = indexCompute (lst !! 0 !! (fromInteger i - 1)) rest + | otherwise = eqPrimFail (indexes mm idxs) Err.out_of_bound_index + +indexCompute mm@(Matrix _ n m lst) idxs@(CInteger i : CInteger j : rest) + | i >= 1 && i <= toInteger n && j >= 1 && j <= toInteger m = + indexCompute (lst !! (fromInteger i - 1) !! (fromInteger j - 1)) rest + | otherwise = eqPrimFail (indexes mm idxs) Err.out_of_bound_index + +indexCompute m@(Matrix _ n _ lst) idx@[CInteger i] + | i >= 1 && i <= toInteger n = return . list $ lst !! (fromInteger i - 1) + | otherwise = eqPrimFail (indexes m idx) Err.out_of_bound_index + +indexCompute l@(List _ lst) idx@(CInteger i : rest) + | i - 1 < toInteger (length lst) = indexCompute (lst !! (fromInteger i - 1)) rest + | otherwise = eqPrimFail (indexes l idx) Err.out_of_bound_index + +indexCompute a b = return $ indexes a b + +-------------------------------------------------- +---- Cons evaluation +-------------------------------------------------- +consEval :: EvalOp +consEval (List _ lst) toAppend = left $ list (toAppend : lst) +consEval l toAppend = + eqPrimFail (binOp OpCons [toAppend, l]) Err.eval_not_list >>= left + +----------------------------------------------- +---- General evaluation +----------------------------------------------- +-- | General evaluation/reduction function +eval :: EvalFun -> EvalFun +eval evaluator (Meta _ m f) = metaEvaluation evaluator m f +eval _ (NumEntity Pi) = return $ CFloat pi +eval evaluator (Matrix _ n m mlines) = do + cells <- sequence [mapM evaluator line | line <- mlines] + return $ matrix n m cells +eval evaluator (List _ l) = do list <$> mapM evaluator l +eval _ func@(Lambda _ _) = unTagFormula <$> inject (Formula func) +eval _ (Variable v) = do + symbol <- symbolLookup v + case symbol of + Nothing -> return $ Variable v + Just (Formula (f)) -> return f + +eval evaluator (App _ (Variable "matrix") args) = + mapM evaluator args >>= matrixCreate + +eval evaluator fullApp@(App _ def var) = do + redDef <- evaluator def + redVar <- mapM evaluator var +#ifdef _DEBUG + addTrace ("Appbegin |", treeIfyFormula . Formula $ app redDef redVar) +#endif + needApply redDef redVar + where needApply :: FormulaPrim -> [FormulaPrim] -> EqContext FormulaPrim + needApply (Lambda _ funArgs) args' = + case getFirstUnifying funArgs args' of + Nothing -> eqPrimFail (app def var) Err.app_no_applygindef + Just (body, subst) -> do + pushContext + addSymbols [ (name, Formula formula) + | (name, formula) <- subst] +#ifdef _DEBUG + addTrace ("subst | " ++ show subst, treeIfyFormula $ Formula body) +#endif + depth <- contextStackSize + if depth > maxRecursiveDepth + then eqFail (treeIfyFormula $ Formula fullApp) Err.max_recursion + >>= return . unTagFormula + else do + body' <- evaluator body +#ifdef _DEBUG + addTrace ("body' | " ++ show body', treeIfyFormula $ Formula body') +#endif + popContext + return body' + needApply def' args = + return $ app def' args + +eval evaluator (BinOp _ OpAdd fs) = + binEval OpAdd (add evaluator) (add evaluator) =<< mapM evaluator fs +eval evaluator (BinOp _ OpSub fs) = + binEval OpSub (sub evaluator) (add evaluator) =<< mapM evaluator fs +eval evaluator (BinOp _ OpMul fs) = + binEval OpMul (mul evaluator) (mul evaluator) =<< mapM evaluator fs +eval evaluator (BinOp _ OpCons fs) = + binEval OpCons consEval consEval =<< mapM evaluator fs + +-- | Todo fix this, it's incorrect +eval evaluator (BinOp _ OpPow fs) = binEval OpPow power power =<< mapM evaluator fs +eval evaluator (BinOp _ OpDiv fs) = + binEval OpDiv (division evaluator) (mul evaluator) =<< mapM evaluator fs + +-- comparisons operators +eval evaluator (BinOp _ OpLt fs) = predicateList OpLt (compOperator (<)) =<< mapM evaluator fs +eval evaluator (BinOp _ OpGt fs) = predicateList OpGt (compOperator (>)) =<< mapM evaluator fs +eval evaluator (BinOp _ OpLe fs) = predicateList OpLe (compOperator (<=)) =<< mapM evaluator fs +eval evaluator (BinOp _ OpGe fs) = predicateList OpGe (compOperator (>=)) =<< mapM evaluator fs + +eval evaluator (BinOp _ OpNe fs) = mapM evaluator fs >>= inequality +eval evaluator (BinOp _ OpEq lst) = mapM evaluator lst >>= equality + +eval evaluator (BinOp _ OpAnd fs) = binEval OpAnd binand binand =<< mapM evaluator fs +eval evaluator (BinOp _ OpOr fs) = binEval OpOr binor binor =<< mapM evaluator fs + +-- | Special case for programs, don't evaluate left :] +eval evaluator (BinOp _ OpAttrib [a,b]) = + binOp OpAttrib . (a:) . (:[]) <$> evaluator b + +eval _ f@(BinOp _ OpAttrib _) = eqPrimFail f Err.attrib_in_expr + +eval evaluator (UnOp _ OpFactorial f) = factorial =<< evaluator f +eval evaluator (UnOp _ OpFloor f) = floorEval =<< evaluator f +eval evaluator (UnOp _ OpCeil f) = ceilEval =<< evaluator f +eval evaluator (UnOp _ OpFrac f) = fracEval =<< evaluator f + +eval evaluator (UnOp _ OpNegate f) = fNegate =<< evaluator f +eval evaluator (UnOp _ OpAbs f) = fAbs =<< evaluator f + +eval evaluator (UnOp _ op f) = return . unOp op =<< evaluator f + +eval evaluator f@(Derivate _ what varSpec) = do + var'<- metaFilter evaluator varSpec + what' <- metaFilter evaluator what + derivator what' var' + where derivator toDeriv (Variable v) = do +#ifdef _DEBUG + addTrace ("Derivation on " ++ v, treeIfyFormula . Formula $ toDeriv) +#endif + derived <- derivateFormula v $ Formula toDeriv + return . unTagFormula $ cleanup derived + derivator _ _ = eqPrimFail f Err.deriv_bad_var_spec + +eval evaluator (Indexes _ what lst) = do + what' <- evaluator what + lst' <- mapM evaluator lst + indexCompute what' lst' + +eval evaluator formu@(Sum _ (BinOp _ OpEq [Variable v, inexpr]) endexpr f) = do + inexpr' <- evaluator inexpr + endexpr' <- evaluator endexpr + sumEval inexpr' endexpr' + where sumEval (CInteger initi) (CInteger endi) + | initi <= endi = iterateFormula evaluator (binOp OpAdd) v initi endi f + | otherwise = eqPrimFail formu Err.sum_wrong_bounds + sumEval ini end = return $ summ (binOp OpEq [Variable v, ini]) end f + + +eval evaluator formu@(Product _ (BinOp _ OpEq [Variable v, inexpr]) endexpr f) = do + inexpr' <- evaluator inexpr + endexpr' <- evaluator endexpr + prodEval inexpr' endexpr' + where prodEval (CInteger initi) (CInteger endi) + | initi <= endi = iterateFormula evaluator (binOp OpMul) v initi endi f + | otherwise = eqPrimFail formu Err.sum_wrong_bounds + prodEval ini end = return $ productt (binOp OpEq [Variable v, ini]) end f + +eval _ f@(Integrate _ _ _ _ _) = + eqPrimFail f Err.integration_no_eval + +eval _ f@(Block _ _ _) = eqPrimFail f Err.block_eval +eval _ end = return end + +-------------------------------------------------------------- +---- iteration +-------------------------------------------------------------- +iterateFormula :: EvalFun + -> ([FormulaPrim] -> FormulaPrim) + -> String -> Integer -> Integer -> FormulaPrim + -> EqContext FormulaPrim +iterateFormula evaluator op ivar initi endi what = do + pushContext + rez <- mapM combiner [initi .. endi] + popContext + case rez of + [x] -> evaluator x + _ -> evaluator $ op rez + where combiner i = do + addSymbol ivar (Formula $ CInteger i) + unTagFormula <$> inject (Formula what) + +-------------------------------------------------------------- +---- Matrix related functions +-------------------------------------------------------------- +matrixScalar :: EvalFun + -> FormulOperator + -> FormulaPrim -> FormulaPrim + -> EqContext FormulaPrim +matrixScalar evaluator op s m@(Matrix _ _ _ _) = matrixScalar evaluator op m s +matrixScalar evaluator op (Matrix _ n m mlines) s = matrix n m <$> cell + where cell = sequence + [ mapM (evaluator . (`op` s)) line | line <- mlines] +matrixScalar _ _ _ _ = error Err.matrixScalar_badop + +-- | Multiplication between two matrix. Check for matrix sizes. +matrixMatrixMul :: EvalFun -> EvalOp +matrixMatrixMul evaluator m1@(Matrix _ n _ mlines) m2@(Matrix _ n' m' mlines') + | n /= m' = do _ <- eqFail (Formula $ binOp OpMul [m1, m2]) Err.matrix_mul_bad_size + right (m1, m2) + | otherwise = cellLine >>= left . matrix n n' + where cellLine = sequence + [ sequence [multCell $ zip line row | row <- transpose mlines' ] + | line <- mlines] + + multCell l = evaluator $ foldl' multAtor (initCase l) (tail l) + multAtor acc (l, r) = acc + (l * r) + + initCase ((x,y):_) = x * y + initCase _ = error . Err.shouldnt_happen $ Err.matrix_empty ++ " - " + +matrixMatrixMul _ _ _ = error $ Err.shouldnt_happen "matrixMatrixMul - " + +-- | Simple operation, matrix addition or substraction +matrixMatrixSimple :: EvalFun + -> FormulOperator + -> FormulaPrim -> FormulaPrim + -> EqContext (Either FormulaPrim (FormulaPrim,FormulaPrim)) +matrixMatrixSimple evaluator op m1@(Matrix _ n m mlines) m2@(Matrix _ n' m' mlines') + | n /= n' || m /= m' = do + _ <- eqFail (Formula $ m1 `op` m2) Err.matrix_diff_size + return $ Right (m1, m2) + | otherwise = Left . matrix n m <$> newCells + where dop (e1, e2) = evaluator $ e1 `op`e2 + newCells = sequence [ mapM dop $ zip line1 line2 + | (line1, line2) <- zip mlines mlines'] +matrixMatrixSimple _ _ _ _ = error $ Err.shouldnt_happen "matrixMatrixSimple" + diff --git a/EqManips/Algorithm/Eval/GlobalStatement.hs b/EqManips/Algorithm/Eval/GlobalStatement.hs new file mode 100644 --- /dev/null +++ b/EqManips/Algorithm/Eval/GlobalStatement.hs @@ -0,0 +1,71 @@ +module EqManips.Algorithm.Eval.GlobalStatement( evalGlobalStatement ) where + +import qualified EqManips.ErrorMessages as Err +import EqManips.Types +import EqManips.EvaluationContext + +import EqManips.Algorithm.Eval.Types + + +-- | Add a function into the symbol table. +addLambda :: String -> [Formula ListForm] -> Formula ListForm -> EqContext () +addLambda varName args body = do + symb <- symbolLookup varName + case symb of + Nothing -> addSymbol varName . Formula + $ lambda [(map unTagFormula args, unTagFormula body)] + Just (Formula (Lambda _ clauses@((prevArg,_):_))) -> + if length prevArg /= length args + then do + _ <- eqFail (Formula $ Variable varName) Err.def_diff_argcount + return () + else updateSymbol varName . Formula . lambda + $ clauses ++ [(map unTagFormula args + , unTagFormula body)] + + Just _ -> do + _ <- eqFail (Formula $ Variable varName) $ Err.def_not_lambda varName + return () + +-- | Add a "value" into the symbol table +addVar :: String -> Formula ListForm -> EqContext () +addVar varName body = do + symb <- symbolLookup varName + case symb of + Nothing -> addSymbol varName body + Just _ -> do + _ <- eqFail (Formula $ Variable varName) $ Err.def_already varName + return () + +-- | Evaluate top level declarations +evalGlobalStatement :: EvalFun -> Formula ListForm -> EqContext (Formula ListForm) +evalGlobalStatement evaluator (Formula (BinOp _ OpAttrib [ (App _ (Variable funName) argList) + , body ])) = do + pushContext + body' <- evaluator body + popContext + addLambda funName (map Formula argList) (Formula body') + return $ Formula (binOp OpAttrib [(app (Variable funName) argList), body]) + +evalGlobalStatement _ (Formula (BinOp _ OpLazyAttrib [ (App _ (Variable funName) argList) + , body ])) = do + addLambda funName (map Formula argList) (Formula body) + return $ Formula (binOp OpLazyAttrib [(app (Variable funName) argList), body]) + +evalGlobalStatement evaluator (Formula (BinOp _ OpAttrib [(Variable varName), body])) = do + pushContext + body' <- evaluator body + popContext + addVar varName (Formula body') + return $ Formula (binOp OpAttrib [(Variable varName), body']) + +evalGlobalStatement _ (Formula (BinOp _ OpLazyAttrib [(Variable varName), body])) = do + addVar varName (Formula body) + return $ Formula (binOp OpLazyAttrib [(Variable varName), body]) + +evalGlobalStatement evaluator (Formula e) = do + pushContext + a <- evaluator e + popContext + return $ Formula a + diff --git a/EqManips/Algorithm/Eval/Meta.hs b/EqManips/Algorithm/Eval/Meta.hs new file mode 100644 --- /dev/null +++ b/EqManips/Algorithm/Eval/Meta.hs @@ -0,0 +1,49 @@ +module EqManips.Algorithm.Eval.Meta ( metaEval + , metaFilter + ) where + +import Control.Applicative +import Data.List( sort ) + +import EqManips.Algorithm.Utils +import EqManips.Algorithm.Expand +import EqManips.Algorithm.Cleanup +import EqManips.Algorithm.Eval.Types +import EqManips.Types +import EqManips.EvaluationContext +import EqManips.FormulaIterator + +import qualified EqManips.ErrorMessages as Err + +-- | The only meta evaluation avaible +metaEval :: (Formula ListForm -> EqContext (Formula ListForm)) + -> MetaOperation + -> Formula ListForm + -> EqContext (Formula ListForm) +metaEval evaluator Force f = evaluator f +metaEval evaluator Cleanup f = return . cleanup =<< evaluator f +metaEval _ Hold f = return f +metaEval _ Expand f = return . listifyFormula . expand . treeIfyFormula $ f + +metaEval evaluator Sort (Formula (List _ lst)) = + Formula . list . sort <$> mapM unclap lst + where unclap formu = unTagFormula <$> evaluator (Formula formu) +metaEval evaluator Sort f = return . sortFormula =<< evaluator f + +metaEval evaluator LambdaBuild (Formula (Lambda _ [([arg], body)])) = do + arg' <- metaFilter (\a -> unTagFormula <$> (evaluator $ Formula a)) arg + body' <- metaFilter (\a -> unTagFormula <$> (evaluator $ Formula a)) body + return . Formula $ lambda [([arg'], body')] +metaEval _ LambdaBuild _ = eqFail (Formula $ Block 1 1 1) Err.wrong_lambda_format + + +-- | Run across the formula to find meta evaluation and then +-- evaluate it. Used to level the use of Force/Hold & everyting. +metaFilter :: EvalFun -> FormulaPrim -> EqContext FormulaPrim +metaFilter evaluator formu = topDownScanning metaCatch formu + where metaCatch (Meta _ op f) = Just . unTagFormula + <$> (metaEval eval' op $ Formula f) + metaCatch _ = pure Nothing + + eval' a = Formula <$> (evaluator $ unTagFormula a) + diff --git a/EqManips/Algorithm/Eval/Polynomial.hs b/EqManips/Algorithm/Eval/Polynomial.hs new file mode 100644 --- /dev/null +++ b/EqManips/Algorithm/Eval/Polynomial.hs @@ -0,0 +1,143 @@ +module EqManips.Algorithm.Eval.Polynomial( polyEvalRules ) where + +import Data.Either( partitionEithers ) + +import qualified EqManips.ErrorMessages as Err +import EqManips.Types +import EqManips.Polynome +import EqManips.EvaluationContext +import EqManips.Algorithm.Cleanup +import EqManips.Algorithm.Utils +import EqManips.Algorithm.Eval.Utils +import EqManips.Algorithm.Eval.Types + +leftclean :: FormulaPrim -> EqContext (Either FormulaPrim a) +leftclean = left . unTagFormula . cleanup . Formula + +-- The two following rules can generate 0 in the polynomial +-- we have to clean them +----------------------------------------------- +---- '+' +----------------------------------------------- +add :: EvalOp +add (Poly _ p1) (Poly _ p2) = leftclean . poly $ p1 + p2 +add v1 (Poly _ p) | isFormulaScalar v1 = leftclean . poly $ (PolyRest $ scalarToCoeff v1) + p +add (Poly _ p) v2 | isFormulaScalar v2 = leftclean . poly $ p + (PolyRest $ scalarToCoeff v2) +add (Variable v) (Poly _ p) = leftclean . poly $ Polynome v [(CoeffInt 1, PolyRest $ CoeffInt 1)] + p +add (Poly _ p) (Variable v) = left . poly $ p + Polynome v [(CoeffInt 1, PolyRest $ CoeffInt 1)] + +add (BinOp _ OpPow [Variable v, degree]) (Poly _ p) + | isFormulaScalar degree = leftclean . poly $ Polynome v [(scalarToCoeff degree, PolyRest $ CoeffInt 1)] + p +add (Poly _ p) (BinOp _ OpPow [Variable v, degree]) + | isFormulaScalar degree = leftclean . poly $ p + Polynome v [(scalarToCoeff degree, PolyRest $ CoeffInt 1)] +add e e' = right (e, e') + +----------------------------------------------- +---- '-' +----------------------------------------------- +sub :: EvalOp +#ifdef _DEBUG +sub leftArg@(Poly _ p1) rightArg@(Poly _ p2) = + addTrace ( "Polynome/Polynome '-'" + , treeIfyFormula . Formula + $ leftArg - rightArg) >> +#else +sub (Poly _ p1) (Poly _ p2) = +#endif + leftclean (poly $ p1 - p2) + +sub v1 (Poly _ p) | isFormulaScalar v1 = leftclean . poly $ (PolyRest $ scalarToCoeff v1) - p +sub (Poly _ p) v2 | isFormulaScalar v2 = leftclean . poly $ p - (PolyRest $ scalarToCoeff v2) +sub (Variable v) (Poly _ p) = leftclean . poly $ Polynome v [(CoeffInt 1, PolyRest $ CoeffInt 1)] - p +sub (Poly _ p) (Variable v) = leftclean . poly $ p - Polynome v [(CoeffInt 1, PolyRest $ CoeffInt 1)] +sub (BinOp _ OpPow [Variable v, degree]) (Poly _ p) + | isFormulaScalar degree = leftclean . poly $ Polynome v [(scalarToCoeff degree, PolyRest $ CoeffInt 1)] - p +sub (Poly _ p) (BinOp _ OpPow [Variable v, degree]) + | isFormulaScalar degree = leftclean . poly $ p - Polynome v [(scalarToCoeff degree, PolyRest $ CoeffInt 1)] +sub e e' = right (e,e') + +----------------------------------------------- +---- '*' +----------------------------------------------- +mul :: EvalOp +mul (Poly _ p1) (Poly _ p2) = left . poly $ p1 * p2 +mul v1 (Poly _ p) | isFormulaScalar v1 = left . poly $ polyCoeffMap (scalarToCoeff v1 *) p +mul (Poly _ p) v2 | isFormulaScalar v2 = left . poly $ polyCoeffMap (* scalarToCoeff v2) p +mul (Variable v) (Poly _ p) = left . poly $ Polynome v [(CoeffInt 1, PolyRest $ CoeffInt 1)] * p +mul (Poly _ p) (Variable v) = left . poly $ p * Polynome v [(CoeffInt 1, PolyRest $ CoeffInt 1)] +mul (BinOp _ OpPow [Variable v, degree]) (Poly _ p) + | isFormulaScalar degree = left . poly $ Polynome v [(scalarToCoeff degree, PolyRest $ CoeffInt 1)] * p +mul (Poly _ p) (BinOp _ OpPow [Variable v, degree]) + | isFormulaScalar degree = left . poly $ p * Polynome v [(scalarToCoeff degree, PolyRest $ CoeffInt 1)] +mul e e' = right (e, e') + +----------------------------------------------- +---- '/' +----------------------------------------------- +-- | Handle the division operator. Nicely handle the case +-- of division by 0. +division :: EvalOp +division v1 (Poly _ p) | isFormulaScalar v1 = left . poly $ polyCoeffMap (scalarToCoeff v1 /) p +division (Poly _ p) v2 | isFormulaScalar v2 = left . poly $ polyCoeffMap (/ scalarToCoeff v2) p +division p1@(Poly _ p) p2f@(Poly _ p2) = + let unconstruct = unTagFormula . cleanupRules . Formula . polyAsFormula + in case syntheticDiv p p2 of + (Nothing, Nothing) -> right (p1, p2f) + (Nothing, Just _) -> right (p1, p2f) + (Just quotient, Nothing) -> left $ unconstruct quotient + (Just quotient, Just rest) -> left $ unconstruct quotient + + ( unconstruct rest + / unconstruct p2) +division f1 f2 = right (f1, f2) + +-- | If a polynome's variable is bound, replace it by the real +-- the value. +substitutePolynome :: EvalFun -> Polynome -> Formula ListForm -> EqContext FormulaPrim +substitutePolynome _ (PolyRest _) _ = error Err.polynome_no_coeff_substitution +substitutePolynome evaluator (Polynome _var coefs) (Formula subst) = + evaluator $ binOp OpAdd added + where added = [formulize subPoly * (subst ** coefToFormula degree) | (degree, subPoly) <- coefs] + formulize (PolyRest coeff) = coefToFormula coeff + formulize normalPolynome = poly normalPolynome + +checkPolynomeBinding :: EvalFun -> Polynome -> EqContext (Either Polynome FormulaPrim) +checkPolynomeBinding _ p@(PolyRest _) = return $ Left p +checkPolynomeBinding evaluator pol@(Polynome var coefList) = do + varBound <- symbolLookup var + case varBound of + Just bound -> + substitutePolynome evaluator pol bound >>= (return . Right) + Nothing -> do + subs <- mapM (\(coeff,p) -> do + subPoly <- checkPolynomeBinding evaluator p + case subPoly of + Left filteredPoly -> return . Left $ (coeff, filteredPoly) + Right formu -> return . Right $ + formu * poly (Polynome var [( coeff + , PolyRest $ CoeffInt 1)]) + ) coefList + case partitionEithers subs of + ([], []) -> error "Impossible case" + ([], formulas) -> + return . Right $ binOp OpAdd formulas + (polys, []) -> + return . Left $ Polynome var polys + (polys, formulas) -> + return . Right . binOp OpAdd + $ poly (Polynome var polys) : formulas + + +----------------------------------------------- +---- General evaluation +----------------------------------------------- +-- | General evaluation/reduction function +polyEvalRules :: EvalFun -> EvalFun +polyEvalRules _ (BinOp _ OpAdd fs) = binEval OpAdd add add fs +polyEvalRules _ (BinOp _ OpSub fs) = binEval OpSub sub add fs +polyEvalRules _ (BinOp _ OpMul fs) = binEval OpMul mul mul fs +polyEvalRules _ (BinOp _ OpDiv fs) = binEval OpDiv division mul fs +polyEvalRules evaluator (Poly _ pol@(Polynome _ _)) = do + checkPolynomeBinding evaluator pol + >>= either (return . poly) return +polyEvalRules _ end = return end + diff --git a/EqManips/Algorithm/Eval/Ratio.hs b/EqManips/Algorithm/Eval/Ratio.hs new file mode 100644 --- /dev/null +++ b/EqManips/Algorithm/Eval/Ratio.hs @@ -0,0 +1,50 @@ +module EqManips.Algorithm.Eval.Ratio( ratioEvalRules ) where + +{-import qualified EqManips.ErrorMessages as Err-} +import EqManips.Types +import EqManips.Algorithm.Eval.Utils +import EqManips.Algorithm.Eval.Types + +-- The two following rules can generate 0 in the polynomial +-- we have to clean them +----------------------------------------------- +---- '+' +----------------------------------------------- +add :: EvalOp +add (Fraction r1) (Fraction r2) = left . Fraction $ r1 + r2 +add a b = right (a,b) + +----------------------------------------------- +---- '-' +----------------------------------------------- +sub :: EvalOp +sub (Fraction r1) (Fraction r2) = left . Fraction $ r1 - r2 +sub a b = right (a,b) + +----------------------------------------------- +---- '*' +----------------------------------------------- +mul :: EvalOp +mul (Fraction r1) (Fraction r2) = left . Fraction $ r1 * r2 +mul a b = right (a,b) + +----------------------------------------------- +---- '/' +----------------------------------------------- +-- | Handle the division operator. Nicely handle the case +-- of division by 0. +division :: EvalOp +division (Fraction r1) (Fraction r2) = left . Fraction $ r1 / r2 +division a b = right (a,b) + +----------------------------------------------- +---- General evaluation +----------------------------------------------- +-- | General evaluation/reduction function +ratioEvalRules :: EvalFun +ratioEvalRules (BinOp _ OpAdd fs) = binEval OpAdd add add fs +ratioEvalRules (BinOp _ OpSub fs) = binEval OpSub sub add fs +ratioEvalRules (BinOp _ OpMul fs) = binEval OpMul mul mul fs +ratioEvalRules (BinOp _ OpDiv fs) = binEval OpDiv division mul fs +ratioEvalRules end = return end + diff --git a/EqManips/Algorithm/Eval/Types.hs b/EqManips/Algorithm/Eval/Types.hs new file mode 100644 --- /dev/null +++ b/EqManips/Algorithm/Eval/Types.hs @@ -0,0 +1,41 @@ +module EqManips.Algorithm.Eval.Types( EvalOp + , EvalFun + , FormulOperator + , EvalPredicate + , FormulaEvaluator + , taggedEvaluator, deTagEvaluator + ) where + +import EqManips.Types +import EqManips.EvaluationContext + +type EvalOp = FormulaPrim + -> FormulaPrim + -> EqContext (Either FormulaPrim (FormulaPrim,FormulaPrim)) + +-- | Type for formula evaluating functions +type EvalFun = FormulaPrim -> EqContext FormulaPrim + +-- | Same as EvalFun, but is lingua franca for tagged formula. +type FormulaEvaluator = Formula ListForm -> EqContext (Formula ListForm) + +-- | A low-level predicate +type EvalPredicate = FormulaPrim -> FormulaPrim -> Maybe Bool + +-- | A binary operator for formula +type FormulOperator = FormulaPrim -> FormulaPrim -> FormulaPrim + + +-- | Transform an EvalFun to it's tagged counterpart. Just +-- to please the type system. +taggedEvaluator :: EvalFun -> FormulaEvaluator +taggedEvaluator evaluator (Formula a)= do + evaluated <- evaluator a + return $ Formula evaluated + +deTagEvaluator :: FormulaEvaluator -> EvalFun +deTagEvaluator eval f = do + evaluated <- eval $ Formula f + return $ unTagFormula evaluated + + diff --git a/EqManips/Algorithm/Eval/Utils.hs b/EqManips/Algorithm/Eval/Utils.hs new file mode 100644 --- /dev/null +++ b/EqManips/Algorithm/Eval/Utils.hs @@ -0,0 +1,58 @@ +module EqManips.Algorithm.Eval.Utils( left + , right + , binOpReducer + , binEval + ) where + +import Control.Applicative +import Data.List( sort, foldl' ) + +import EqManips.Types +import EqManips.EvaluationContext +import EqManips.Algorithm.Eval.Types +import EqManips.Algorithm.Utils +import EqManips.Propreties + +left :: (Monad m) => a -> m (Either a b) +left = return . Left + +right :: (Monad m) => b -> m (Either a b) +right = return . Right + +-- | Used to transform a binop to a scalar if size +-- is small +binOpReducer :: BinOperator -> [FormulaPrim] -> FormulaPrim +binOpReducer _ [x] = x +binOpReducer op lst = binOp op lst + +-- | Assuming children in list form, parse the list to +-- keep the general listform. +binListRepacker :: BinOperator -> [FormulaPrim] -> FormulaPrim +binListRepacker op lst = binOpReducer op + $ foldl' emergeSubOp id lst [] + where emergeSubOp acc (BinOp _ op2 subLst) + | op == op2 = acc . (subLst ++) + emergeSubOp acc sub = acc . (sub:) + +-- | Evaluate a binary operator +-- Right associative operators are called with arguments reversed! +binEval :: BinOperator -> EvalOp -> EvalOp -> [FormulaPrim] -> EqContext FormulaPrim +binEval op f inv formulaList + | op `hasProp` Associativ && op `hasProp` Commutativ = +#ifdef _DEBUG + addTrace ("Sorting => ", treeIfyFormula . Formula $ binOp op formulaList) >> +#endif + binListRepacker op <$> biAssocM f inv (sort formulaList) + + | op `obtainProp` AssocSide == OpAssocRight = +#ifdef _DEBUG + addTrace ("Basic Right Eval=>", treeIfyFormula . Formula $ binOp op formulaList) >> +#endif + binListRepacker op . reverse <$> (biAssocM f inv $ reverse formulaList) + + | otherwise = +#ifdef _DEBUG + addTrace ("Basic Eval=>", treeIfyFormula . Formula $ binOp op formulaList) >> +#endif + binListRepacker op <$> biAssocM f inv formulaList + diff --git a/EqManips/Algorithm/Expand.hs b/EqManips/Algorithm/Expand.hs new file mode 100644 --- /dev/null +++ b/EqManips/Algorithm/Expand.hs @@ -0,0 +1,45 @@ +module EqManips.Algorithm.Expand ( expand ) where + +import EqManips.Types +import EqManips.Algorithm.Utils +import EqManips.FormulaIterator +import EqManips.Propreties + +-- | Algorithm to call to perform a global formula +-- expension +expand :: Formula TreeForm -> Formula TreeForm +expand (Formula f) = Formula + $ depthFormulaPrimTraversal `asAMonad` expander + $ f + +-- | Filter used to perform formula expansion. +expander :: FormulaPrim -> FormulaPrim +expander (BinOp _ op [a,b]) + | op `hasProp` Distributiv = + distributeLeft op (binOp op) a b +expander f = f + +-- | The role of this function is to search all pseudo-end +-- nodes in the right formula and then launch another matching +-- which will really create new nodes. +distributeLeft :: BinOperator -- ^ Priority of distributiv operator + -> ([FormulaPrim] -> FormulaPrim) -- ^ Combine two sub-formulas + -> FormulaPrim + -> FormulaPrim + -> FormulaPrim +distributeLeft op combine formula (BinOp _ op' [a,b]) + | not $ op `canDistributeOver` op' + = binOp op' [digg a, digg b] + where digg = distributeLeft op combine formula + +distributeLeft _iniPrio combine formula with = + distributeRight combine formula with + +-- | Really apply the distributivity. +distributeRight :: ([FormulaPrim] -> FormulaPrim) + -> FormulaPrim -> FormulaPrim -> FormulaPrim +distributeRight combine (BinOp _ op [a,b]) sub + | not $ op `hasProp` Distributiv = binOp op [digg a, digg b] + where digg tree = distributeRight combine tree sub +distributeRight combine op sub = combine [op, sub] + diff --git a/EqManips/Algorithm/Inject.hs b/EqManips/Algorithm/Inject.hs new file mode 100644 --- /dev/null +++ b/EqManips/Algorithm/Inject.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module EqManips.Algorithm.Inject( inject ) where + +import Control.Applicative +import EqManips.Types +import EqManips.FormulaIterator +import EqManips.EvaluationContext +import EqManips.Algorithm.Utils + +-- | Replace all variables that get a definition by +-- their definition if there is one. Otherwise let +-- the variable like that. +inject :: Formula ListForm -> EqContext (Formula ListForm) +inject (Formula f) = do +#ifdef _DEBUG + addTrace ("Injection:", Formula $ f) +#endif + Formula <$> depthPrimTraversal scopePreserver injectIntern f + +-- | This function perform a sort of alpha +-- renaming on subScope, it's called when arriving +-- on a node, to prevent wrong replacements. +scopePreserver :: FormulaPrim -> EqContext () +scopePreserver f = keepSafe $ reBoundVar f + where keepSafe Nothing = return () + keepSafe (Just v) = do + pushContext + mapM_ delSymbol v + +injectIntern :: FormulaPrim -> EqContext FormulaPrim +injectIntern f@(Variable v) = + maybe f unTagFormula <$> symbolLookup v + +injectIntern f = scope $ reBoundVar f + where scope Nothing = return f + scope _ = popContext >> return f + +-- | Tell if a node change the scope. +-- The pattern is explicitely exaustive to be sure +-- to get the compiler shout if a change is made. +reBoundVar :: FormulaPrim -> Maybe [String] +reBoundVar (Product _ (BinOp _ OpEq (Variable v:_)) _ _) = Just [v] +reBoundVar (Sum _ (BinOp _ OpEq (Variable v: _)) _ _) = Just [v] +reBoundVar (Lambda _ clauses) = Just $ + concat [concatMap collectSymbols args | (args, _) <- clauses] + +reBoundVar (Indexes _ _ _) = Nothing +reBoundVar (List _ _) = Nothing +reBoundVar (Complex _ _) = Nothing +reBoundVar (Fraction _) = Nothing +reBoundVar (Poly _ _) = Nothing +reBoundVar (Variable _) = Nothing +reBoundVar (NumEntity _) = Nothing +reBoundVar (CInteger _) = Nothing +reBoundVar (CFloat _) = Nothing +reBoundVar (App _ _ _) = Nothing +reBoundVar (Derivate _ _ _) = Nothing +reBoundVar (Integrate _ _ _ _ _) = Nothing +reBoundVar (UnOp _ _ _) = Nothing +reBoundVar (BinOp _ _ _) = Nothing +reBoundVar (Matrix _ _ _ _) = Nothing +reBoundVar (Block _ _ _) = Nothing +reBoundVar (Product _ _ _ _) = Nothing +reBoundVar (Sum _ _ _ _) = Nothing +reBoundVar (Truth _) = Nothing +-- Nothing preserved during evaluation normaly. +reBoundVar (Meta _ _ _) = Nothing diff --git a/EqManips/Algorithm/Simplify.hs b/EqManips/Algorithm/Simplify.hs new file mode 100644 --- /dev/null +++ b/EqManips/Algorithm/Simplify.hs @@ -0,0 +1,115 @@ +module EqManips.Algorithm.Simplify( simplifyFormula ) where + +import Control.Applicative + +import EqManips.Types +import EqManips.EvaluationContext +import EqManips.Algorithm.Eval.Utils +import EqManips.Algorithm.Eval.Types + +#ifdef _DEBUG +import EqManips.Algorithm.Utils + +tracer :: String -> BinOperator -> FormulaPrim -> FormulaPrim + -> EqContext () +tracer str op f1 f2 = + addTrace (str, treeIfyFormula . Formula + $ binOp op [ f1, f2 ]) +#endif + +-------------------------------------------------- +---- Operators +-------------------------------------------------- + +-- | '+' operator simplification. +-- Some propreties which should work for the addition +-- operation. +addSimplification :: EvalFun -> EvalOp +addSimplification eval a (BinOp _ OpMul [b, c]) + | hashOfFormula a == hashOfFormula c + && a == c = do +#ifdef _DEBUG + tracer "Triggered '+' simplification" OpAdd a (BinOp 0 OpMul [b, c]) +#endif + subCoeff <- eval $ b + 1 + left $ subCoeff * c + +addSimplification eval (BinOp _ OpMul [a, c]) b + | hashOfFormula c == hashOfFormula b + && b == c = do +#ifdef _DEBUG + tracer "Triggered '+' simplification" OpAdd (BinOp 0 OpMul [a,c]) b +#endif + subCoeff <- eval $ a + 1 + left $ subCoeff * c +addSimplification _ a b + | hashOfFormula a == hashOfFormula b + && a == b = +#ifdef _DEBUG + tracer "Triggered '+' simplification" OpAdd a b >> +#endif + left (2 * a) + | otherwise = right $ (a,b) + +-- | '-' operator simplification +subSimplification :: EvalFun -> EvalOp +subSimplification eval (BinOp _ OpMul [a, c]) b + | hashOfFormula c == hashOfFormula b + && b == c = do +#ifdef _DEBUG + tracer "Triggered '-' simplification" OpSub (BinOp 0 OpMul [a, c]) b +#endif + subCoeff <- eval (a - 1) + left (subCoeff * c) + +subSimplification _ a b + | hashOfFormula a == hashOfFormula b + && a == b = +#ifdef _DEBUG + tracer "Triggered '-' simplification" OpSub a b >> +#endif + left 0 + | otherwise = right (a,b) + +-------------------------------------------------- +---- '*' simplification +-------------------------------------------------- +mulSimplification :: EvalFun -> EvalOp +mulSimplification eval (BinOp _ OpPow [a, c]) b + | hashOfFormula a == hashOfFormula b + && a == b = +#ifdef _DEBUG + tracer "Triggered '*' simplification" OpMul a b >> +#endif + Left <$> eval (a ** (c + 1)) + +mulSimplification eval b (BinOp _ OpPow [a, c]) + | hashOfFormula a == hashOfFormula b + && a == b = +#ifdef _DEBUG + tracer "Triggered '*' simplification" OpMul b a >> +#endif + Left <$> eval (a ** (c + 1)) + +mulSimplification _ a b + | hashOfFormula a == hashOfFormula b + && a == b = +#ifdef _DEBUG + tracer "Triggered '*' simplification" OpMul a b >> +#endif + left (a ** 2) + | otherwise = right (a,b) + +-------------------------------------------------- +---- Main Function +-------------------------------------------------- +simplifyFormula :: EvalFun -> FormulaPrim + -> EqContext FormulaPrim +simplifyFormula f (BinOp _ OpAdd lst) = + binEval OpAdd (addSimplification f) (addSimplification f) lst +simplifyFormula f (BinOp _ OpSub lst) = + binEval OpSub (subSimplification f) (addSimplification f) lst +simplifyFormula f (BinOp _ OpMul lst) = + binEval OpMul (mulSimplification f) (mulSimplification f) lst +simplifyFormula _ formu = pure formu + diff --git a/EqManips/Algorithm/Unification.hs b/EqManips/Algorithm/Unification.hs new file mode 100644 --- /dev/null +++ b/EqManips/Algorithm/Unification.hs @@ -0,0 +1,229 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +module EqManips.Algorithm.Unification( unify, getFirstUnifying ) where + +import Data.List( foldl' ) + +import Control.Applicative +import Control.Monad.Writer +import Control.Monad.State.Lazy + +import EqManips.Types +import EqManips.Polynome +import EqManips.Algorithm.Utils + +infix 4 =~= + +instance Applicative (State s) where + pure = return + a <*> b = + do { a' <- a; b' <- b; return $ a' b' } + +type UnificationContext a = State [(String, FormulaPrim)] a + +-- | Just a little shortcut to be able to write more +-- consise code. +(=~=) :: FormulaPrim -> FormulaPrim + -> UnificationContext Bool +(=~=) = unifyFormula + +-- | Return the first pattern matching the given formula +-- and a list of substitution to be made on the function +-- body. +getFirstUnifying :: [([FormulaPrim], FormulaPrim)] + -> [FormulaPrim] + -> Maybe (FormulaPrim, [(String,FormulaPrim)]) +getFirstUnifying matches toMatch = foldl' unif Nothing matches + where unif Nothing (args, body) = + let (rez, lst) = runState (unifyList args toMatch) [] + in if rez then Just (body, lst) + else Nothing + unif j@(Just _) _ = j + +-- | Try to Unify two formula, return a list of substitution +-- to transform a into b in case of success. +unify :: Formula anyKind -> Formula anyKind + -> Maybe [(String, Formula TreeForm)] +unify (Formula a) (Formula b) = + if rez + then Nothing + else Just [(s, Formula f) | (s,f) <- lst] + where (rez, lst) = runState (a =~= b) [] + +-- | Helper function to unify list of formula side by side. +-- Used for "tuples"/arguments +unifyList :: [FormulaPrim] -> [FormulaPrim] -> UnificationContext Bool +unifyList l1 l2 + | length l1 == length l2 = + let valid acc (a,b) = (acc &&) <$> (a =~= b) + in foldM valid True $ zip l1 l2 + | otherwise = return False + +-- | Used to unify list and operator "::" +unifyTill :: [FormulaPrim] -> [FormulaPrim] -> UnificationContext Bool +unifyTill [] _ = return True +unifyTill [Variable v] rest = checkSymbol v $ list rest +unifyTill _ [] = return False +unifyTill (x:xs) (y:ys) = do + valid <- x =~= y + if valid then unifyTill xs ys + else return False + + +-- | Real function that implement unification. +-- origin pattern (function args...), to unify +unifyFormula :: FormulaPrim -- ^ Pattern + -> FormulaPrim -- ^ to apply + -> UnificationContext Bool +unifyFormula (App _ f1 l1) (App _ f2 l2) = + (&&) . valid <$> (f1 =~= f2) <*> unifyList l1 l2 + where valid = (&&) $ length l1 == length l2 + +unifyFormula (Fraction f1) (Fraction f2) = + return $ f1 == f2 + +unifyFormula (Complex _ (re, im)) (Complex _ (re2, im2)) = + (&&) <$> (re =~= re2) <*> (im =~= im2) + +unifyFormula (Poly _ left@(Polynome _ _)) + (Poly _ right@(Polynome _ _)) = + if valid + then and <$> mapM (uncurry checkSymbol) subs + else pure valid + where (valid, subs :: [(String, FormulaPrim)]) = runWriter $ subPolyEq left right + -- n == n' + subPolyEq (PolyRest a) (PolyRest b) = return $ a == b + -- n == x^y + ... + ... <=> False + subPolyEq (PolyRest _) (Polynome _ _) = return False + -- x^y + ... + ... == n <=> False + subPolyEq (Polynome _ _) (PolyRest _) = return False + + -- 1 * x ^ 1 <=> var / poly equivalence + subPolyEq (Polynome var1 [(c1, PolyRest c2)]) + replacement@(Polynome _ _) + | c1 == CoeffInt 1 && c2 == CoeffInt 1 = + tell [(var1, poly replacement)] >> return True + + -- Are two polynoms equivalent? + subPolyEq (Polynome var1 lst1') + (Polynome var2 lst2') = do + valid' <- verifyCoeff lst1' lst2' + when valid' $ tell [(var1, Variable var2)] + return valid' + + verifyCoeff a = foldM coefEq True . zip a + + coefEq acc ((c1,sub1),(c2,sub2)) = + ((acc && c1 == c2) &&) <$> subPolyEq sub1 sub2 + +unifyFormula (BinOp _ OpAdd added) (Poly _ (Polynome v lst)) = + if length added == length lst && valid + then and <$> mapM (uncurry checkSymbol) adds + else return valid + + where (valid, adds) = runWriter $ and <$> (mapM validMatch . zip added $ zipper v lst) + zipper var = map (\(c, s) -> (var,c,s)) + + validMatch :: (FormulaPrim, (String, PolyCoeff, Polynome)) + -> Writer [(String, FormulaPrim)] Bool + -- a =~= x^y+z, ok it works + validMatch ( Variable pvar, (var, c, sub)) = + tell [(pvar, poly $ Polynome var [(c,sub)])] >> return True + + -- a ^ b =~= 1 * x ^ y + validMatch ( BinOp _ OpPow [ Variable pvar + , Variable powvar] + , (var, c, PolyRest sub)) + | CoeffInt 1 == sub = do + tell [(pvar, Variable var)] + tell [(powvar, coefToFormula c)] + return True + + -- a ^ 15 =~= 1*x^15 + validMatch ( BinOp _ OpPow [ Variable pvar + , CInteger i], (var, c, PolyRest sub)) + | CoeffInt 1 == sub && c == CoeffInt i = + tell [(pvar, Variable var)] >> return True + + -- y * .... <=> x ^ 0 * n + -- false if the power is non-zero. + validMatch ( BinOp _ OpMul [Variable fvar], (_, c, PolyRest coeff)) + | c /= 0 = return False + | otherwise = tell [(fvar, coefToFormula coeff)] + >> return True + + validMatch ( BinOp _ OpMul [c], (_, _, PolyRest coeff)) + | isFormulaScalar c = return $ scalarToCoeff c == coeff + + -- y * ... <=> + validMatch ( BinOp _ OpMul (Variable fvar:xs) + , (var1, c, Polynome var2 ((c2,sub2):_))) + | c /= 1 = return False + | otherwise = do + valid' <- validMatch (binOp OpMul xs, (var2, c2, sub2)) + when valid' $ tell [(fvar, Variable var1)] + return valid' + + validMatch ( BinOp _ OpMul ((BinOp _ OpPow [ Variable pvar + , CInteger i ]) + :xs) + , (var1, c, Polynome var2 ((c2,sub2):_))) + | CoeffInt i == c = do + valid' <- validMatch (binOp OpMul xs, (var2, c2, sub2)) + when valid' $ tell [(pvar, Variable var1)] + return valid' + + -- n * ... <=> n' * x ^ 0 + -- else it's wrong + validMatch ( BinOp _ OpMul (e:_), (_, c, sub)) + | isFormulaScalar e = case sub of + PolyRest a -> return $ c == CoeffInt 0 && scalarToCoeff e == a + _ -> return False + + -- General case : it's not valid. + validMatch _ = return False + +unifyFormula (Truth a) (Truth b) = + return $ a == b + +unifyFormula (CInteger i1) (CInteger i2) = + return $ i1 == i2 + +unifyFormula (CFloat i1) (CFloat i2) = + return $ i1 == i2 + +unifyFormula (NumEntity e1) (NumEntity e2) = + return $ e1 == e2 + +unifyFormula (BinOp _ OpCons l1) (List _ valList) = + unifyTill l1 valList + +unifyFormula (BinOp _ op1 l1) (BinOp _ op2 l2) + | op1 == op2 && length l1 == length l2 = unifyList l1 l2 + | otherwise = return False + +unifyFormula (UnOp _ op1 f1) (UnOp _ op2 f2) = + (op1 == op2 &&) <$> (f1 =~= f2) + +unifyFormula (Indexes _ what l1) (Indexes _ what2 l2) + | length l1 == length l2 = + (&&) <$> (what =~= what2) <*> unifyList l1 l2 + | otherwise = + return False + +unifyFormula (List _ l1) (List _ l2) = unifyList l1 l2 +unifyFormula (Variable v1) f2 = checkSymbol v1 f2 + +unifyFormula _ _ = return False + +-- | Add symbol if it doesn't exists, and check for equality +-- of definition otherwise. +checkSymbol :: String -> FormulaPrim -> UnificationContext Bool +checkSymbol var what = do + symbolList <- get + maybe (do put $ (var, what) : symbolList + return True) + (return . (what ==)) + $ lookup var symbolList + diff --git a/EqManips/Algorithm/Utils.hs b/EqManips/Algorithm/Utils.hs new file mode 100644 --- /dev/null +++ b/EqManips/Algorithm/Utils.hs @@ -0,0 +1,321 @@ +-- | Utility function/types used in the project. +module EqManips.Algorithm.Utils ( biAssocM, biAssoc + , asAMonad + , fromEmptyMonad + , treeIfyFormula, treeIfyBinOp + , listifyFormula, listifyBinOp + , isFormulaConstant, isFormulaConstant' + , isFormulaInteger, isFormulaScalar + , isConstantNegative, negateConstant + , sortFormula, invSortFormula, sortBinOp + + -- | Count nodes in basic formula + , nodeCount + -- | Same version with form info. + , nodeCount' + , needParenthesis + , needParenthesisPrio + , interspereseS + , concatS + , concatMapS + , collectSymbols, collectSymbols' + + -- | Translate complex into "simpler" format, + -- intended for display use only! + , complexTranslate + ) where + +import Control.Applicative +import qualified Data.Monoid as Monoid + +import Data.Monoid( All( .. ), mempty ) +import EqManips.Algorithm.EmptyMonad +import EqManips.Propreties +import EqManips.Types +import {-# SOURCE #-} EqManips.FormulaIterator +import Data.List( foldl', sortBy ) + +----------------------------------------------------------- +-- Parsing formula +----------------------------------------------------------- +-- | Count the number of nodes in a formula. +nodeCount :: FormulaPrim -> Int +nodeCount = Monoid.getSum . foldf + (\_ a -> Monoid.Sum $ Monoid.getSum a + 1) + (Monoid.Sum 0) + +nodeCount' :: Formula anyForm -> Int +nodeCount' (Formula a) = nodeCount a + +-- | Perform a semantic sorting on formula, trying to put numbers +-- front and rassembling terms +sortFormula :: Formula ListForm -> Formula ListForm +sortFormula (Formula a) = Formula + $ (depthFormulaPrimTraversal `asAMonad` sortBinOp compare) a + +-- | Sort a binary operator, used by sortFormula to sort globally +-- a formula +sortBinOp :: (FormulaPrim -> FormulaPrim -> Ordering) -> FormulaPrim -> FormulaPrim +sortBinOp f (BinOp _ op lst) + | op `hasProp` Associativ && op `hasProp` Commutativ = binOp op $ sortBy f lst +sortBinOp _f a = a + +invSortFormula :: Formula ListForm -> Formula ListForm +invSortFormula (Formula f) = + Formula $ (depthFormulaPrimTraversal `asAMonad` sortBinOp cmp) f + where cmp a = invOrd . compare a + invOrd GT = LT + invOrd LT = GT + invOrd EQ = EQ + +-- | listify a whole formula +listifyFormula :: Formula TreeForm -> Formula ListForm +listifyFormula (Formula a) = Formula $ + (depthFormulaPrimTraversal `asAMonad` listifyBinOp) a + + +-- | Given a binary operator in binary tree form, +-- transform it in list form. +listifyBinOp :: FormulaPrim -> FormulaPrim +listifyBinOp (BinOp _ op lst) = binOp op $ translate lst + where translate = flatten (op `obtainProp` AssocSide) + flatten OpAssocRight = rightLister + flatten OpAssocLeft + | op `hasProp` Associativ = rightLister . leftLister + | otherwise = leftLister + + leftLister = foldr lefter [] + + -- left associative operator packing. + lefter (BinOp _ op' fl) acc + | op == op' = foldr lefter acc fl + lefter final acc = final : acc + + rightLister = foldl' righter [] + -- right associative operator packing. + righter acc (BinOp _ op' fl) + | op' == op = foldl' righter acc fl + righter acc e = acc ++ [e] + +listifyBinOp a = a + +-- | treeify a whole formula +treeIfyFormula :: Formula ListForm -> Formula TreeForm +treeIfyFormula (Formula a) = Formula f + where f :: FormulaPrim + f = depthFormulaPrimTraversal `asAMonad` treeIfyBinOp $ a + +-- | Given a formula where all binops are in list +-- forms, transform it back to binary tree. +treeIfyBinOp :: FormulaPrim -> FormulaPrim +treeIfyBinOp (BinOp _ _ []) = error "treeIfyBinOp - empty binop" +treeIfyBinOp f@(BinOp _ _ [_]) = error ("treeIfyBinOp - Singleton binop " ++ show f) +treeIfyBinOp f@(BinOp _ _ [_,_]) = f +treeIfyBinOp (BinOp _ op lst) = innerNode (op `obtainProp` AssocSide) lst + where innerNode OpAssocLeft (fx:fy:fs) = + foldl' innerLeft (binOp op [fx, fy]) fs + innerNode OpAssocRight lst' = innerRight lst' + innerNode _ _ = error "treeIfyBinOp - weird unhandled case" + + innerRight [a,b] = binOp op [a,b] + innerRight (fx:fs) = binOp op [fx, innerRight fs] + innerRight _ = error "treeIfyBinOp - bleh right" + + innerLeft acc fx = binOp op [acc, fx] +treeIfyBinOp f = f + +-- | Little helper to help to know if a formula renderer +-- need to put parenthesis around the current node regarding +-- his parent node. +needParenthesis :: Bool -- ^ if the node is on the right side of parent operator + -> BinOperator -- ^ Parent operator + -> BinOperator -- ^ This node operator + -> Bool +needParenthesis v = + needParenthesisPrio v . (`obtainProp` Priority) + +-- | Little helper to know if a renderer need to put parenthesis +-- given his parent's priority +needParenthesisPrio :: Bool -- ^ If the node is on the right side of parent operator + -> Int -- ^ Parent operator priority + -> BinOperator -- ^ This node operator + -> Bool +-- for right associative operators, it's reversed. +needParenthesisPrio True parentPrio op + | op `obtainProp` AssocSide == OpAssocRight = + (op `obtainProp` Priority) > parentPrio + | otherwise = + (op `obtainProp` Priority) >= parentPrio + +needParenthesisPrio False parentPrio op + | op `obtainProp` AssocSide == OpAssocRight = + (op `obtainProp` Priority) >= parentPrio + | otherwise = + (op `obtainProp` Priority) > parentPrio + +-- | Bi associate operation on a list of elements. +-- Can be used for reduction of formula. +biAssoc :: (a -> a -> Either a (a,a)) + -> (a -> a -> Either a (a,a)) + -> [a] -> [a] +biAssoc f finv = fromEmptyMonad + . biAssocM (\a -> return . f a) + (\a -> return . finv a) + +-- | same as biAssoc, but use monads. +{- +{-# SPECIALIZE biAssocM :: (FormulaPrim -> FormulaPrim -> EqContext (Either FormulaPrim (FormulaPrim,FormulaPrim))) + -> (FormulaPrim -> FormulaPrim -> EqContext (Either FormulaPrim (FormulaPrim,FormulaPrim))) + -> [FormulaPrim] -> EqContext [FormulaPrim] #-} + -} +biAssocM :: (Monad m, Functor m) + => (a -> a -> m (Either a (a,a))) + -> (a -> a -> m (Either a (a,a))) + -> [a] -> m [a] +biAssocM f finv lst = assocInner f lst + where assocInner _ [] = return [] + assocInner _ [x] = return [x] + assocInner f' [x,y] = f' x y >>= \val -> case val of + Left v -> return [v] + Right (v1, v2) -> return [v1, v2] + assocInner f' (x:y:xs) = f' x y >>= \val -> case val of + Left v -> assocInner f' (v:xs) + Right (v1, v2) -> (v1:) <$> assocInner finv (v2:xs) + +-- | Work like concat on list, but instead +-- just combine functions of kind of ShowS. +-- The function is generalized +concatS :: [a -> a] -> (a -> a) +concatS [] = id +concatS lst = foldr1 (.) lst + +-- | Work like concatMap, but instead use +-- function combination. +concatMapS :: (a -> b -> b) -> [a] -> (b -> b) +concatMapS f = concatS . map f + +-- | Same functionality as intersperse but combine function +-- instead of concatenation +interspereseS :: (a -> a) -> [a -> a] -> a -> a +interspereseS what within = + foldl' (\acc e -> e . what . acc) lastOne reversed + where (lastOne : reversed) = reverse within + +-- | Collect all the symbols present in the formula. +-- Symbols can be present multiple times +collectSymbols :: FormulaPrim -> [String] +collectSymbols = foldf symbolCollector [] + where symbolCollector (Variable v) acc = v:acc + symbolCollector _ acc = acc + +collectSymbols' :: Formula anyKind -> [String] +collectSymbols' (Formula a) = collectSymbols a + +isFormulaInteger :: FormulaPrim -> Bool +isFormulaInteger = getAll . foldf isConstant mempty + where isConstant (Variable _) _ = All False + isConstant (Sum _ _ _ _) _ = All False + isConstant (Poly _ _) _ = All False + isConstant (Product _ _ _ _) _ = All False + isConstant (Derivate _ _ _) _ = All False + isConstant (Integrate _ _ _ _ _) _ = All False + isConstant (Lambda _ _) _ = All False + isConstant (App _ _ _) _ = All False + isConstant (Block _ _ _) _ = All False + -- + isConstant (CFloat _) _ = All False + isConstant (CInteger _) _ = All True + isConstant (Complex _ _) _ = All False + isConstant (Fraction _) _ = All True + isConstant (Truth _) _ = All False + isConstant (NumEntity _) _ = All False + -- + isConstant (UnOp _ op _) a = isValidUnop op a + isConstant (BinOp _ _ _) a = a + isConstant (Meta _ _ _) a = a + isConstant (Matrix _ 1 1 _) a = a + isConstant (Matrix _ _ _ _) _ = All False + isConstant (Indexes _ _ _) _ = All False + isConstant (List _ _) _ = All False + + isValidUnop OpNegate a = a + isValidUnop OpAbs a = a + isValidUnop OpFactorial _ = All True + isValidUnop OpCeil _ = All True + isValidUnop OpFloor _ = All True + isValidUnop _ _ = All False + +isFormulaScalar :: FormulaPrim -> Bool +isFormulaScalar (CFloat _) = True +isFormulaScalar (CInteger _) = True +isFormulaScalar (Fraction _) = True +-- next case is "fishy" +isFormulaScalar (Complex _ (a,b)) = isFormulaScalar a && isFormulaScalar b +isFormulaScalar (UnOp _ OpNegate f) = isFormulaScalar f +isFormulaScalar _ = False + +negateConstant :: FormulaPrim -> FormulaPrim +negateConstant (CFloat a) = CFloat (-a) +negateConstant (CInteger a) = CInteger (-a) +negateConstant (Fraction a) = Fraction (-a) +negateConstant (UnOp _ OpNegate c) = c +negateConstant a = a + +isConstantNegative :: FormulaPrim -> Bool +isConstantNegative (CFloat a) = a < 0 +isConstantNegative (CInteger a) = a < 0 +isConstantNegative (Fraction a) = a < 0 +isConstantNegative (UnOp _ OpNegate c) = + not $ isConstantNegative c +isConstantNegative _ = False + +-- | Translate a complex to a simpler formula using '+' and '*' +-- Perform mandatory simplification +complexTranslate :: (FormulaPrim, FormulaPrim) -> FormulaPrim +complexTranslate (a,b) + | isZero b = a + | isZero a && isOne b = Variable "i" + | isZero a = Variable "i" * b + | otherwise = a + Variable "i" * b + where isZero (CInteger 0) = True + isZero (CFloat 0.0) = True + isZero _ = False + + isOne (CInteger 1) = True + isOne (CFloat 1.0) = True + isOne _ = False + +-- | Tell if a formula can be reduced to a scalar somehow +isFormulaConstant :: FormulaPrim -> Bool +isFormulaConstant = getAll . foldf isConstant mempty + where isConstant (Variable _) _ = All False + isConstant (Poly _ _) _ = All False + isConstant (Sum _ _ _ _) _ = All False + isConstant (Product _ _ _ _) _ = All False + isConstant (Derivate _ _ _) _ = All False + isConstant (Integrate _ _ _ _ _) _ = All False + isConstant (Lambda _ _) _ = All False + isConstant (App _ _ _) _ = All False + isConstant (Block _ _ _) _ = All False + -- + isConstant (CFloat _) _ = All True + isConstant (CInteger _) _ = All True + isConstant (Truth _) _ = All True + isConstant (NumEntity _) _ = All True + isConstant (Fraction _) _ = All True + isConstant (List _ _) _ = All False + isConstant (Indexes _ _ _) _ = All False + + -- + isConstant (Complex _ _) a = a + isConstant (UnOp _ _ _) a = a + isConstant (BinOp _ _ _) a = a + isConstant (Meta _ _ _) a = a + isConstant (Matrix _ 1 1 _) a = a + isConstant (Matrix _ _ _ _) _ = All False + +-- | Tell if a formula in any form can be reduced +-- to a scalar somehow +isFormulaConstant' :: Formula anyKind -> Bool +isFormulaConstant' (Formula a) = isFormulaConstant a + diff --git a/EqManips/BaseLibrary.hs b/EqManips/BaseLibrary.hs new file mode 100644 --- /dev/null +++ b/EqManips/BaseLibrary.hs @@ -0,0 +1,8 @@ +module EqManips.BaseLibrary( defaultSymbolTable ) where + +import EqManips.Types +import Data.Map + +defaultSymbolTable :: Map String (Formula ListForm) +defaultSymbolTable = fromList [("concat",{-(lambda (((list ) y) y)((x (list ) ) x)(((:: x xs) y) (:: x (apply concat xs y)))((a b) undefined))-} Formula (Lambda 148011272 [([List 12303291 [],Variable "y"],Variable "y"),([Variable "x",List 12303291 []],Variable "x"),([BinOp 867 OpCons [Variable "x",Variable "xs"],Variable "y"],BinOp 9121 OpCons [Variable "x",App 8361 (Variable "concat") [Variable "xs",Variable "y"]]),([Variable "a",Variable "b"],Variable "undefined")])),("cons",{-(lambda ((a b) (:: b a)))-} Formula (Lambda 1821 [([Variable "a",Variable "b"],BinOp 937 OpCons [Variable "b",Variable "a"])])),("derivaten",{-(lambda ((f var 0) f)((f var 1) (derivate (Force f) (Force var)))((f var n) (derivate (Force (apply derivaten f var (poly n (0, -1) (1, 1) ))) (Force var))))-} Formula (Lambda (-1019272245) [([Variable "f",Variable "var",CInteger 0],Variable "f"),([Variable "f",Variable "var",CInteger 1],Derivate (-1808503526) (Meta 1610613004 Force (Variable "f")) (Meta (-1879047910) Force (Variable "var"))),([Variable "f",Variable "var",Variable "n"],Derivate (-1759068902) (Meta (-1342176258) Force (App 12171 (Variable "derivaten") [Variable "f",Variable "var",Poly 107 (Polynome "n" [(CoeffInt 0,PolyRest (CoeffInt (-1))),(CoeffInt 1,PolyRest (CoeffInt 1))])])) (Meta (-1879047910) Force (Variable "var")))])),("eq",{-(lambda ((a a) True)((a b) False))-} Formula (Lambda (-2147479268) [([Variable "a",Variable "a"],Truth True),([Variable "a",Variable "b"],Truth False)])),("filter",{-(lambda ((pred (list ) ) (list ) )((pred (:: x xs)) (apply concat (apply if (apply pred x) (list x) (list ) ) (apply filter pred xs)))((a b) undefined))-} Formula (Lambda (-1382858888) [([Variable "pred",List 12303291 []],List 12303291 []),([Variable "pred",BinOp 867 OpCons [Variable "x",Variable "xs"]],App 721864843 (Variable "concat") [App 90233179 (Variable "if") [App 6848 (Variable "pred") [Variable "x"],List 12303299 [Variable "x"],List 12303291 []],App 9691 (Variable "filter") [Variable "pred",Variable "xs"]]),([Variable "a",Variable "b"],Variable "undefined")])),("foldl",{-(lambda ((f acc (list ) ) acc)((f acc (:: x xs)) (apply foldl f (apply f acc x) xs))((a b c) undefined))-} Formula (Lambda 12512956 [([Variable "f",Variable "acc",List 12303291 []],Variable "acc"),([Variable "f",Variable "acc",BinOp 867 OpCons [Variable "x",Variable "xs"]],App 16691 (Variable "foldl") [Variable "f",App 3880 (Variable "f") [Variable "acc",Variable "x"],Variable "xs"]),([Variable "a",Variable "b",Variable "c"],Variable "undefined")])),("foldr",{-(lambda ((f acc (list ) ) acc)((f acc (:: x xs)) (apply f (apply foldr f acc xs) x))((a b c) undefined))-} Formula (Lambda 12855048 [([Variable "f",Variable "acc",List 12303291 []],Variable "acc"),([Variable "f",Variable "acc",BinOp 867 OpCons [Variable "x",Variable "xs"]],App 102216 (Variable "f") [App 12587 (Variable "foldr") [Variable "f",Variable "acc",Variable "xs"],Variable "x"]),([Variable "a",Variable "b",Variable "c"],Variable "undefined")])),("if",{-(lambda ((True a b) a)((False a b) b)((otherwise a b) undefined))-} Formula (Lambda 1025416 [([Truth True,Variable "a",Variable "b"],Variable "a"),([Truth False,Variable "a",Variable "b"],Variable "b"),([Variable "otherwise",Variable "a",Variable "b"],Variable "undefined")])),("length",{-(lambda ((lst) (apply lengthIntern 0 lst)))-} Formula (Lambda 20416 [([Variable "lst"],App 20091 (Variable "lengthIntern") [CInteger 0,Variable "lst"])])),("lengthIntern",{-(lambda ((acc (list ) ) acc)((acc (:: x xs)) (apply lengthIntern (poly acc (0, 1) (1, 1) ) xs))((a b) undefined))-} Formula (Lambda 12413172 [([Variable "acc",List 12303291 []],Variable "acc"),([Variable "acc",BinOp 867 OpCons [Variable "x",Variable "xs"]],App 18057 (Variable "lengthIntern") [Poly 1073742121 (Polynome "acc" [(CoeffInt 0,PolyRest (CoeffInt 1)),(CoeffInt 1,PolyRest (CoeffInt 1))]),Variable "xs"]),([Variable "a",Variable "b"],Variable "undefined")])),("listFromTo",{-(lambda ((a a) (list a) )((a b) (:: a (apply listFromTo (poly a (0, 1) (1, 1) ) b))))-} Formula (Lambda 12374757 [([Variable "a",Variable "a"],List 12303322 [Variable "a"]),([Variable "a",Variable "b"],BinOp 16768 OpCons [Variable "a",App 16960 (Variable "listFromTo") [Poly 1073741923 (Polynome "a" [(CoeffInt 0,PolyRest (CoeffInt 1)),(CoeffInt 1,PolyRest (CoeffInt 1))]),Variable "b"]])])),("listFromToBy",{-(lambda ((a by a) (list a) )((a by maxi) (:: a (apply listFromToBy (poly a (0, (poly by (1, 1) )) (1, 1) ) by maxi))))-} Formula (Lambda 12455077 [([Variable "a",Variable "by",Variable "a"],List 12303322 [Variable "a"]),([Variable "a",Variable "by",Variable "maxi"],BinOp 27967 OpCons [Variable "a",App 28175 (Variable "listFromToBy") [Poly 1073741974 (Polynome "a" [(CoeffInt 0,Polynome "by" [(CoeffInt 1,PolyRest (CoeffInt 1))]),(CoeffInt 1,PolyRest (CoeffInt 1))]),Variable "by",Variable "maxi"]])])),("map",{-(lambda ((f (list ) ) (list ) )((f (:: x xs)) (:: (apply f x) (apply map f xs)))((f otherwise) undefined))-} Formula (Lambda 24658672 [([Variable "f",List 12303291 []],List 12303291 []),([Variable "f",BinOp 867 OpCons [Variable "x",Variable "xs"]],BinOp 8427 OpCons [App 1552 (Variable "f") [Variable "x"],App 4147 (Variable "map") [Variable "f",Variable "xs"]]),([Variable "f",Variable "otherwise"],Variable "undefined")])),("max",{-(lambda ((a b) (apply if (> a b) a b)))-} Formula (Lambda 60786 [([Variable "a",Variable "b"],App 59922 (Variable "if") [BinOp 918 OpGt [Variable "a",Variable "b"],Variable "a",Variable "b"])])),("min",{-(lambda ((a b) (apply if (< a b) a b)))-} Formula (Lambda 61554 [([Variable "a",Variable "b"],App 60690 (Variable "if") [BinOp 906 OpLt [Variable "a",Variable "b"],Variable "a",Variable "b"])])),("modintern",{-(lambda ((True rest num) rest)((False rest num) (apply modintern (< (poly num (0, (poly rest (1, 1) )) (1, -1) ) num) (poly num (0, (poly rest (1, 1) )) (1, -1) ) num)))-} Formula (Lambda 1040531 [([Truth True,Variable "rest",Variable "num"],Variable "rest"),([Truth False,Variable "rest",Variable "num"],App 257624 (Variable "modintern") [BinOp 3952 OpLt [Poly 448 (Polynome "num" [(CoeffInt 0,Polynome "rest" [(CoeffInt 1,PolyRest (CoeffInt 1))]),(CoeffInt 1,PolyRest (CoeffInt (-1)))]),Variable "num"],Poly 448 (Polynome "num" [(CoeffInt 0,Polynome "rest" [(CoeffInt 1,PolyRest (CoeffInt 1))]),(CoeffInt 1,PolyRest (CoeffInt (-1)))]),Variable "num"])])),("modulo",{-(lambda ((n p) (apply modintern (< n p) n p)))-} Formula (Lambda 63750 [([Variable "n",Variable "p"],App 62984 (Variable "modintern") [BinOp 800 OpLt [Variable "n",Variable "p"],Variable "n",Variable "p"])])),("reverse",{-(lambda ((lst) (apply foldl cons (list ) lst)))-} Formula (Lambda 98407080 [([Variable "lst"],App 98406739 (Variable "foldl") [Variable "cons",List 12303291 [],Variable "lst"])])),("taylor",{-(lambda ((f var a n) (Sort (Cleanup (apply taylorin (LambdaBuild (lambda (((Force var)) (Force f)))) var a n)))))-} Formula (Lambda 1879091869 [([Variable "f",Variable "var",Variable "a",Variable "n"],Meta 1879051629 Sort (Meta 34423 Cleanup (App 538384 (Variable "taylorin") [Meta (-1895824344) LambdaBuild (Lambda (-268434904) [([Meta (-1879047910) Force (Variable "var")],Meta 1610613004 Force (Variable "f"))]),Variable "var",Variable "a",Variable "n"])))])),("taylorin",{-(lambda ((f var a 0) (apply f a))((f var a n) (+ (apply taylorin f var a (poly n (0, -1) (1, 1) )) (* (/ (apply (apply derivaten f var (Force n)) a) (! n)) (^ (poly a (0, (poly x (1, 1) )) (1, -1) ) n)))))-} Formula (Lambda 50262095 [([Variable "f",Variable "var",Variable "a",CInteger 0],App 1545 (Variable "f") [Variable "a"]),([Variable "f",Variable "var",Variable "a",Variable "n"],BinOp 12514838 OpAdd [App 43531 (Variable "taylorin") [Variable "f",Variable "var",Variable "a",Poly 107 (Polynome "n" [(CoeffInt 0,PolyRest (CoeffInt (-1))),(CoeffInt 1,PolyRest (CoeffInt 1))])],BinOp 12297802 OpMul [BinOp 1537203 OpDiv [App 192167 (App (-536858900) (Variable "derivaten") [Variable "f",Variable "var",Meta (-536870644) Force (Variable "n")]) [Variable "a"],UnOp 403 OpFactorial (Variable "n")],BinOp 934 OpPow [Poly (-2147483521) (Polynome "a" [(CoeffInt 0,Polynome "x" [(CoeffInt 1,PolyRest (CoeffInt 1))]),(CoeffInt 1,PolyRest (CoeffInt (-1)))]),Variable "n"]]])]))] + diff --git a/EqManips/Conf.hs b/EqManips/Conf.hs new file mode 100644 --- /dev/null +++ b/EqManips/Conf.hs @@ -0,0 +1,5 @@ +module EqManips.Conf where + +maxRecursiveDepth :: Int +maxRecursiveDepth = 256 + diff --git a/EqManips/Domain.hs b/EqManips/Domain.hs new file mode 100644 --- /dev/null +++ b/EqManips/Domain.hs @@ -0,0 +1,60 @@ +module EqManips.Domain where + +-- | Describe the bound kinds of an interval +data Openness = + Include -- ^ [0;1] 0 and 1 included + | Exclude -- ^ ]0;1[ 0 and 1 excluded + deriving (Eq, Show) + +type Bound = (Double, Openness) + +-- | Yeay, interval +data Interval = Interval !Bound !Bound deriving (Eq, Show) + +data Domain = + -- | Describe an application, typically : + -- [-inf; +inf] -> [-1;1] + -- [0; +inf] -> [-inf; +inf] + -- [0;1] U [2;3] -> [0;1] U [2;2.5] + App [Interval] [Interval] + deriving (Eq, Show) + +union :: Interval -> Interval -> [Interval] +union i1@(Interval (l,kl) (h,kh)) i2@(Interval (l',kl') (h',kh')) + | l' < l = union i2 i1 + -- [+ [- +] -] + -- l l' h k' + | l' < h = [Interval (l, kl) (h', kh')] + -- [+ +]]- -] + -- [+ +[[- -] + | h == l' && (kh == Include || kl' == Include) = + [Interval (l, kl) (h', kh')] + -- [+ +] [- -] + | otherwise = [i1, i2] + +instance Ord Openness where + (<) Include Exclude = True + (<) Include Include = False + (<) Exclude Include = False + (<) Exclude Exclude = False + +instance Num Interval where + (Interval x1 x2) + (Interval y1 y2) = + Interval (x1 + y1) (x2 + y2) + + (Interval x1 x2) - (Interval y1 y2) = + Interval (x1 - y2) (x2 - y1) + + (Interval x1 x2) * (Interval y1 y2) = + Interval ( minimum crossProduct, maximum crossProduct ) + where crossProduct = [ x * y | x <- [x1, x2], y <- [y1, y2] ] + + abs i@(Interval x y) + | x > 0 && y > 0 = i + | x < 0 && y > 0 = Interval (abs x) y + -- Here x < 0 && y < 0, x > 0 && y < 0 + -- cannot happen by definition. + | otherwise = Interval (abs y) (abs x) + negate (Interval x y) = Interval (negate y) $ negate x + signum (Interval x y) = Interval (signum x) $ signum y + diff --git a/EqManips/ErrorMessages.hs b/EqManips/ErrorMessages.hs new file mode 100644 --- /dev/null +++ b/EqManips/ErrorMessages.hs @@ -0,0 +1,108 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +-- | This module should be imported as qualified +module EqManips.ErrorMessages where + +-------------------------------------------------- +---- Generic stuff +-------------------------------------------------- +shouldnt_happen = (++ "Shouldn't happen") +reOp = "reOp Empty formula? WTF" +impossible = (++ " It's impossible. Really.") + +-------------------------------------------------- +---- Eval defs +-------------------------------------------------- +def_diff_argcount = "Warning definition with different argument count" +def_not_lambda = (++ " already defined as not a function") +def_already = (++ " is already defined") + +-------------------------------------------------- +---- Eval errors +-------------------------------------------------- +attrib_in_expr = "You can't attribute a value in an expression" +div_undefined_matrixes = "Division is not defined for matrixes" +div_by_0 = "This expression evaluate to 0, and is used in a division." + +max_recursion = "Recursion limit excedeed" + +factorial_on_real = "Can't apply factorial to real number" +factorial_negative = "No factorial of negative numbers" +factorial_matrix = "No factorial of matrix" + +add_matrix = "Addition between matrix and scalar is invalid" +sub_matrix = "Substraction between matrix and scalar is invalid" + +empty_binop = (++ "Operator denormalized, no operand in it") +single_binop = (++ "Operator denormalized, only one operand in it") + +not_here = (++ "Shouldn't happen here") +app_no_applygindef = "No function definition match the parameters" + + +deriv_bad_var_spec = "Sorry your derivation doesn't have a good variable specification" +sum_wrong_bounds = "Sorry, your sum as wrong bounds, can't evaluate" +product_wrong_bounds = "Sorry, your product as wrong bounds, can't evaluate" +integration_no_eval = "No algorithm to integrate your function, sorry" +block_eval = "Block cannot be evaluated" + +matrixScalar_badop = "matrixScalar - Should be impossible" +matrix_mul_bad_size = "Error can't multiply matrix, m2 has wrong height" +matrix_empty = "Matrixes are empty" +matrix_diff_size = "Sorry can't apply this operation on matrix of different sizes" + +out_of_bound_index = "Your indexes are out of bound" +integer_not_indexable = "Numbers cannot be indexed" +float_not_indexable = "Numbers cannot be indexed" + +eval_not_list = "You can only append to a list" + +-------------------------------------------------- +---- MetaEval +-------------------------------------------------- +wrong_lambda_format = "Your lambda definition doesn't have the good format" + +-------------------------------------------------- +---- Derivative +-------------------------------------------------- +deriv_no_multi_app = "Ok, now solution for app with multi argument" +deriv_no_eq_expr = "Can't derivate expression with a '='" +deriv_no_attrib_expr = "Can't derivate an assignation ':='" +deriv_no_sum = "Sum differentiation is not defined" +deriv_no_product = "Product differentiation is not defined" +deriv_floor_not_continuous = "The floor function is not continuous" +deriv_ceil_not_continuous = "The ceil function in not continuous" +deriv_frac_not_continuous = "I don't know how to derivate the fractional part" +deriv_in_deriv = "No nested differentiation allowed" +deriv_no_integration = "No integration allowed in differentiation" +deriv_no_matrix = "No matrix allowed in differentiation" +deriv_no_bool = "No Boolean value allowed in differentiation" +deriv_lambda = "Differentiation of lambdas" +deriv_block = "An error as previously occured during evaluation, can't differentiate" +deriv_no_factorial = "Differentiation of factorials is undefined" +deriv_no_abs = "Absolute value is not derivable" +deriv_no_log = "No position for Log for now" +deriv_no_list = "Cannot derivate lists" +deriv_no_meta = "No meta operation allowed in derivation" + +-------------------------------------------------- +---- C output +-------------------------------------------------- +c_out_lambda = "We can't output lambda function in C" +c_out_integrate = "We can't output integrals function in C" +c_out_derivate = "We can't output derivative function in C" +c_out_block = "We can't output evaluation errors in C" +c_out_matrix = "We can't output matrix in C for now (maybe in the future)" +c_out_bad_iteration = "We can't translate product or sum to a meaningfull loop" +c_out_bad_binop = "The binary operator has a wrong internal form" +c_out_complex = "Complex is not yet decided for C/C++ output" +c_out_list = "List cannot be outputed yet in C/C++" + +-------------------------------------------------- +---- Polynome +-------------------------------------------------- +polynom_bad_casting = "Error, coefficients are not compatible, casting error" +polynom_emptyCoeffPack = "Error, empty coeff, big bug!!" +ill_formed_polynomial = "Error the polynome is ill formed, no element in it" +polynom_coeff_notascalar = "Error, you're trying to create a polynome coefficient from a non-scalar element" +polynome_empty = "Error, the polynomial is empty, which is not allowed" +polynome_no_coeff_substitution = "Error, the polynomial coefficient shouldn't be substitued by formula" diff --git a/EqManips/EvaluationContext.hs b/EqManips/EvaluationContext.hs new file mode 100644 --- /dev/null +++ b/EqManips/EvaluationContext.hs @@ -0,0 +1,255 @@ +module EqManips.EvaluationContext( EqTransformInfo( .. ) + , EqContext + , performTransformation + , performTransformationWithContext + , performLastTransformation + , performLastTransformationWithContext + , obtainEqResult + , cleanErrorList + , addSymbols + , addSymbol, delSymbol, updateSymbol + , eqFail, eqPrimFail + , symbolLookup + , pushContext, popContext, setContext + , contextStackSize +#ifdef _DEBUG + , addTrace + , printTrace + , traceContext +#endif /* _DEBUG */ + ) where + +import Data.Map (Map) +import Control.Applicative +import qualified Data.Map as Map + +import EqManips.Types +import EqManips.Algorithm.Utils + +#ifdef _DEBUG +import System.IO +import qualified EqManips.Renderer.RenderConf as RenderConf + +import {-# SOURCE #-} EqManips.Renderer.Ascii( formatFormula ) +import {-# SOURCE #-} EqManips.Renderer.Sexpr +#endif /* _DEBUG */ + +-- | The real context info. +data EqTransformInfo = EqTransformInfo { + -- | Well, here context mean more "symbol table" + -- associate some variable with a definition. + context :: Map String (Formula ListForm) + -- | A context "stack" used to handle some scoping + -- which can be used to evaluate some sums. + , contextStack :: [Map String (Formula ListForm)] + + -- | Depth of the context stack. Used to limit + -- recursion in the monad. + , contextDepth :: !Int + + -- | Some constraints put on variables + , assertions :: Map String FormulaPrim + + -- | List of errors encountered when + -- transforming formula + , errorList :: [(Formula TreeForm,String)] + + -- | The result of the formula computation + , result :: Formula ListForm + +#ifdef _DEBUG + -- | Used for debugging, can print everything + , trace :: [(String, Formula TreeForm)] +#endif /* _DEBUG */ + } + +-- | Here we go, our evaluation monad. +-- It's basically a State monad, but providing +-- more services usefull to the software +data EqContext a = EqContext { + runEqTransform :: EqTransformInfo -> (EqTransformInfo, a) + } + +instance Functor EqContext where + {-# INLINE fmap #-} + fmap f m = EqContext $ \c -> + let (c', a) = runEqTransform m c + in (c', f a) + +instance Applicative EqContext where + {-# INLINE pure #-} + pure a = EqContext $ \c -> (c,a) + + {-# INLINE (<*>) #-} + (EqContext ff) <*> (EqContext a) = EqContext $ \c -> + let (c' , f) = ff c + (c'', a') = a c' + in (c'', f a') + +instance Monad EqContext where + {-# INLINE return #-} + return a = EqContext $ \c -> (c, a) + + {-# INLINE (>>=) #-} + prev >>= k = EqContext $ \c -> + let (c', a) = runEqTransform prev c + in runEqTransform (k a) c' + +-- | A basic initial context +emptyContext :: EqTransformInfo +emptyContext = EqTransformInfo { + context = Map.empty + , contextStack = [] + , contextDepth = 0 + , assertions = Map.empty + , errorList = [] + , result = Formula $ Block 0 0 0 +#ifdef _DEBUG + , trace = [] +#endif /* _DEBUG */ + } + +#ifdef _DEBUG +-- | Function used to add a trace in debug. +-- don't forget to surround it's use by #ifdef _DEBUG/#endif +addTrace :: (String, Formula TreeForm) -> EqContext () +addTrace newTrace = EqContext $ \c -> + (c { trace = newTrace : trace c }, ()) + +-- | Print all the trace found. +printTrace :: Handle -> EqTransformInfo -> IO () +printTrace f inf = mapM_ showIt . reverse $ trace inf + where showIt (str, formula) = do + hPutStrLn f "==========================================" + hPutStrLn f str + hPutStrLn f $ sexprRender formula + hPutStrLn f $ formatFormula RenderConf.defaultRenderConf + formula + +traceContext :: EqContext () +traceContext = EqContext $ \c -> + let contextes = unlines + . map (\a -> printContext a ++ "\n/////////////////////////////////////////////////\n") + . map Map.toList + $ contextStack c + printContext var = concat $ map (\(a,f) -> a ++ " =\n" + ++ formatFormula RenderConf.defaultRenderConf + (treeIfyFormula f) + ++ "\n") + var + in + ( c { trace = ("ContextStack | " ++ contextes, Formula $ Variable "") + : ("Context | " ++ (show $ context c), Formula $ Variable "") : trace c } + , () + ) +#endif /* _DEBUG */ + +-- | Keep a track of current context, keep previous context clean +pushContext :: EqContext () +pushContext = EqContext $ \c -> + (c { contextStack = context c : contextStack c + , contextDepth = contextDepth c + 1 + } + , ()) + +-- | Discard the current deep context and restore the one +-- which was previously "pushed" by pushContext. If no +-- context was there, an empty one is put in place +popContext :: EqContext () +popContext = EqContext $ \c -> + let safeHeadTail (x:xs) = (x, xs) + safeHeadTail [] = (Map.empty, []) + (oldContext, stack) = safeHeadTail $ contextStack c + in + (c { contextStack = stack + , context = oldContext + , contextDepth = contextDepth c - 1 + } + , ()) + +setContext :: [(String, Formula ListForm)] -> EqContext () +setContext newContext = EqContext $ \c -> + (c { context = Map.fromList newContext }, ()) + +-- | Cleanup error list, useful in cases of +-- threaded computation +cleanErrorList :: EqContext () +cleanErrorList = EqContext $ \c -> (c { errorList = [] }, ()) + +type FormulaForm = ListForm + +-- | Public function of the API to retrieve the result of +-- a formula transformation. The type is opaque otherwise. +performTransformation :: EqContext (Formula FormulaForm) -> EqTransformInfo +performTransformation = performTransformationWithContext Map.empty + +-- | Evaluate a formula, you can provide variable bindings +performTransformationWithContext :: Map String (Formula ListForm) + -> EqContext (Formula ListForm) + -> EqTransformInfo +performTransformationWithContext base m = ctxt { result = formula } + where (ctxt, formula) = runEqTransform m $ emptyContext { context = base } + +-- | Evaluate a programm, with no pre-definitions +performLastTransformation :: EqContext [Formula FormulaForm] -> EqTransformInfo +performLastTransformation = + performLastTransformationWithContext Map.empty + +-- | Run a programm and get the last statement. +-- You can run programm with your pre-defined symbols +performLastTransformationWithContext :: Map String (Formula ListForm) + -> EqContext [Formula FormulaForm] + -> EqTransformInfo +performLastTransformationWithContext c m = ctxt { result = last formula } + where (ctxt, formula) = runEqTransform m $ emptyContext { context = c } + +obtainEqResult :: EqContext a -> a +obtainEqResult m = snd $ runEqTransform m emptyContext + +-- | Remove a variable from the context +delSymbol :: String -> EqContext () +delSymbol s = EqContext $ \ctxt -> + (ctxt { context = Map.delete s $ context ctxt}, ()) + +updateSymbol :: String -> Formula ListForm -> EqContext () +updateSymbol varName def = do + delSymbol varName + addSymbol varName def + +addSymbols :: [(String, Formula ListForm)] -> EqContext () +addSymbols adds = EqContext $ \eqCtxt -> + let syms = context eqCtxt + in -- union is left biased, we use it here, new symbols + -- at the left of union !! + ( eqCtxt { context = Map.fromList adds `Map.union` syms}, ()) + +-- | Add a variable into the context +addSymbol :: String -> Formula ListForm -> EqContext () +addSymbol varName def = EqContext $ \eqCtxt -> + let prevSymbol = context eqCtxt + in ( eqCtxt{ context = Map.insert varName def prevSymbol }, ()) + +contextStackSize :: EqContext Int +contextStackSize = EqContext $ \eqCtxt -> + (eqCtxt, contextDepth eqCtxt) + +-- | Check if a symbol is present, and if so, return it's +-- definition +symbolLookup :: String -> EqContext (Maybe (Formula ListForm)) +symbolLookup varName = EqContext $ \eqCtxt -> + (eqCtxt, Map.lookup varName $ context eqCtxt) + +-- | Used to provide error messages at the end of the computation +-- (when jumping back to IO), and also assure a nice partial evaluation, +-- by replacing the faulty formula by a block. +eqFail :: Formula TreeForm -> String -> EqContext (Formula a) +eqFail formula errorText = EqContext $ \eqCtxt -> + let prevErr = errorList eqCtxt + in ( eqCtxt {errorList = (formula, errorText):prevErr}, Formula $ Block 1 1 1) + +-- | Little helper to be able to use eqFail easily when +-- manipulating FormulaPrim formula. Assume that FormulaPrim +-- is in List Form. Use eqFail otherwise. +eqPrimFail :: FormulaPrim -> String -> EqContext FormulaPrim +eqPrimFail f s = unTagFormula `fmap` eqFail (treeIfyFormula $ Formula f) s + diff --git a/EqManips/FormulaIterator.hs b/EqManips/FormulaIterator.hs new file mode 100644 --- /dev/null +++ b/EqManips/FormulaIterator.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module EqManips.FormulaIterator( depthFirstFormula + , depthFormulaTraversal + , depthFormulaPrimTraversal + , depthPrimTraversal + , topDownTraversal + , topDownScanning + ) where + +import Control.Applicative +import Control.Monad.Identity +import EqManips.Types + +import EqManips.EvaluationContext + +-- | Depth first traversal of formula. +-- the function is applied to each subformula when +-- the traversal is coming back to the top of the +-- formula tree. +depthFirstFormula :: (Applicative m, Monad m) + => (Formula a -> m (Formula b)) -> Formula a -> m (Formula b) +depthFirstFormula = depthFormulaTraversal . const $ return () + +depthFormulaTraversal :: (Applicative m, Monad m) + => (Formula a -> m ()) + -> (Formula a -> m (Formula b)) + -> Formula a -> m (Formula b) +depthFormulaTraversal pre f formula = do + prim <- depthPrimTraversal + (pre . Formula) + -- Can't get it to compile with >>= or <$> + -- so back to ugly form + (\a -> do a' <- f $ Formula a + return $ unTagFormula a') + $ unTagFormula formula + return $ Formula prim + + +depthFormulaPrimTraversal :: (Applicative m, Monad m) + => (FormulaPrim -> m FormulaPrim) + -> FormulaPrim + -> m FormulaPrim +depthFormulaPrimTraversal = depthPrimTraversal (const $ return ()) + +topDownTraversal :: (FormulaPrim -> Maybe FormulaPrim) + -> FormulaPrim -> FormulaPrim +topDownTraversal f formu = + runIdentity $ topDownScanning (return . f) formu + +fromMaybeM :: (Monad m) => m a -> m (Maybe a) -> m a +fromMaybeM e da = do + rez <- da + case rez of + Nothing -> e + Just a -> return a + +-- | This function must be used to transform function from +-- the top. +{-# SPECIALIZE topDownScanning :: (FormulaPrim -> Identity (Maybe FormulaPrim)) + -> FormulaPrim -> Identity FormulaPrim #-} +{-# SPECIALIZE topDownScanning :: (FormulaPrim -> EqContext (Maybe FormulaPrim)) + -> FormulaPrim -> EqContext FormulaPrim #-} +topDownScanning :: (Monad m, Applicative m) + => (FormulaPrim -> m (Maybe FormulaPrim)) + -> FormulaPrim + -> m FormulaPrim +topDownScanning f p@(Poly _ _) = fromMaybeM (return p) $ f p +topDownScanning f v@(Variable _) = fromMaybeM (return v) $ f v +topDownScanning f i@(CInteger _) = fromMaybeM (return i) $ f i +topDownScanning f i@(Fraction _) = fromMaybeM (return i) $ f i +topDownScanning f i@(Complex _ _) = fromMaybeM (return i) $ f i +topDownScanning f d@(CFloat _) = fromMaybeM (return d) $ f d +topDownScanning f e@(NumEntity _) = fromMaybeM (return e) $ f e +topDownScanning f t@(Truth _) = fromMaybeM (return t) $ f t +topDownScanning f l@(Lambda _ eqs) = + fromMaybeM (lambda <$> lambda') $ f l + where lambda' = sequence + [ do args' <- mapM (topDownScanning f) args + body' <- topDownScanning f body + return (args', body') | (args, body) <- eqs] + +topDownScanning f met@(Meta _ op form) = + fromMaybeM (meta op <$> topDownScanning f form) $ f met + +topDownScanning f i@(Indexes _ what lst) = do + what' <- topDownScanning f what + fromMaybeM (indexes what' <$> mapM (topDownScanning f) lst) + $ f i + +topDownScanning f l@(List _ lst) = + fromMaybeM (list <$> mapM (topDownScanning f) lst) $ f l + +topDownScanning f formula@(App _ func args) = + fromMaybeM (app <$> mayFunc <*> mayArgs) $ f formula + where mayFunc = topDownScanning f func + mayArgs = mapM (topDownScanning f) args + +topDownScanning f formula@(Sum _ ini end what) = + fromMaybeM (summ <$> mayIni <*> mayEnd <*> mayWhat) $ f formula + where mayIni = topDownScanning f ini + mayEnd = topDownScanning f end + mayWhat = topDownScanning f what + +topDownScanning f formula@(Product _ ini end what) = + fromMaybeM (productt <$> mayIni <*> mayEnd <*> mayWhat) $ f formula + where mayIni = topDownScanning f ini + mayEnd = topDownScanning f end + mayWhat = topDownScanning f what + +topDownScanning f formula@(Derivate _ what var) = + fromMaybeM (derivate <$> mayWhat <*> mayVar ) $ f formula + where mayVar = topDownScanning f var + mayWhat = topDownScanning f what + +topDownScanning f formula@(Integrate _ ini end what var) = + fromMaybeM (integrate <$> mayIni <*> mayEnd <*> mayWhat <*> mayVar) $ f formula + where mayIni = topDownScanning f ini + mayEnd = topDownScanning f end + mayWhat = topDownScanning f what + mayVar = topDownScanning f var + +topDownScanning f formula@(Matrix _ n m cells) = + fromMaybeM (matrix n m <$> mapM (mapM (topDownScanning f)) cells) + $ f formula + +topDownScanning f formula@(UnOp _ op sub) = + fromMaybeM (unOp op <$> topDownScanning f sub) $ f formula + +topDownScanning f formula@(BinOp _ op fs) = + fromMaybeM (binOp op <$> mapM (topDownScanning f) fs) $ f formula + +-- Hmm, it's a debug for renderer, we dont really care +topDownScanning _ b@(Block _ _ _) = return b + + +-- | Depth first traversal providing two events : +-- - One pre event which is called when a node is +-- reached when descending the tree +-- - One post event similar to depthFirstFormula, +-- reached when the traversal go up. +-- Note : the leaf don't have a pre event, just a +-- post. +{-# SPECIALIZE depthPrimTraversal :: (FormulaPrim -> Identity ()) + -> (FormulaPrim -> Identity FormulaPrim) + -> FormulaPrim -> Identity FormulaPrim #-} +{-# SPECIALIZE depthPrimTraversal :: (FormulaPrim -> EqContext ()) + -> (FormulaPrim -> EqContext FormulaPrim) + -> FormulaPrim -> EqContext FormulaPrim #-} +depthPrimTraversal :: (Applicative m, Monad m) + => (FormulaPrim -> m ()) + -> (FormulaPrim -> m FormulaPrim) + -> FormulaPrim + -> m FormulaPrim +depthPrimTraversal _ f p@(Poly _ _) = f p +depthPrimTraversal _ f v@(Variable _) = f v +depthPrimTraversal _ f i@(CInteger _) = f i +depthPrimTraversal _ f i@(Fraction _) = f i +depthPrimTraversal _ f d@(CFloat _) = f d +depthPrimTraversal _ f e@(NumEntity _) = f e +depthPrimTraversal _ f t@(Truth _) = f t +depthPrimTraversal pre f i@(Indexes _ main lst) = do + pre i + main' <- depthPrimTraversal pre f main + lst' <- mapM (depthPrimTraversal pre f) lst + f $ indexes main' lst' + +depthPrimTraversal pre f i@(List _ lst) = do + pre i + lst' <- mapM (depthPrimTraversal pre f) lst + f $ list lst' + +depthPrimTraversal pre f c@(Complex _ (r, i)) = do + pre c + r' <- depthPrimTraversal pre f r + i' <- depthPrimTraversal pre f i + f $ complex (r', i') + +depthPrimTraversal pre f l@(Lambda _ eqs) = do + pre l + f =<< lambda <$> mapM traverser eqs + where traverser (args, body) = do + body' <- depthPrimTraversal pre f body + return (args, body') + +depthPrimTraversal pre post met@(Meta _ op f) = do + pre met + post =<< meta op <$> depthPrimTraversal pre post f + +depthPrimTraversal pre post formula@(App _ func args) = do + pre formula + post =<< app <$> depthPrimTraversal pre post func + <*> mapM (depthPrimTraversal pre post) args + +depthPrimTraversal pre post formula@(Sum _ ini end what) = do + pre formula + post =<< summ <$> depthPrimTraversal pre post ini + <*> depthPrimTraversal pre post end + <*> depthPrimTraversal pre post what + +depthPrimTraversal pre post formula@(Product _ ini end what) = do + pre formula + post =<< productt <$> depthPrimTraversal pre post ini + <*> depthPrimTraversal pre post end + <*> depthPrimTraversal pre post what + +depthPrimTraversal pre post formula@(Derivate _ what var) = do + pre formula + post =<< derivate <$> depthPrimTraversal pre post what + <*> depthPrimTraversal pre post var + +depthPrimTraversal pre post formula@(Integrate _ ini end what var) = do + pre formula + post =<< integrate + <$> depthPrimTraversal pre post ini + <*> depthPrimTraversal pre post end + <*> depthPrimTraversal pre post what + <*> depthPrimTraversal pre post var + +depthPrimTraversal pre post formula@(Matrix _ n m cells) = do + pre formula + post =<< matrix n m + <$> sequence [ mapM (depthPrimTraversal pre post) matrixLine + | matrixLine <- cells] + +depthPrimTraversal pre post formula@(UnOp _ op sub) = do + pre formula + post =<< unOp op <$> depthPrimTraversal pre post sub + +depthPrimTraversal pre post formula@(BinOp _ op fs) = do + pre formula + post =<< binOp op <$> mapM (depthPrimTraversal pre post) fs + +-- Hmm, it's a debug for renderer, we dont really care +depthPrimTraversal _ _ b@(Block _ _ _) = return b + diff --git a/EqManips/FormulaIterator.hs-boot b/EqManips/FormulaIterator.hs-boot new file mode 100644 --- /dev/null +++ b/EqManips/FormulaIterator.hs-boot @@ -0,0 +1,27 @@ +module EqManips.FormulaIterator where + +import Control.Applicative +import EqManips.Types + +depthFirstFormula :: (Applicative m, Monad m) + => (Formula a -> m (Formula b)) -> Formula a -> m (Formula b) + +depthFormulaTraversal :: (Applicative m, Monad m) + => (Formula a -> m ()) + -> (Formula a -> m (Formula b)) + -> Formula a -> m (Formula b) + +depthFormulaPrimTraversal :: (Applicative m, Monad m) + => (FormulaPrim -> m FormulaPrim) + -> FormulaPrim + -> m FormulaPrim + +topDownTraversal :: (FormulaPrim -> Maybe FormulaPrim) + -> FormulaPrim + -> FormulaPrim + +depthPrimTraversal :: (Applicative m, Monad m) + => (FormulaPrim -> m ()) + -> (FormulaPrim -> m FormulaPrim) + -> FormulaPrim + -> m FormulaPrim diff --git a/EqManips/InputParser/EqCode.hs b/EqManips/InputParser/EqCode.hs new file mode 100644 --- /dev/null +++ b/EqManips/InputParser/EqCode.hs @@ -0,0 +1,174 @@ +module EqManips.InputParser.EqCode + ( program -- if you want to define some definition before + , expr -- if you want to evaluate just an expression + , parseFormula + , perfectParse + , parseProgramm + ) where + + +import Control.Applicative( (<$>), (<*) ) +import Control.Monad.Identity + +import EqManips.Types +import EqManips.Polynome +import EqManips.Linker +import EqManips.Algorithm.Utils + +import Text.Parsec.Expr +import Text.Parsec +import Text.Parsec.Language( haskellStyle ) +import qualified Text.Parsec.Token as P + +-- | Helper function to parse a formula and apply all +-- needed algorithm to be able to apply them +parseFormula :: String -> Either ParseError (Formula ListForm) +parseFormula = either Left (Right . polynomizeFormula) . perfectParse + +-- | Parse a formula and doesn't alter it's global form +-- (no polynomization) +perfectParse :: String -> Either ParseError (Formula ListForm) +perfectParse text = case runParser expr () "FromFile" text of + Left e -> Left e + Right f -> Right . listifyFormula + . linkFormula + $ Formula f + +-- | Helper function to use to parse a programm. +-- Perform some transformations to get a usable +-- formula. +parseProgramm :: String -> Either ParseError [Formula ListForm] +parseProgramm text = rez + where parsed = runParser program () "FromFile" text + rez = case parsed of + Left a -> Left a + Right f -> Right $ map ( polynomizeFormula + . listifyFormula + . linkFormula + . Formula ) f + +----------------------------------------------------------- +-- Lexing defs +----------------------------------------------------------- +float :: Parsed st Double +float = P.float lexer + +identifier :: Parsed st String +identifier = P.identifier lexer + +reservedOp :: String -> Parsed st () +reservedOp= P.reservedOp lexer + +integer :: Parsed st Integer +integer = P.integer lexer + +parens :: ParsecT String u Identity a -> ParsecT String u Identity a +parens = P.parens lexer + +braces :: ParsecT String u Identity a -> ParsecT String u Identity a +braces = P.braces lexer + +brackets :: ParsecT String u Identity a -> ParsecT String u Identity a +brackets = P.brackets lexer + +whiteSpace :: Parsed st () +whiteSpace = P.whiteSpace lexer + +lexer :: P.GenTokenParser String st Identity +lexer = P.makeTokenParser + (haskellStyle { P.reservedOpNames = [ "&", "|", "<", ">" + , "*", "/", "+", "-" + , "^", "=", "!", ":" + , "_" + ] + , P.identStart = letter + } ) + +----------------------------------------------------------- +-- Real "grammar" +----------------------------------------------------------- +type Parsed st b = ParsecT String st Identity b + +program :: Parsed st [FormulaPrim] +program = sepBy expr (whiteSpace >> char ';' >> whiteSpace) <* whiteSpace + "program" + +-- | Parser for the mini language is defined here +expr :: Parsed st FormulaPrim +expr = whiteSpace >> buildExpressionParser operatorDefs funCall + "expression" + +operatorDefs :: OperatorTable String st Identity FormulaPrim +operatorDefs = + [ [postfix "!" (unOp OpFactorial)] + , [prefix "-" (unOp OpNegate) ] + , [binary "_" (\a b -> indexes a [b]) AssocLeft] + , [binary "^" (binop OpPow) AssocLeft] + , [binary "/" (binop OpDiv) AssocLeft, binary "*" (binop OpMul) AssocLeft] + , [binary "+" (binop OpAdd) AssocLeft, binary "-" (binop OpSub) AssocLeft] + , [binary "=" (binop OpEq) AssocRight, binary "/=" (binop OpNe) AssocLeft + ,binary "<" (binop OpLt) AssocLeft, binary ">" (binop OpGt) AssocLeft + ,binary "<=" (binop OpLe) AssocLeft, binary ">=" (binop OpGe) AssocLeft] + , [binary "&" (binop OpAnd) AssocLeft, binary "|" (binop OpOr) AssocLeft] + , [binary "::" (binop OpCons) AssocRight] + , [ binary ":>" (binop OpLazyAttrib) AssocRight + , binary ":=" (binop OpAttrib) AssocRight] + ] + +funCall :: Parsed st FormulaPrim +funCall = do + caller <- term + (app caller <$> argList) <|> return caller + where argSeparator = whiteSpace >> char ',' >> whiteSpace + exprList = sepBy expr argSeparator + argList = parens (whiteSpace >> (exprList <* whiteSpace)) + +listParser :: Parsed st FormulaPrim +listParser = do + lst <- brackets $ sepBy expr (whiteSpace >> char ',' >> whiteSpace) <* whiteSpace + return $ list lst + +variable :: Parsed st FormulaPrim +variable = Variable <$> identifier + "variable" + +term :: Parsed st FormulaPrim +term = try trueConst + <|> try falseConst + <|> try nilConst + <|> variable + <|> try ellipses + <|> try (CFloat <$> float) + <|> CInteger . fromInteger <$> integer + <|> parens expr + <|> meta Force <$> braces expr + <|> listParser + "Term error" + +ellipses :: Parsed st FormulaPrim +ellipses = return (NumEntity Ellipsis) <* (string "..." >> whiteSpace) + +nilConst :: Parsed st FormulaPrim +nilConst = return (list []) <* (string "[]" >> whiteSpace) + +trueConst :: Parsed st FormulaPrim +trueConst = return (Truth True) <* (string "true" >> whiteSpace) + +falseConst :: Parsed st FormulaPrim +falseConst = return (Truth False) <* (string "false" >> whiteSpace) + +----------------------------------------------- +---- Little helpers +----------------------------------------------- +binary :: String -> (a -> a -> a) -> Assoc -> Operator String st Identity a +binary name fun = Infix (do{ reservedOp name; return fun }) + +prefix :: String -> (a -> a) -> Operator String st Identity a +prefix name fun = Prefix (do{ reservedOp name; return fun }) + +postfix :: String -> (a -> a) -> Operator String st Identity a +postfix name fun = Postfix (do{ reservedOp name; return fun }) + +binop :: BinOperator -> FormulaPrim -> FormulaPrim -> FormulaPrim +binop op left right = binOp op [left, right] + diff --git a/EqManips/InputParser/MathML.hs b/EqManips/InputParser/MathML.hs new file mode 100644 --- /dev/null +++ b/EqManips/InputParser/MathML.hs @@ -0,0 +1,226 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module EqManips.InputParser.MathML ( mathMlToEqLang + , mathMlToEqLang' + ) where + +import Control.Applicative +import EqManips.Algorithm.Utils +import qualified EqManips.UnicodeSymbols as Uni + +import Text.XML.HaXml.Parse +import Text.XML.HaXml.Types + +-- | Type used to reduce the complexity of XML +-- tree and favor an easier pattern matching +data ReducedXmlTree = + Xop String + | Xsymb String + | Xnum String + | Xsqrt ReducedXmlTree + | Xfrac ReducedXmlTree ReducedXmlTree + | Xsup ReducedXmlTree ReducedXmlTree + | XunderOver ReducedXmlTree ReducedXmlTree ReducedXmlTree + | Xfenced String String ReducedXmlTree + | Xrow [ReducedXmlTree] + | Xtable [[ReducedXmlTree]] + deriving (Show) + +mathMlToEqLang' :: String -> String +mathMlToEqLang' = either id id . mathMlToEqLang + +-- | Input XML code encoded in a string +-- output a string in Eq Language, ready to +-- be parsed by the usual meanings. +mathMlToEqLang :: String -> Either String String +mathMlToEqLang text = + xmlParse' "mathml" text >>= simplifyXml >>= toProgramString + +toProgramString :: ReducedXmlTree -> Either String String +toProgramString tree = (\s -> s "") <$> translate tree + +simplifyXml :: Document a -> Either String ReducedXmlTree +simplifyXml (Document a b (Elem "m:math" c lst) l) = + simplifyXml (Document a b (Elem "math" c lst) l) +simplifyXml (Document _ _ (Elem "math" _ lst) _) = + Xrow <$> eitherMap (map simplifyContent lst) +simplifyXml _ = error "The xml document has the wrong format" + +strOfContent :: Content a -> String +strOfContent (CString _ txt _) = txt +strOfContent _ = error "Xml string waited at this point" + +elemOfContent :: Content a -> Element a +elemOfContent (CElem e _) = e +elemOfContent _ = error "Xml element waited at this point" + +-- | Helper to simplify content +simplifyContent :: Content a -> Either String ReducedXmlTree +simplifyContent = simplify . elemOfContent + +instance Applicative (Either a) where + pure = Right + (<*>) (Left a) _ = Left a + (<*>) (Right _) (Left b) = Left b + (<*>) (Right f) (Right v) = Right (f v) + +instance Monad (Either a) where + return = Right + (>>=) (Left a) _ = Left a + (>>=) (Right v) f = f v + +eitherMap :: [Either a b] -> Either a [b] +eitherMap [] = Right [] +eitherMap lst = foldr mapper (Right []) lst + where mapper (Left a) _ = Left a + mapper _ (Left a) = Left a + mapper (Right v) (Right list) = Right (v:list) + +-- | Really transform an XML file to a simplified tree +-- to make a better pattern matching +simplify :: Element a -> Either String ReducedXmlTree +-- This rule is for mathML generated by microsoft math input +-- panel whom got the bad habit of prefixing it by 'm:' +simplify (Elem ('m':':':xs) att cont) = simplify (Elem xs att cont) +simplify (Elem "mi" _ [c]) = Right . Xsymb $ strOfContent c +simplify (Elem "mn" _ [c]) = Right . Xnum $ strOfContent c +simplify (Elem "mo" _ [c]) = Right . Xop $ strOfContent c +simplify (Elem "mrow" _ lst) = Xrow <$> eitherMap (map simplifyContent lst) +simplify (Elem "msqrt" _ lst) = Xsqrt . Xrow <$> eitherMap (map simplifyContent lst) +simplify (Elem "mfrac" _ [a,b]) = Xfrac <$> simplifyContent a <*> simplifyContent b +simplify (Elem "msup" _ [a,b]) = Xsup <$> simplifyContent a <*> simplifyContent b +simplify (Elem "munderover" _ [a,b,c]) = + XunderOver <$> simplifyContent a <*> simplifyContent b <*> simplifyContent c + +simplify (Elem "mtable" _ lst) = Xtable <$> lineList + where lineList = eitherMap $ map (unrow . elemOfContent) lst + + unrow (Elem "m:mtr" a b) = unrow (Elem "mtr" a b) + unrow (Elem "mtr" _ cells) = eitherMap $ map (uncell . elemOfContent) cells + unrow _ = Left "Ill formed MathML Matrix" + + uncell (Elem "m:mtd" a b) = uncell (Elem "mtd" a b) + uncell (Elem "mtd" _ cellList) = Xrow <$> eitherMap (map simplifyContent cellList) + uncell _ = Left "Ill format MathML Matrix cell" + +simplify (Elem "mfenced" [ ("open", AttValue [Left openChar]) + , ("close", AttValue [Left closeChar]) ] lst) = + + Xfenced openChar closeChar . Xrow <$> eitherMap (map simplifyContent lst) + +simplify (Elem "mfenced" attrs _lst) = Left $ show attrs + +simplify (Elem elemName _ _) = Left $ "Unknown MathMl element : " ++ elemName + +str :: String -> String -> String +str = (++) + +char :: Char -> String -> String +char = (:) + +uniSymbolTranslation :: [(Int, String)] +uniSymbolTranslation = + [ (Uni.pi, "pi") + , (Uni.infinity, "infinite") + ] + +unicodeTranslation :: [(Int, String)] +unicodeTranslation = + [ (Uni.logicalAnd, "&&") + , (Uni.logicalOr, "||") + , (Uni.logicalNot, "not") + , (Uni.identicalTo, "==") + , (Uni.lessThanOrEqualTo, "<=") + , (Uni.greaterThanOrEqualTo, ">=") + , (Uni.multiplicationSign , "*") + ] + +vardeclFinder :: [ReducedXmlTree] + -> Maybe ([ReducedXmlTree],[ReducedXmlTree], String) +vardeclFinder = declFind [] + where declFind _ [] = Nothing + declFind acc (Xop [op]:next) + | fromEnum op == Uni.doubleStruckItalicSmalld = obtainVar acc next + declFind acc (Xsymb ['d']:next) = obtainVar acc next + declFind acc (Xsymb ['d', var]:next) = Just (reverse acc, next, [var]) + declFind acc (Xrow lst:next) = declFind acc (lst ++ next) + declFind acc (x:xs) = declFind (x:acc) xs + + obtainVar _ [] = Nothing + obtainVar acc (Xsymb var:next) = Just (reverse acc, next, var) + obtainVar acc (Xrow lst:next) = obtainVar acc (lst ++ next) + obtainVar _ _ = Nothing + +-- | Real transformation =) +translate :: ReducedXmlTree -> Either String ShowS +translate (Xop [s]) = case lookup (fromEnum s) unicodeTranslation of + Nothing -> Right $ char s + Just v -> Right $ str v + +translate (Xsymb [s]) = case lookup (fromEnum s) uniSymbolTranslation of + Nothing -> Right $ char s + Just v -> Right $ str v + +-- Special case to handle matrix +translate (Xfenced op en body@(Xtable _)) + | (op == "(" && en == ")") || (op == "[" && en == "]") = translate body +translate (Xfenced op en (Xrow [body@(Xtable _)])) + | (op == "(" && en == ")") || (op == "[" && en == "]") = translate body + +translate (Xfenced "(" ")" body) = + (\sub -> char '(' . sub . char ')') <$> translate body +translate (Xfenced "|" "|" body) = + (\sub -> str "abs(" . sub . char ')') <$> translate body +translate (Xfenced str1 str2 body) = + (\sub -> shows body . str str1 . sub . str str2) <$> translate body + +translate (Xrow ((XunderOver (Xop [bigop]) lowerBound upperBound):rs)) + | fromEnum bigop == Uni.sum = + (\ini end what -> str "sum(" . ini . char ',' . end . char ',' + . what . char ')') + <$> translate lowerBound + <*> translate upperBound + <*> translate (Xrow rs) + | fromEnum bigop == Uni.product = + (\ini end what -> str "product(" . ini . char ',' . end . char ',' + . what . char ')') + <$> translate lowerBound + <*> translate upperBound + <*> translate (Xrow rs) + | fromEnum bigop == Uni.integral = case vardeclFinder rs of + Nothing -> Left "Invalid integral definition, cannot be handled" + Just (acc,rest,var) -> + (\lower upper what rest' -> + str "integrate(" . lower . char ',' . upper + . char ',' . what . char ',' + . str var . char ')' . rest') + <$> translate lowerBound + <*> translate upperBound + <*> translate (Xrow acc) + <*> translate (Xrow rest) + | otherwise = Left "Unrecognized big operator" + +translate (XunderOver _ _ _) = Left "Unrecognized operator" +translate (Xop s) = Right $ str s +translate (Xsymb s) = Right $ str s +translate (Xnum s) = Right $ str s +translate (Xsqrt subTree) = (\sub -> str "sqrt(" . sub . char ')') + <$> translate subTree +translate (Xfrac a b) = (\a' b' -> char '(' . a' . str ") / (" . b' . char ')') + <$> translate a + <*> translate b + +translate (Xsup a b) = (\a' b' -> char '(' . a' . str ") ^ (" . b' . char ')') + <$> translate a + <*> translate b + +translate (Xrow []) = Right id +translate (Xrow lst) = concatS <$> eitherMap (map translate lst) + +translate (Xtable []) = Left "Wrong table format" +translate (Xtable lst) = + (\elems -> str "matrix( " . shows lineCount . char ',' . shows columncount . char ',' + . interspereseS (char ',') elems . char ')') + <$> (eitherMap . map translate $ concat lst) + where lineCount = length lst + columncount = length $ head lst + diff --git a/EqManips/Linker.hs b/EqManips/Linker.hs new file mode 100644 --- /dev/null +++ b/EqManips/Linker.hs @@ -0,0 +1,260 @@ +-- | This module will link variable names to +-- symbols. +module EqManips.Linker( DocString, LongDescr + , entityList + , metaFunctionList + , unaryFunctions + , multiParamsFunctions + , linkFormula + ) where + +import Data.List +import Data.Maybe( fromMaybe ) +import qualified Data.Map as Map + +import EqManips.Types + +-- | Linking formula doesn't change it's form, +-- so we can keep it +linkFormula :: Formula anyForm -> Formula anyForm +linkFormula (Formula a) = Formula $ link a + +type DocString = String +type LongDescr = String + +entityList :: [(String, (DocString, LongDescr, FormulaPrim))] +entityList = + [ ("infinite", ("Represent the inifinity in this program." + , "" + , NumEntity Infinite)) + , ("pi", ( "The number Pi (=3.14159...)." + , "When used, exact simplification can be used" + , NumEntity Pi)) + , ("i", ( "The imaginary number, use it to describe complex numbers." + , "i * i = -1" + , complex (CInteger 0, CInteger 1))) + ] + +metaFunctionList :: [(String, (DocString, LongDescr, FormulaPrim -> FormulaPrim))] +metaFunctionList = + [ ("Hold", ( "Avoid evaluating the expression passed as parameter." + , "" + , meta Hold)) + , ("Force", ( "Force the evaluation of sub-expression even if the enclosing" + , "" + , meta Force)) + , ("Expand", ( "" + , "" + , meta Expand)) + , ("Cleanup", ( "Make trivial simplification to the formula" + , "Simplify things like '1 * x' to 'x'." + , meta Cleanup)) + , ("Sort", ( "" + , "" + , meta Sort)) + ] + +unaryFunctions :: [(String, (DocString, LongDescr, FormulaPrim -> FormulaPrim))] +unaryFunctions = + [ ("ceil", ( "" + , "" + , unOp OpCeil)) + , ("floor", ( "" + , "" + , unOp OpFloor)) + , ("frac", ( "" + , "" + , unOp OpFrac)) + , ("sin", ( "" + , "" + , unOp OpSin)) + , ("sinh", ( "" + , "" + , unOp OpSinh)) + , ("asin", ( "" + , "" + , unOp OpASin)) + , ("asinh", ( "" + , "" + , unOp OpASinh)) + , ("cos", ( "" + , "" + , unOp OpCos)) + , ("cosh", ( "" + , "" + , unOp OpCosh)) + , ("acos", ( "" + , "" + , unOp OpACos)) + , ("acosh", ( "" + , "" + , unOp OpACosh)) + , ("tan", ( "" + , "" + , unOp OpTan)) + , ("tanh", ( "" + , "" + , unOp OpTanh)) + , ("atan", ( "" + , "" + , unOp OpATan)) + , ("atanh", ( "" + , "" + , unOp OpATanh)) + , ("abs", ( "" + , "" + , unOp OpAbs)) + , ("sqrt", ( "" + , "" + , unOp OpSqrt)) + , ("exp", ( "" + , "" + , unOp OpExp)) + , ("log", ( "" + , "" + , unOp OpLog)) + , ("ln", ( "" + , "" + , unOp OpLn)) + ] + +unaryTranslations :: Map.Map String (FormulaPrim -> FormulaPrim) +unaryTranslations = Map.fromList + [ (name, fun) | (name, (_,_,fun)) <- unaryFunctions ++ metaFunctionList ] + +entityTranslation :: Map.Map String FormulaPrim +entityTranslation = Map.fromList [(name, val) | (name, (_,_,val)) <- entityList] + +multiParametersFunction :: Map.Map String ([FormulaPrim] -> FormulaPrim) +multiParametersFunction = Map.fromList [(name, f) | (name, (_,_,_,f)) <- multiParamsFunctions] + +multiParamsFunctions :: [ ( String + , (DocString, LongDescr, [(DocString,LongDescr)], [FormulaPrim] -> FormulaPrim))] +multiParamsFunctions = + [ ("Lambda", ( "Create an anonymous function" + , "An anonymous function is a function with no name which can be passed as parameter." + , [ ("Argument", "Variable to be bound when the lambda is called") + , ("Body", "Expression to be evaluated after argument binding.\n" + ++"The body is not evaluated during it's definition.") + ] + , lambdaBuilder ) ) + , ("derivate", ( "Make a partial differentiation" + , "Differentiate an expression for a variable given in parameter." + , [ ("Expression", "Expression to be differentiated, no evaluation occur at binding, unless it is in Force()") + , ("Variable", "Variable on which to perform partial differentiation. No evaluation done unless in Force()") + ] + , derivateBuilder + )) + + , ("sum", ( "Perform a sum of an expression" + , "The sum bind a variable over a range and perform a sum. If the arguments below are not given, no calculation is performed." + , [ ("Initial value", "An expression in the form x = something, to declare the start of iteration.") + , ("End value", "An upper bound for iteration, must be a number for calculation to happen") + , ("Expression", "Expression to be summed, can contain the variable bound by initial value.") + ] + , sumBuilder)) + , ("product", ( "Perform a product of an expression" + , "The sum bind a variable over a range and perform a sum. If the arguments below are not given, no calculation is performed." + , [ ("Initial value", "An expression in the form x = something, to declare the start of iteration.") + , ("End value", "An upper bound for iteration, must be a number for calculation to happen") + , ("Expression", "Expression to be summed, can contain the variable bound by initial value.") + ] + , productBuilder )) + , ("integrate", ( "Describe an integral" + , "For the moment, no calculation is performed. Just used for the format command" + , [ ("Initial Value", "Lower bound of the integral.") + , ("End Value", "Upper bound of the integral.") + , ("Expression", "The expression to be integrated.") + , ("Variable", "The dx of the integral, where x is any variable.") + ] + , integrateBuilder)) + , ("matrix", ( "Create a matrix" + , "" + , [("width", "Number of columns") + ,("height", "Number of lines of the matrix") + ,("...", "All the values") + ] + , matrixBuilder )) + ] + +lambdaBuilder :: [FormulaPrim] -> FormulaPrim +lambdaBuilder [arg, body] = meta LambdaBuild $ lambda [([arg], body)] +lambdaBuilder lst = app (Variable "Lambda") lst + +derivateBuilder :: [FormulaPrim] -> FormulaPrim +derivateBuilder [what, var] = derivate what var +derivateBuilder lst = app (Variable "Derivate") lst + + +sumBuilder :: [FormulaPrim] -> FormulaPrim +sumBuilder [ini, end, what] = summ ini end what +sumBuilder [ini, what] = summ ini (Variable "") what +sumBuilder [what] = summ (Variable "") (Variable "") what +sumBuilder lst = app (Variable "sum") lst + +productBuilder :: [FormulaPrim] -> FormulaPrim +productBuilder [ini, end, what] = productt ini end what +productBuilder [ini, what] = productt ini (Variable "") what +productBuilder [what] = productt (Variable "") (Variable "") what +productBuilder lst = app (Variable "product") lst + +integrateBuilder :: [FormulaPrim] -> FormulaPrim +integrateBuilder [ini, end, what, dvar] = integrate ini end what dvar +integrateBuilder [ini, what, dvar] = integrate ini (Variable "") what dvar +integrateBuilder [what, dvar] = integrate (Variable "") (Variable "") what dvar +integrateBuilder lst = app (Variable "integrate") lst + +matrixBuilder :: [FormulaPrim] -> FormulaPrim +matrixBuilder (CInteger n: CInteger m: exps) + | fromEnum n * fromEnum m > length exps = error "The matrix has not enough expressions" + | fromEnum n * fromEnum m < length exps = error "The matrix has too much expressions" + | otherwise = matrix (fromEnum n) (fromEnum m) $ splitMatrix exps + where splitMatrix [] = [] + splitMatrix lst = + let (matrixLine, matrixRest) = genericSplitAt n lst + in matrixLine : splitMatrix matrixRest +matrixBuilder lst = app (Variable "matrix") lst + +multivarLinker :: String -> [FormulaPrim] -> FormulaPrim +multivarLinker v flst = + maybe (app (Variable v) $ linked) (\f -> f $ linked) + $ Map.lookup v multiParametersFunction + where linked = map link flst + +-- | Function associating variables to symbol. +link :: FormulaPrim -> FormulaPrim +link (App _ (Variable "block") [CInteger i1, CInteger i2, CInteger i3]) = + Block (fromEnum i1) (fromEnum i2) (fromEnum i3) + +-- Transformations for operators +link p@(Poly _ _) = p +link v@(Variable varName) = + fromMaybe v $ Map.lookup varName entityTranslation +link (App _ (Variable funName) [x]) = + maybe (multivarLinker funName [x]) (\f -> f $ linked) + $ Map.lookup funName unaryTranslations + where linked = link x + +link (App _ (Variable v) flst) = multivarLinker v flst + +-- General transformations +link (App _ f flst) = app (link f) $ map link flst +link (UnOp _ op f) = unOp op $ link f +link (BinOp _ op fs) = binOp op $ map link fs +link (Meta _ m fs) = meta m $ link fs +link a@(CFloat _) = a +link a@(CInteger _) = a +link a@(NumEntity _) = a +link a@(Block _ _ _) = a +link t@(Truth _) = t +link f@(Fraction _) = f +link (Complex _ (r,i)) = complex (link r, link i) +link (Lambda _ l) = lambda [ (map link fl, link f) | (fl, f) <- l] +link (Matrix _ n m ll) = matrix n m [map link rows | rows <- ll] +link (Derivate _ a b) = derivate (link a) (link b) +link (Sum _ a b c) = summ (link a) (link b) (link c) +link (Product _ a b c) = productt (link a) (link b) (link c) +link (Integrate _ a b c d) = integrate (link a) (link b) (link c) (link d) +link (Indexes _ main lst) = indexes (link main) $ map link lst +link (List _ lst) = list $ map link lst + diff --git a/EqManips/Polynome.hs b/EqManips/Polynome.hs new file mode 100644 --- /dev/null +++ b/EqManips/Polynome.hs @@ -0,0 +1,592 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Rank2Types #-} +module EqManips.Polynome( convertToPolynome + , convertToFormula + , polynomizeFormula + , polyMap + , polyCoeffMap + , scalarToCoeff + , coefToFormula + , isCoeffNull + , prepareFormula + , syntheticDiv + , polyAsFormula + + -- | Pack/simplify polynome with only one coefficient + -- and/or null coef. + , simplifyPolynome + ) where +import Data.Maybe( fromMaybe ) +import Data.Ord( comparing ) +import Control.Applicative( (<$>), (<*>) ) +import Control.Arrow( (***), second ) +import Control.Monad( join ) +import Data.Either( partitionEithers ) +import Data.List( sortBy, groupBy, foldl' ) +import Data.Ratio + +import EqManips.Types +import EqManips.Algorithm.Utils +import EqManips.FormulaIterator +import qualified EqManips.ErrorMessages as Err + +-- | will pack/simplify internal representation of a polynome. +-- If there is only one null coefficient only subPoly will be present +simplifyPolynome :: Polynome -> Polynome +simplifyPolynome (Polynome v p@[(lastCoeff, PolyRest constant)]) + | isCoeffNull lastCoeff = PolyRest constant + | otherwise = Polynome v p +simplifyPolynome (Polynome v p@[(lastCoeff, subPoly)]) + | isCoeffNull lastCoeff = subPoly + | otherwise = Polynome v p +simplifyPolynome a = a + +polyAsFormula :: Polynome -> FormulaPrim +polyAsFormula (PolyRest coeff) = coefToFormula coeff +polyAsFormula (Polynome _ [(0, a)]) = polyAsFormula a +polyAsFormula p = poly p + +-- | Given a formula, it'll try to convert it to a polynome. +-- Formula should be expanded and in list form to get this +-- function to work (nested shit shouldn't work) +convertToPolynome :: Formula ListForm -> Maybe Polynome +convertToPolynome (Formula f) = polynomize + $ prepareFormula f + +convertToFormula :: Polynome -> Formula ListForm +convertToFormula = Formula . convertToFormulaPrim + +-- | Run across the whole formula and replace what +-- can polynomized by a polynome +polynomizeFormula :: Formula ListForm -> Formula ListForm +polynomizeFormula (Formula f) = Formula $ topDownTraversal converter f + where converter f' = poly <$> convertToPolynome (Formula f') + +-- | Convert a polynome into a simpler formula using only +-- basic operators. +convertToFormulaPrim :: Polynome -> FormulaPrim +convertToFormulaPrim (PolyRest coeff) = coefToFormula coeff +convertToFormulaPrim (Polynome var lst) = + foldl' constructor realFirst rest + where constructor a (Left b) = a + b + constructor a (Right b) = a - b + + realFirst = either id id felem + (felem : rest) = map elemConverter lst + + fvar = Variable var + elemConverter (degree,def) = + degreeOf (convertToFormulaPrim def) + (coefToFormula degree) + + degreeOf fdef (CInteger 0) + | isConstantNegative fdef = Right $ negateConstant fdef + | otherwise = Left $ fdef + + degreeOf (CInteger 1 ) (CInteger 1) = Left fvar + degreeOf (CInteger (-1)) (CInteger 1) = Right fvar + degreeOf fdef (CInteger 1) + | isConstantNegative fdef = Right $ negateConstant fdef * fvar + | otherwise = Left $ fdef * fvar + + degreeOf (CInteger 1) deg = Left $ fvar ** deg + degreeOf (CInteger (-1)) deg = Right $ fvar ** deg + + degreeOf fdef deg + | isConstantNegative fdef = + Right $ negateConstant fdef * (fvar ** deg) + | otherwise = Left $ fdef * (fvar ** deg) + +-- | Conversion from coef to basic formula. ratio +-- are converted to (a/b), like a division. +coefToFormula :: PolyCoeff -> FormulaPrim +coefToFormula (CoeffFloat f) = CFloat f +coefToFormula (CoeffInt i) = CInteger i +coefToFormula (CoeffRatio r) = if denominator r == 1 + then CInteger $ numerator r + else Fraction r + +-- | Flatten the formula, remove all the OpSub and replace them +-- by OpAdd. Also bring lowest variables to the front, regardless of +-- their order. Ordering is very important in this function. All +-- the polynome construction is built uppon the ordering created here. +prepareFormula :: FormulaPrim -> FormulaPrim +prepareFormula = polySort . formulaFlatter + +polySort :: FormulaPrim -> FormulaPrim +polySort = depthFormulaPrimTraversal `asAMonad` sortBinOp sorter + where lexicalOrder EQ b = b + lexicalOrder a _ = a + + invert LT = GT + invert EQ = EQ + invert GT = LT + + -- Special sort which bring x in front, followed by others. Lexical + -- order first. + + sorter (Poly _ p1) (Poly _ p2) = compare p1 p2 + sorter (Poly _ _) _ = LT + sorter _ (Poly _ _) = GT + + -- Rules to fine-sort '*' elements + -- (x before y), no regard for formula degree + sorter (Variable v1) (Variable v2) = compare v1 v2 + + -- x ^ n * y ^ n (n can be one, not shown) + sorter (BinOp _ OpPow [Variable v1, p1]) + (BinOp _ OpPow [Variable v2, p2]) = + compare v1 v2 `lexicalOrder` compare p1 p2 + + -- x * y ^ n + sorter (Variable v1) + (BinOp _ OpPow (Variable v2:_)) = + compare v1 v2 `lexicalOrder` LT + + -- x ^ n * y + sorter (BinOp _ OpPow (Variable v1:_)) + (Variable v2) = compare v1 v2 `lexicalOrder` GT + + -- (x * ...) + y ^ n + sorter (BinOp _ OpMul (Variable v1:_)) + (BinOp _ OpPow [Variable v2, _]) = compare v1 v2 `lexicalOrder` LT + + -- x ^ n + (y * ...) + sorter (BinOp _ OpPow [Variable v1, _]) + (BinOp _ OpMul (Variable v2:_)) = compare v1 v2 `lexicalOrder` GT + + -- (x ^ m * ...) + y ^ n + sorter (BinOp _ OpMul (BinOp _ OpPow [Variable v1,p1]:_)) + (BinOp _ OpPow [Variable v2, p2]) = + compare v1 v2 `lexicalOrder` compare p1 p2 + + -- x ^ n + (y ^ m * ...) + sorter (BinOp _ OpPow [Variable v1, p1]) + (BinOp _ OpMul (BinOp _ OpPow [Variable v2,p2]:_)) = + compare v1 v2 `lexicalOrder` compare p1 p2 + + -- Rules to fine sort the '+' elements, lowest variable + -- first (x before y), smallest order first (x before x ^ 15) + + -- (x^n * ....) + (y^n * ...) + sorter (BinOp _ OpMul (BinOp _ OpPow (Variable v1: power1):_)) + (BinOp _ OpMul (BinOp _ OpPow (Variable v2: power2):_)) = + compare v1 v2 `lexicalOrder` compare power1 power2 + + -- (x * ...) + (y^n * ...) + sorter (BinOp _ OpMul (Variable v1:_)) + (BinOp _ OpMul (BinOp _ OpPow (Variable v2:_):_)) = + compare v1 v2 `lexicalOrder` LT + + -- (x^n * ...) + (y * ...) + sorter (BinOp _ OpMul (BinOp _ OpPow (Variable v1:_):_)) + (BinOp _ OpMul (Variable v2:_)) = compare v1 v2 `lexicalOrder` GT + + -- (x * ...) + (y * ...) + sorter (BinOp _ OpMul (Variable v1:_)) + (BinOp _ OpMul (Variable v2:_)) = compare v1 v2 + + -- x + (y * ...) + sorter (Variable v1) + (BinOp _ OpMul (Variable v2:_)) = compare v1 v2 + + -- (x * ...) + y + sorter (BinOp _ OpMul (Variable v1:_)) + (Variable v2) = compare v1 v2 + + sorter (BinOp _ OpPow a) (BinOp _ OpPow b) = + case comparing length a b of + LT -> LT + GT -> GT + EQ -> foldl' (\acc (a', b') -> if acc == EQ + then acc + else compare a' b') EQ $ zip a b + -- x ^ n * ? + sorter _ (BinOp _ OpPow (Variable _:_)) = GT + sorter (BinOp _ OpPow (Variable _:_)) _ = LT + + -- make sure weird things go at the end. + sorter (Variable _) _ = LT + sorter _ (Variable _) = GT + + -- Just reverse the general readable order. + sorter a b = invert $ compare a b + +-- | Called when we found an OpSub operator within the +-- formula. -- We assume that the formula as been previously sorted +resign :: FormulaPrim -> [FormulaPrim] -> [FormulaPrim] +resign = globalResign + where globalResign (BinOp _ OpMul (a:xs)) acc + | isFormulaInteger a = case atomicResign a of + Nothing -> binOp OpMul (CInteger (-1):a:xs) : acc + Just a' -> binOp OpMul (a':xs) : acc + globalResign (BinOp _ OpAdd lst) acc = foldr resign acc lst + globalResign a acc = fromMaybe (CInteger (-1) * a) (atomicResign a) : acc + + atomicResign (CInteger i) = Just $ CInteger (-i) + atomicResign (CFloat i) = Just $ CFloat (-i) + atomicResign (UnOp _ OpNegate a) = Just a + atomicResign (BinOp _ OpDiv [a,b]) = (\a' -> binOp OpDiv [a', b]) <$> atomicResign a + atomicResign _ = Nothing + +-- | Flatten a whole formula, by flattening from the leafs. +formulaFlatter :: FormulaPrim -> FormulaPrim +formulaFlatter = depthFormulaPrimTraversal `asAMonad` listFlatter + +-- | Given a formula in LIST form, provide a version +-- with only Pluses. +listFlatter :: FormulaPrim -> FormulaPrim +listFlatter (BinOp _ OpAdd lst) = binOp OpAdd $ foldr flatter [] lst + where flatter (BinOp _ OpSub (x:xs)) acc = x : foldr resign acc xs + flatter (BinOp _ OpAdd lst') acc = lst' ++ acc + flatter x acc = x:acc +listFlatter (BinOp _ OpSub ((BinOp _ OpAdd lst'):xs)) = + binOp OpAdd $ lst' ++ foldr resign [] xs +listFlatter (BinOp _ OpSub (x:xs)) = + binOp OpAdd $ x : foldr resign [] xs + +-- Remove the maximum of negation in the multiplication. +-- In the end, keep the needed negation into the first term +listFlatter (BinOp _ OpMul lst) = if foldr countInversion False lst + then let (x:xs) = map cleanSign lst + in binOp OpMul $ resign x xs + else binOp OpMul $ map cleanSign lst + where iodd :: Int -> Bool + iodd = odd + countInversion whole@(UnOp _ OpNegate _) acc = + if iodd . fst $ getUnsignedRoot 0 whole + then not acc + else acc + countInversion _ acc = acc + + getUnsignedRoot n (UnOp _ OpNegate something) = getUnsignedRoot (n+1) something + getUnsignedRoot n (something) = (n :: Int, something) + + cleanSign whole@(UnOp _ OpNegate _) = snd $ getUnsignedRoot 0 whole + cleanSign a = a + +listFlatter a = a + +-- | Verify if the coefficient is valid in the context +-- of polynomial. might add a reduction rule here. +evalCoeff :: [FormulaPrim] -> Maybe PolyCoeff +evalCoeff [CInteger i] = Just $ CoeffInt i +evalCoeff [CFloat f] = Just $ CoeffFloat f +evalCoeff [UnOp _ OpNegate (CInteger i)] = Just $ CoeffInt (-i) +evalCoeff [UnOp _ OpNegate (CFloat f)] = Just $ CoeffFloat (-f) +evalCoeff [BinOp _ OpDiv [CInteger a, CInteger b]] = Just . CoeffRatio $ a % b +evalCoeff [UnOp _ OpNegate (BinOp _ OpDiv [CInteger a, CInteger b])] = Just . CoeffRatio $ (-a) % b +evalCoeff _ = Nothing + +-- | Given a rest (a leading +c, where c is a constant) and +-- a group of variable and coefficients, try to build a full +-- blown polynomial out of it. +translator :: [FormulaPrim] -- Unnammed rest (var ^ 0) + -> [(String, [(FormulaPrim, FormulaPrim)])] -- Named things x ^ n or y ^ n, n > 0 + -> Maybe (Maybe Polynome) -- ^ First maybe: error, nested maybe: empty +translator [] [(var, coefs)] = do + result <- mapM (\(rank, polyn) -> (,) <$> evalCoeff [rank] <*> polynomize polyn) coefs + return . Just $ Polynome var result + +translator pow0 [(var, coefs)] = do + result <- mapM (\(rank,polyn) -> (,) <$> evalCoeff [rank] <*> polynomize polyn) coefs + rest <- evalCoeff pow0 + return . Just . Polynome var $ (CoeffInt 0, PolyRest rest):result + +translator pow0 ((var,coefs):rest) = do + result <- mapM (\ (rank,polyn) -> (,) <$> evalCoeff [rank] <*> polynomize polyn) coefs + subPolynome <- translator pow0 rest + let finalList = case subPolynome of + Nothing -> result + Just p -> (CoeffInt 0, p) : result + return . Just $ Polynome var finalList + +translator pow0 [] = return $ PolyRest <$> evalCoeff pow0 + +-- | Try to transform a formula in polynome. +polynomize :: FormulaPrim -> Maybe Polynome +polynomize wholeFormula@(BinOp _ OpMul _) = polynomize (binOp OpAdd [wholeFormula]) +-- HMmm? +polynomize (BinOp _ OpAdd lst) = join -- flatten a maybe level, we don't distingate + . translator pow0 -- cases at the upper level. + . packCoefs + $ varGroup polys + where (polys, pow0) = partitionEithers $ map extractFirstTerm lst + varGroup = groupBy (\(var,_,_) (var',_,_) -> var == var') + coeffGroup = groupBy (\(_,coeff1,_) (_,coeff2,_) -> coeff1 == coeff2) + + packCoefs :: [[(String,FormulaPrim,FormulaPrim)]] -> [(String, [(FormulaPrim,FormulaPrim)])] + packCoefs varGrouped = map grouper varGrouped + where nameOfGroup ((varName, _,_):_) = varName + nameOfGroup [] = error Err.polynom_emptyCoeffPack + + grouper :: [(String,FormulaPrim,FormulaPrim)] -> (String, [(FormulaPrim,FormulaPrim)]) + grouper lst' = (nameOfGroup lst' + , [(coef group, polySort $ binOp OpAdd $ defs group) + | group <- coeffGroup lst']) + defs = map (\(_,_,def) -> def) + coef ((_,c1,_):_) = c1 + coef [] = error Err.polynom_emptyCoeffPack + +polynomize (BinOp _ OpPow [Variable v, CInteger c]) = + Just $ Polynome v [(CoeffInt c, PolyRest 1)] +polynomize _ = Nothing + +-- | Function in charge of extracting variable name (if any), and +-- return the coeff function. +extractFirstTerm :: FormulaPrim + -> Either (String, FormulaPrim, FormulaPrim) FormulaPrim +extractFirstTerm fullFormula@(BinOp _ OpMul lst) = varCoef lst + where varCoef ((BinOp _ OpPow [(Variable v), f]):xs) + | isFormulaConstant f = Left (v, f, multify xs) + varCoef ((Variable v):xs) = Left (v, CInteger 1, multify xs) + varCoef _ = Right fullFormula + + multify [] = error $ Err.empty_binop "Polynome.OpMul" + multify [x] = x + multify alist = binOp OpMul alist + +extractFirstTerm (BinOp _ OpPow [Variable v, order]) + | isFormulaConstant order = Left (v, order, CInteger 1) + +extractFirstTerm (Variable v) = Left (v, CInteger 1, CInteger 1) + +extractFirstTerm a = Right a + +-------------------------------------------------- +---- Polynome instances +-------------------------------------------------- + +-- | Only to map on the polynome coefficients (not the degree +-- of it). +polyCoeffMap :: (PolyCoeff -> PolyCoeff) -> Polynome -> Polynome +polyCoeffMap f = polyMap mapper + where mapper (deg, PolyRest c) = (deg, PolyRest $ f c) + mapper otherCoeff = otherCoeff + +-- | polynome mapping +polyMap :: ((PolyCoeff, Polynome) -> (PolyCoeff, Polynome)) -> Polynome -> Polynome +polyMap f (Polynome s lst) = Polynome s $ map (second $ polyMap f) lst +polyMap f rest@(PolyRest _) = snd $ f (CoeffInt 0, rest) + +-- | Transform a scalar formula component to +-- a polynome coefficient. If formula is not +-- a scalar, error is called. +scalarToCoeff :: FormulaPrim -> PolyCoeff +scalarToCoeff (UnOp _ OpNegate f) = negate $ scalarToCoeff f +scalarToCoeff (CFloat f) = CoeffFloat f +scalarToCoeff (CInteger i) = CoeffInt i +scalarToCoeff (BinOp _ OpDiv [CInteger a, CInteger b]) = CoeffRatio $ a % b +scalarToCoeff _ = error Err.polynom_coeff_notascalar + +-- | Operation on polynome coefficients. Put there +-- to provide automatic Equality derivation for polynome +-- and in the end... Formula +coeffOp :: (forall a. (Num a) => a -> a -> a) + -> PolyCoeff -> PolyCoeff -> PolyCoeff +coeffOp op c1 c2 = eval $ polyCoeffCast c1 c2 + where eval (CoeffInt i1, CoeffInt i2) = CoeffInt $ i1 `op` i2 + eval (CoeffFloat f1, CoeffFloat f2) = CoeffFloat $ f1 `op` f2 + eval (CoeffRatio r1, CoeffRatio r2) = CoeffRatio $ r1 `op` r2 + eval _ = error Err.polynom_bad_casting + +inf :: PolyCoeff -> PolyCoeff -> Bool +inf = coeffPredicate ((<) :: forall a. (Ord a) => a -> a -> Bool) + +-- | Implement the same idea that the one used by the +-- mergesort, only this time it's only used to perform +-- addition or substraction on polynomial. +lockStep :: (Polynome -> Polynome -> Polynome) + -> [(PolyCoeff, Polynome)] -> [(PolyCoeff, Polynome)] + -> [(PolyCoeff, Polynome)] +lockStep op xs [] = map (\(c,v) -> (c, v `op` PolyRest 0)) xs +lockStep op [] ys = map (\(c,v) -> (c, PolyRest 0 `op` v)) ys +lockStep op whole1@((c1, def1):xs) whole2@((c2, def2):ys) + | c1 `inf` c2 = + (c1, def1 `op` PolyRest (CoeffInt 0)) : lockStep op xs whole2 + | c1 == c2 = + (c1, def1 `op` def2) : lockStep op xs ys + | otherwise = + (c2, PolyRest (CoeffInt 0) `op` def2) : lockStep op whole1 ys + +-- | Tell if a coefficient can be treated as Null +isCoeffNull :: PolyCoeff -> Bool +isCoeffNull (CoeffInt 0) = True +isCoeffNull (CoeffFloat 0.0) = True +isCoeffNull (CoeffRatio r) = numerator r == 0 +isCoeffNull _ = False + +coeffPropagator :: (forall a. (Num a) => a -> a -> a) -> (PolyCoeff, Polynome) -> (PolyCoeff, Polynome) +coeffPropagator op (degree, PolyRest a) = (degree, PolyRest $ coeffOp op (CoeffInt 0) a) +coeffPropagator op (degree, Polynome v lst) = (degree, Polynome v $ map (coeffPropagator op) lst) + + +polySimpleOp :: (forall a. (Num a) => a -> a -> a) -> Polynome -> Polynome -> Polynome +polySimpleOp _ (Polynome _ []) _ = error Err.ill_formed_polynomial +polySimpleOp _ _ (Polynome _ []) = error Err.ill_formed_polynomial + +polySimpleOp op (PolyRest c1) (PolyRest c2) = PolyRest $ coeffOp op c1 c2 + +polySimpleOp op left@(PolyRest c1) (Polynome v1 as@((coeff, def):xs)) + | isCoeffNull coeff = case def of + PolyRest a -> Polynome v1 $ (CoeffInt 0, PolyRest $ coeffOp op c1 a) : map (coeffPropagator op) xs + _ -> Polynome v1 $ (coeff,polySimpleOp op left def) : map (coeffPropagator op) xs + + | otherwise = + Polynome v1 $ (CoeffInt 0, PolyRest $ coeffOp op c1 (CoeffInt 0)) : map (coeffPropagator op) as + +polySimpleOp op (Polynome v1 as@((coeff, def):xs)) right@(PolyRest c1) + | isCoeffNull coeff = case def of + PolyRest a -> Polynome v1 $ (CoeffInt 0, PolyRest $ coeffOp op a c1) + : map (coeffPropagator $ flip op) xs + _ -> Polynome v1 $ (coeff,polySimpleOp op def right) + : map (coeffPropagator $ flip op) xs + | otherwise = + Polynome v1 $ (CoeffInt 0, PolyRest $ coeffOp op (CoeffInt 0) c1) + : as + +polySimpleOp op (Polynome v1 as@((c, d1):rest)) right@(Polynome v2 bs) + | v1 > v2 = polySimpleOp (flip op) (Polynome v2 bs) (Polynome v1 as) + | v1 == v2 = + let computedCoefs = lockStep op as bs + in if null computedCoefs then PolyRest 0 + else Polynome v1 computedCoefs + | isCoeffNull c = + Polynome v1 $ (c, polySimpleOp op d1 right) : map (coeffPropagator $ flip op) rest + + | otherwise = + Polynome v1 $ (CoeffInt 0, polySimpleOp op (PolyRest $ CoeffInt 0) right) + : map (coeffPropagator $ flip op) as + + +-- | Multiply two polynomials between them using the brute force +-- way, algorithm in O(n²) +polyMul :: Polynome -> Polynome -> Polynome +polyMul p@(Polynome _ _) (PolyRest c) = polyCoeffMap (* c) p +polyMul (PolyRest c) p@(Polynome _ _) = polyCoeffMap (c *) p +polyMul (PolyRest c) (PolyRest c2) = PolyRest $ coeffOp (*) c c2 +polyMul p1@(Polynome v1 _) p2@(Polynome v2 _) | v1 > v2 = polyMul p2 p1 +polyMul (Polynome v1 coefs1) p2@(Polynome v2 coefs2) + | v1 /= v2 {- v1 < v2 by previous line -} = + Polynome v1 $ map (\(order, c) -> (order, polyMul c p2)) coefs1 + | otherwise {- v1 == v2 -} = + Polynome v1 + {-. map (\lst@((o,_):_) -> (o, foldr1 (+) $ map snd lst))-} + . map (\lst@((o,_):_) -> (o, sum $ map snd lst)) + . groupBy (\(o1,_) (o2,_) -> o1 == o2) -- Regroup same order together + $ sortBy (\(c1,_) (c2,_) -> compare c1 c2) + [ (degree1 + degree2, c1 * c2) | (degree1, c1) <- coefs1, (degree2, c2) <- coefs2] + +-------------------------------------------------- +---- Division +-------------------------------------------------- +-- | Expand coefficients of an _UNIVARIATE_ polynomial +-- in an descending way, each integer power given a +-- coefficient (0 if none). +expandCoeff :: Polynome -> Maybe [PolyCoeff] +expandCoeff (PolyRest _) = error "" +expandCoeff (Polynome _ coefs) = snd <$> foldl' sparser (Just (-1, [])) coefs + where sparser (Just (lastNum, lst)) (CoeffInt n, PolyRest r) = + Just (fromInteger n, r : replicate (fromInteger n - lastNum - 1) (CoeffInt 0) + ++ lst) + sparser _ _ = Nothing + +-- | Tell if a polynomial has only one var +isPolyMonovariate :: Polynome -> Bool +isPolyMonovariate (PolyRest _) = False +isPolyMonovariate (Polynome _ coefs) = all isCoeff coefs + where isCoeff (_,PolyRest _) = True + isCoeff _ = False + +-- | Given a power descending list of coefficient, rearrange +-- them to make it normal polynomial +packCoeffs :: [PolyCoeff] -> [(PolyCoeff, Polynome)] +packCoeffs = reverse . snd . foldr packer (0, []) + where packer coeff (n, lst) + | isCoeffNull coeff = (n + 1, lst) + | otherwise = (n + 1, (CoeffInt n, PolyRest coeff) : lst) + +-- | Apply an operation on an head of a list given an other list. +-- return Nothing if first list finish after "applied" list. +headApply :: (a -> b -> a) -> [a] -> [b] -> Maybe [a] +headApply _ [] [] = Just [] +headApply _ rest [] = Just rest +headApply _ [] _ = Nothing +headApply f (x:xs) (y:ys) = (f x y :) <$> headApply f xs ys + +-- | Try to perform a polynomial synthetic division on +-- monovariate polynomial. +syntheticDiv :: Polynome -> Polynome -> (Maybe Polynome, Maybe Polynome) +syntheticDiv polyn@(Polynome var lst1) divisor@(Polynome var' lst2) + | var == var' + && isPolyMonovariate polyn && isPolyMonovariate divisor + && fst (last lst1) > fst (last lst2) = + + (finalize . packCoeffs . map (/ normalizingCoeff) + *** finalize . packCoeffs) + + . splitAt (length coefList + 1 - length divCoeff) + $ firstCoeff : syntheticInnerDiv divCoeff firstCoeff coefList + + where Just (firstCoeff: coefList) = expandCoeff polyn + Just (firstDivCoeff:divCoeff) = map negate <$> expandCoeff divisor + + normalizingCoeff = negate firstDivCoeff + + finalize [] = Nothing + finalize lst = Just $ Polynome var lst + + syntheticInnerDiv :: [PolyCoeff] + -> PolyCoeff -> [PolyCoeff] -> [PolyCoeff] + syntheticInnerDiv _ _ [] = [] + syntheticInnerDiv diviCoeff prevCoeff polyCoeff = + case endCoeffs of + Just [] -> error "syntheticDiv - empty rest, impossible" + Just (x:xs) -> x : syntheticInnerDiv diviCoeff x xs + Nothing -> polyCoeff + where normalizedCoeff = prevCoeff / normalizingCoeff + endCoeffs = headApply (+) polyCoeff + $ map (normalizedCoeff *) diviCoeff +syntheticDiv _ _ = (Nothing, Nothing) + +instance Num PolyCoeff where + fromInteger = CoeffInt + (+) = coeffOp (+) + (-) = coeffOp (-) + (*) = coeffOp (*) + + abs (CoeffInt i) = CoeffInt $ abs i + abs (CoeffFloat f) = CoeffFloat $ abs f + abs (CoeffRatio r) = CoeffRatio $ abs r + + signum (CoeffInt i) = CoeffInt $ signum i + signum (CoeffFloat f) = CoeffFloat $ signum f + signum (CoeffRatio r) = CoeffRatio $ signum r + +instance Fractional PolyCoeff where + a / b = case polyCoeffCast a b of + (CoeffInt i1, CoeffInt i2) -> if i1 `mod` i2 == 0 + then CoeffInt $ i1 `div` i2 + else CoeffRatio $ i1 % i2 + (CoeffFloat f1, CoeffFloat f2) -> CoeffFloat $ f1 / f2 + (CoeffRatio r1, CoeffRatio r2) -> CoeffRatio $ r1 / r2 + _ -> error Err.polynom_bad_casting + + recip (CoeffFloat f) = CoeffFloat $ recip f + recip (CoeffInt i) = CoeffRatio $ 1 % i + recip (CoeffRatio r) = if denominator r' == 1 + then CoeffInt $ numerator r' + else CoeffRatio r' + where r' = recip r + + fromRational = CoeffRatio + +instance Num Polynome where + (+) = polySimpleOp (+) + (-) = polySimpleOp (-) + (*) = polyMul + fromInteger = PolyRest . fromInteger + abs = error "Unimplemented-Abs" + signum = error "Unimplemented-signum" + diff --git a/EqManips/Polynome.hs-boot b/EqManips/Polynome.hs-boot new file mode 100644 --- /dev/null +++ b/EqManips/Polynome.hs-boot @@ -0,0 +1,8 @@ +module EqManips.Polynome where + +import {-# SOURCE #-} EqManips.Types + +convertToPolynome :: Formula ListForm -> Maybe Polynome +convertToFormula :: Polynome -> Formula ListForm +polyMap :: ((PolyCoeff, Polynome) -> (PolyCoeff, Polynome)) -> Polynome -> Polynome + diff --git a/EqManips/Preprocessor.hs b/EqManips/Preprocessor.hs new file mode 100644 --- /dev/null +++ b/EqManips/Preprocessor.hs @@ -0,0 +1,223 @@ +module EqManips.Preprocessor ( processFile + , LangDef( .. ) + , kindAssociation + ) where + +import System.FilePath +import Data.List +import Control.Applicative +import Text.Parsec.Error( ParseError ) + +import EqManips.Algorithm.Eval +import EqManips.Algorithm.Utils +import EqManips.InputParser.EqCode +import EqManips.Renderer.Ascii +import EqManips.Renderer.Cpp +import EqManips.EvaluationContext +import EqManips.Types +import EqManips.Renderer.RenderConf + +data LangDef = LangDef { + initComm :: String + , languageName :: String + , endLineComm :: String + , formater :: Formula TreeForm -> [String] + } + + +voidLang :: LangDef +voidLang = LangDef + { initComm = "" + , endLineComm = "" + , languageName = "" + , formater = formulaTextTable defaultRenderConf + } + +shellLang, cppLang, cLang, ocamlLang, haskellLang :: LangDef +cppLang = voidLang { initComm = "//" + , endLineComm = "" + , formater = (\f -> [convertToCpp f]) + , languageName = "C++ like" + } + +shellLang = voidLang { initComm = "#" + , endLineComm = "" + , languageName = "Shell like" + } + +cLang = voidLang { initComm = "/*", endLineComm = "*/" + , languageName = "C like"} + +haskellLang = voidLang { initComm = "--", endLineComm = "" + , languageName = "Haskell" + } + +ocamlLang = voidLang { initComm = "(*", endLineComm = "*)" + , languageName = "OCaml" } + +kindAssociation :: [(String, LangDef)] +kindAssociation = + [ (".c", cLang) + , ( ".C", cppLang) + , ( ".cc", cppLang) + , ( ".cpp", cppLang) + , ( ".h", cLang) + , ( ".hpp", cppLang) + , ( ".java", cppLang) + , ( ".cs", cppLang) + + , ( ".hs", haskellLang) + , ( ".lhs", haskellLang) + , ( ".ml", ocamlLang) + , ( ".mli", ocamlLang) + + , ( ".py", shellLang) + , ( ".rb", shellLang) + , ( ".sh", shellLang) + , ( ".ps1", shellLang) + ] + +beginResultMark, endResultMark :: String +beginResultMark = "<@<" +endResultMark = ">@>" + +------------------------------------------------------ +---- Choosing weapons for preprocessing +------------------------------------------------------ +processFile :: FilePath -> IO String +processFile inFile = + case langOfFileName inFile of + Nothing -> do print "Error unrecognized file type" + return "" + Just lang -> do + file <- readFile inFile + let rez = concat . obtainEqResult + . processLines lang $ lines file + return rez + +-- temp to avoid nasty warning +langOfFileName :: FilePath -> Maybe LangDef +langOfFileName name = lookup (takeExtension name) kindAssociation + +processLines :: LangDef -> [String] -> EqContext [String] +processLines lang lst = do + fileLines' <- fileLines + return . reverse . map (++ "\n") $ concat fileLines' + where initVal = (PState (begin lang) (pure []), pure []) + + updater ((PState f _), acc) l = (rez , neoList) + where rez = f l + (PState _ lst') = rez + neoList = do + a <- lst' + acc' <- acc + return $ a : acc' + + (_,fileLines) = foldl' updater initVal lst + +------------------------------------------------------ +---- Processing file's lines +------------------------------------------------------ +eatSpaces :: String -> (String, String) +eatSpaces = eat [] + where eat acc (' ':xs) = eat (' ':acc) xs + eat acc ('\t':xs) = eat ('\t':acc) xs + eat acc xs = (acc, xs) + +stripSuffix :: String -> String -> String +stripSuffix suffix text + | isSuffixOf suffix text = take (length text - length suffix) text + | otherwise = text + +removeBeginComment :: LangDef -> String -> Maybe (String, String) +removeBeginComment langDef line = do + let (iniSpace, restLine) = eatSpaces line + rest <- stripPrefix (initComm langDef) restLine + return ( iniSpace ++ initComm langDef + , stripSuffix (endLineComm langDef) rest) + +-- | Grab a word from a string, returning it and +-- the tail. +word :: String -> (String, String) +word = w [] + where w acc [] = (reverse acc, []) + w acc (' ':xs) = (reverse acc, xs) + w acc ('\t':xs) = (reverse acc, xs) + w acc (c:xs) = w (c:acc) xs + +data PreprocessState = PState (String -> PreprocessState) (EqContext [String]) + +begin :: LangDef -> String -> PreprocessState +begin lang line = + maybe (PState (begin lang) $ pure [line]) + (\(initSpace, line') -> rez initSpace . snd $ eatSpaces line') + $ removeBeginComment lang line + where rez initSpace ('E':'q':':':xs) = + let (command, rest) = word xs + in PState (gatherInput lang (initSpace, command, [rest])) $ pure [line] + rez _ _ = PState (begin lang) $ pure [line] + + +gatherInput :: LangDef -> (String, String, [String]) -> String -> PreprocessState +gatherInput lang info@(initSpace, command, eqInfo) line = + maybe (PState (begin lang) $ produce lang info >>= pure . (line:)) + markSearch + $ removeBeginComment lang line + where markSearch (_,line') = + maybe (PState (gatherInput lang (initSpace, command, eqInfo ++ [line'])) + $ pure [line]) + (const $ PState (skip lang info) $ pure []) + $ stripPrefix beginResultMark line' + +-- Prelude const :: a -> b -> a +-- Prelude maybe :: b -> (a -> b) -> Maybe a -> b +-- Data.List stripPrefix :: Eq a => [a] -> [a] -> Maybe [a] +skip :: LangDef -> (String, String, [String]) -> String -> PreprocessState +skip lang info line = + maybe (PState (skip lang info) (pure [])) + endSearch + $ removeBeginComment lang line + where endSearch (_,line') = + if stripPrefix endResultMark line' == Nothing + then PState (skip lang info) (pure []) + else PState (begin lang) $ produce lang info + +produce :: LangDef -> (String, String, [String]) -> EqContext [String] +produce lang (initSpace, command, eqData) = + return $ endLine : process command mayParsedFormla ++ [preLine] + where emark = endLineComm lang + preLine = initSpace ++ beginResultMark ++ emark + endLine = initSpace ++ endResultMark ++ emark + + mayParsedFormla = parseFormula $ concat eqData + + commentLine = initSpace ++ " " + commentEnd = ' ' : emark + + spaceCount acc ' ' = 1 + acc + spaceCount acc '\t' = 4 + acc + spaceCount acc _ = acc + + unCommentedLine = replicate (foldl' spaceCount 0 initSpace) ' ' + + process :: String -> Either ParseError (Formula ListForm) -> [String] + process _ (Left err) = map (commentLine++) . lines $ show err + process "format" (Right f) = printResult (treeIfyFormula f) + process "eval" (Right f) = + let rez = performTransformation $ reduce f + in case (errorList rez) of + [] -> reverse . map (unCommentedLine ++) + . formater lang + . treeIfyFormula + $ result rez + errs@(_:_) -> concat + [ (commentLine ++ txt ++ commentEnd) : printResult form + | (form, txt) <- errs ] + process _ (Right _) = ["Unknown command " ++ command] + + printResult = + reverse . map (\l -> commentLine ++ l ++ commentEnd) + . formulaTextTable defaultRenderConf + + + diff --git a/EqManips/Propreties.hs b/EqManips/Propreties.hs new file mode 100644 --- /dev/null +++ b/EqManips/Propreties.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +module EqManips.Propreties( Property( .. ) + , TypeInfo( .. ) + , obtainProp + ) where + +import Data.Maybe + +-- | Class to attach static propreties to a type +-- minimum definition : getProps +class (Eq propKey) => Property onType propKey propVal + | propKey -> propVal where + -- | To retrieve all the propreties + -- of the current item + getProps :: onType -> [(propKey, propVal)] + + -- | retrieve a propretie if it exists + getProp :: onType -> propKey -> Maybe propVal + getProp a what = lookup what $ getProps a + + -- | Tell if the element as the propreties + -- passed as parameters + hasProp :: onType -> propKey -> Bool + hasProp a p = case getProp a p of + Nothing -> False + Just _ -> True + +-- | Associate an unique meta information +-- to a type/value +class TypeInfo onType infoToken tokenType where + propOf :: onType -> infoToken -> tokenType + +obtainProp :: (Property a p c) => a -> p -> c +obtainProp a = fromJust . getProp a + diff --git a/EqManips/Renderer/Ascii.hs b/EqManips/Renderer/Ascii.hs new file mode 100644 --- /dev/null +++ b/EqManips/Renderer/Ascii.hs @@ -0,0 +1,656 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | Module in charge of rendering an equation in ASCII +-- provide sizing information and rendering +module EqManips.Renderer.Ascii( renderFormula + , formulaTextTable + , formatFormula ) where + +import Data.List( foldl' ) +import Data.Array.Unboxed +import Data.Maybe( fromMaybe ) +import Data.Ratio +import EqManips.Types +import EqManips.Renderer.Placer +import EqManips.Algorithm.Utils +import EqManips.Propreties +import EqManips.Polynome +import EqManips.Renderer.RenderConf + +import qualified EqManips.UnicodeSymbols as Unicode + +import CharArray +type Pos = (Int, Int) + +-- | Here is all the rules for sizing of equation for an ascii +-- rendering. It's a bit harch to look at, but you can look +-- at the test suite to decipher the more complex ones +asciiSizer :: Dimensioner +asciiSizer = Dimensioner + { unaryDim = \_ op (base, (w,h)) -> + let s OpNegate = (base, (w + 1, h)) + s OpFactorial = (base, (w + 1, h)) + s OpAbs = (base, (w + 2, h)) + s OpSqrt = if h == 1 + then (base + 1, (w + 2, h + 1)) + else (base + 1, (w + (h * 3) `div` 2, h + 1)) + + s OpExp = (h, (1 + w, 1 + h)) + s OpCeil = (base + 1, (2 + w, 1 + h)) + s OpFloor = (base, (2 + w, 1 + h)) + s OpFrac = (base, (2 + w, h)) + + s oper = (h `div` 2, (w + opLength + 2, h)) + where opLength = + case oper `getProp` OperatorText of + Just name -> length name + Nothing -> error "Unknown operator name" + in s op + + , varSize = sizeOfVar + , intSize = \_ i -> (0, (length $ show i,1)) + , truthSize = \_ v -> if v then (0, (length "true", 1)) + else (0, (length "false", 1)) + + , floatSize = \_ f -> (0, (length $ show f, 1)) + , addParens = \_ (w, h) -> (w + 2, h) + , remParens = \_ (w, h) -> (w - 2, h) + , divBar = \_ (_,(w1,h1)) (_,(w2,h2)) -> + (h1, (max w1 w2 + 2, h1 + h2 + 1)) + + , powSize = \_ (b,(w1,h1)) (_,(w2,h2)) -> + (b + h2, (w1 + w2, h1 + h2)) + + , binop = binopSize + , productSize = \_ (_, (iniw,inih)) (_, (endw,endh)) (_, (whatw,whath)) -> + let height = inih + endh + max 2 whath + sumW = maximum [iniw, endw, 3] + width = sumW + whatw + 1 + in (endh + 1 + whath `div` 2 , (width, height)) + + , sumSize = \_ (_, (iniw,inih)) (_, (endw,endh)) (_, (whatw,whath)) -> + let height = inih + endh + max 2 whath + 2 + sumW = maximum [iniw, endw, whath, 2] + width = sumW + whatw + 1 + in (endh + 1 + whath `div` 2 , (width, height)) + + , integralSize = \_ (_, (iniw,inih)) (_, (endw,endh)) (_, (whatw,whath)) + (_, (dvarw, dvarh))-> + let height = inih + endh + maximum [2, dvarh, whath] + 2 + sumW = maximum [iniw, endw, whath, 4] + width = sumW + whatw + 2 + dvarw + in (endh + 1 + whath `div` 2 , (width, height)) + + , matrixSize = \_ lst -> + let mHeight = sum [ h | (_,(_,h)) <- map head lst ] + + length lst + + 1 + firstLine = head lst + mWidth = length firstLine + sum [ w | (_,(w,_)) <- firstLine ] + in + (mHeight `div` 2, (mWidth + 3, mHeight)) + + , derivateSize = \_ (_,(we,he)) (_,(wv, hv)) -> + (he, (max we wv + 3, he + hv + 1)) + + , blockSize = \_ (i1,i2,i3) -> (i1, (i2,i3)) + , entitySize = sizeOfEntity + + , argSize = \_ (wa, argBase, lower) (nodeBase, (w,h)) -> + (wa + w + 2, max argBase nodeBase, max lower (h-nodeBase)) + + , appSize = \_ (pw, argsBase, argsLeft) (_, (wf, hf)) -> + let finalY = max hf (argsBase + argsLeft) + in ((finalY - hf) `div` 2, (wf + pw, finalY)) + + , listSize = \_ (width, base, belowBase) -> + (base, (width + 2, max 1 $ base + belowBase)) + + , indexesSize = \_ (base, (width, height)) subTrees -> + let indexWidth = sum [ w + 1 | (_,(w,_)) <- subTrees ] + indexHeight = maximum [ h | (_,(_,h)) <- subTrees ] + in + (base, ( width + indexWidth + 2, height + indexHeight)) + + , indexPowerSize = \_conf (base, (width, height)) subTrees (_, (powerWidth, powerHeight)) -> + let indexWidth = sum [ w + 1 | (_,(w,_)) <- subTrees ] + indexHeight = maximum [ h | (_,(_,h)) <- subTrees ] + in + (base + powerHeight + , ( width + max indexWidth powerWidth + 2 + , height + powerHeight + indexHeight)) + + , lambdaSize = \_ poses -> + let clauseCount = length poses + mHeight = 2 + clauseCount + sum + [ max bodyH $ top + bottom | ((_, top, bottom), (_,(_,bodyH))) <- poses ] + mWidth = maximum + [ w + 4 {- " -> " -} + bodyW + | ((w, _, _), (_,(bodyW,_))) <- poses] + in + (mHeight `div` 2, (2 + mWidth, mHeight)) + } + + +-- We must handle case like this : +-- +-------+ +-- | |+-------+ +-- +-------|+-------+ +-- | || | +-- +-------+| | +-- +-------+ +binopSize :: Conf -> BinOperator -> RelativePlacement -> RelativePlacement + -> RelativePlacement +binopSize conf OpMul l@(bl,(w1,h1)) r@(br,(w2,h2)) + | not $ mulAsDot conf = binopSize conf OpAdd l r -- fall back to normal case + | otherwise = (max bl br, (w1 + w2 + 1, nodeSize)) + where nodeSize = base + max (h1 - bl) (h2 - br) + base = max bl br + +binopSize _ op (bl,(w1,h1)) (br,(w2,h2)) = (base, (w1 + w2 + 2 + oplength, nodeSize)) + where base = max bl br + oplength = length $ binopString op + nodeSize = base + max (h1 - bl) (h2 - br) + +sizeOfVar :: Conf -> String -> RelativePlacement +sizeOfVar conf s + | useUnicode conf && s `lookup` Unicode.varAssoc /= Nothing = (0, (1,1)) + | otherwise = (0, (length s, 1)) + +sizeOfEntity :: Conf -> Entity -> RelativePlacement +sizeOfEntity c = fst . textOfEntity c + +-- | Convert entity to text, not much entity for +-- the moment +textOfEntity :: Conf -> Entity -> ((Int,(Int,Int)), [String]) +textOfEntity conf Pi + | useUnicode conf = ((0,(1,1)), [[toEnum Unicode.pi]]) + | otherwise = ((0,(2,1)),["pi"]) +textOfEntity conf Infinite + | useUnicode conf = ((0,(1,1)), [[toEnum Unicode.infinity]]) + | otherwise = ((0,(length "infinite",1)), ["infinite"]) +textOfEntity _ Nabla = ((1,(2,1)), [" _ ","\\/"]) +textOfEntity _ Ellipsis = ((0,(3,1)), ["..."]) +{- + | useUnicode conf = ((0, (1,1)), [[toEnum Unicode.midlineDots ]]) + | otherwise + -} + + +-- | Convert a variable to it's possible unicode representation +textOfVariable :: Conf -> String -> String +textOfVariable conf var + | useUnicode conf = + fromMaybe var $ var `lookup` Unicode.varAssoc + | otherwise = var + +-- | Little helper for ready to parse string +formatFormula :: Conf -> Formula TreeForm -> String +formatFormula conf = unlines . formulaTextTable conf + +-- | The function to call to render a formula. +-- Return a list of lines containing the formula. +-- You can indent the lines do whatever you want with it. +formulaTextTable :: Conf -> Formula TreeForm -> [String] +formulaTextTable conf = linesOfArray . fst . renderFormula conf + +------------------------------------------------------------- +---- Rendering ---- +------------------------------------------------------------- +-- | This function return a char matrix containing the rendered +-- formula. This function might not stay public in the future... +renderFormula :: Conf -- ^ Rendering preferences + -> Formula TreeForm -- ^ Formula to render + -> (UArray (Int,Int) Char,SizeTree) -- ^ Rendered formula +renderFormula conf originalFormula@(Formula formula) = + (accumArray (flip const) ' ' size writeList, sizeTree) + where sizeTree = sizeTreeOfFormula conf asciiSizer originalFormula + size = ((0,0), sizeOfTree sizeTree) + writeList = renderF conf formula sizeTree (0,0) [] + +-- | Same idea as behind ShowS, to avoid heavy concatenation +-- use function composition instead which seem to be cheaper +type PoserS = [(Pos, Char)] -> [(Pos, Char)] + +{- else we try to render something like that : +-- @ +-- / \ +-- | | +-- | | +-- \ / +-- @ +-- Kept away from normal haddock comment, because it crash... +-} +-- | One function to render them all! (parenthesis) +-- for one line ( ... ) +renderParens :: Pos -> Dimension -> PoserS +renderParens (x,y) (w,1) = ([((x,y), '('), ((x + w - 1, y), ')')] ++) +renderParens (x,y) (w,h) = + ([((x , y ), '/' ), ((x , lastLine), '\\'), + ((rightCol, y ), '\\'), ((rightCol, lastLine), '/' )] ++) + . ( concat [ [ ((rightCol, height), '|') + , ((x , height), '|')] | height <- [y+1 .. lastLine - 1] ] ++) + where rightCol = x + w - 1 + lastLine = y + h - 1 + +-- | One function to render them all! +-- for one line ( ... ) +-- else we try to render something like that : +-- @ +-- |¯ ¯| +-- | | +-- | | +-- |_ _| +-- @ +renderSquareBracket :: Pos -> Dimension -> Bool -> Bool -> PoserS +renderSquareBracket (x,y) (w,1) True True = ([((x,y), '['), ((x + w - 1, y), ']')] ++) +renderSquareBracket (x,y) (w,h) top bottom = + (upper ++) . (downer ++) . (concat + [ [ ((rightCol, height), '|') + , ((x , height), '|')] | height <- [y .. lastLine]] ++) + where rightCol = x + w - 1 + lastLine = y + h - 1 + topSymbols s = [((x + 1 , y ), s), ((rightCol - 1, y ), s)] + bottomSymbols s = [((x + 1, lastLine), s), ((rightCol - 1, lastLine ), s)] + matrixTopSymbol = '¯' + upper = if top then topSymbols matrixTopSymbol + else [] + downer = if bottom then bottomSymbols '_' else [] + + +{- Just try to get that +-- @ +-- +-- / +-- | / / { { +-- | / { { +-- / \ \ +-- \ \ +-- | +-- | +-- \ +-- @ -} + +-- | Hope to render { and } for all sizes +renderBraces :: Pos -> Dimension -> Bool -> Bool -> PoserS +renderBraces (x,y) (w, 1) left right = leftChar . rightChar + where leftChar = if left then (:) ((x,y), '{') else id + rightChar = if right then (:) ((x + w - 1, y),'}') else id + +renderBraces (x,y) (w, 2) renderLeft renderRight = leftChar . rightChar + where leftChar = if renderLeft + then (++) [((x,y), '{'), ((x,y+1),'{')] + else id + right = x + w - 1 + rightChar = if renderRight + then (++) [((right, y),'}'), ((right, y+1), '}')] + else id + +renderBraces (x,y) (w, 3) renderLeft renderRight = leftChar . rightChar + where leftChar = if renderLeft + then (++) [((x,y), '/'), ((x,y+1),'{'), ((x,y+2),'\\')] + else id + right = x + w - 1 + rightChar = if renderRight + then (++) [((right, y),'\\'), ((right,y+1), '}'), ((right, y+2),'/')] + else id + +renderBraces (x,y) (w, h) renderLeft renderRight = leftChar . rightChar + where leftChar = if renderLeft then leftBrace else id + rightChar = if renderRight then rightBrace else id + top = (h - 4) `div` 2 + bottomLine = y + h - 1 + right = x + w - 1 + middle = y + top + 1 + leftBrace = (++) [ ((x,y),'/'), ((x, bottomLine),'\\') + , ((x, middle), '/'), ((x, middle + 1),'\\')] + . (++) [((x,i), '|')| i <- [y + 1 .. middle - 1]] + . (++) [((x,i), '|')| i <- [middle + 2 .. bottomLine - 1]] + rightBrace = (++) [ ((right,y),'\\'), ((right, bottomLine),'/') + , ((right, middle), '\\'), ((right, middle + 1),'/')] + . (++) [((right,i), '|')| i <- [y + 1 .. middle - 1]] + . (++) [((right,i), '|')| i <- [middle + 2 .. bottomLine - 1]] + +-- | Render a list of arguments, used by lambdas & functions +renderArgs :: Conf -- ^ How to render stuff + -> Bool -- ^ With parenthesis + -> Pos -- ^ Where to render the arguments + -> Int -- ^ The baseline for all the arguments + -> Int -- ^ Maximum height for all the arguments + -> [(FormulaPrim, SizeTree)] -- ^ Arguments to be rendered + -> (Int, PoserS) -- ^ Width & charList +renderArgs _ False (x,_) _ _ [] = (x, id) +renderArgs _ True (x,y) _ argsMaxHeight [] = + (x + 2, renderParens (x , y) (x + 2, argsMaxHeight)) + +renderArgs conf withParenthesis (x,y) argBase argsMaxHeight mixedList = + (xla + lastWidth + 2, + if withParenthesis + then fullArgs . renderParens (x , y) (xla + lastWidth + 2 - argBegin, argsMaxHeight) + else fullArgs) + + where argBegin = x + 1 + (params, (xla,_)) = foldl' write (id, (argBegin,y)) $ init mixedList + (lastNode, lastSize) = last mixedList + (lastBase, (lastWidth, _)) = sizeExtract lastSize + + fullArgs = params . renderF conf lastNode lastSize (xla, y + (argBase - lastBase)) + + write (acc, (x',y')) (node, size) = + ( commas . argWrite . acc , (x' + nodeWidth + 2, y') ) + where (nodeWidth, _) = sizeOfTree size + commas = (:) ((x' + nodeWidth, y + argBase), ',') + nodeBase = baseLineOfTree size + baseLine' = y' + (argBase - nodeBase) + argWrite = renderF conf node size (x', baseLine') + +-- | The real rendering function, return a list of position and char +-- to be used in accumArray function. +renderF :: Conf -- ^ Rendering preferences + -> FormulaPrim -- ^ CurrentNode + -> SizeTree -- ^ Previously calculated size + -> Pos -- ^ Where to render + -> PoserS -- ^ Result to be used in accumArray + +renderF conf (Fraction f) node pos = renderF conf ( CInteger (numerator f) + / CInteger (denominator f)) node pos +-- INVISIBLE META NINJA +renderF conf (Meta _ _ f) node pos = renderF conf f node pos +renderF conf (Complex _ c) node pos = + renderF conf (complexTranslate c) node pos +renderF conf (Poly _ p) node pos = + renderF conf translated node pos + where translated = unTagFormula + . treeIfyFormula + $ convertToFormula p + +-- In the following matches, we render parenthesis and +-- then recurse to the normal flow for the regular render. +renderF conf node (MonoSizeNode True (base, dim) st) (x,y) = + renderParens (x,y) dim . renderF conf node neoTree (x+1, y) + where subSize = remParens asciiSizer conf dim + neoTree = MonoSizeNode False (base, subSize) st +-- Parentheses for binop +renderF conf node (BiSizeNode True (base, dim) st1 st2) (x,y) = + renderParens (x,y) dim . renderF conf node neoTree (x+1, y) + where subSize = remParens asciiSizer conf dim + neoTree = BiSizeNode False (base, subSize) st1 st2 +-- Parenthesis for something else +renderF conf node (SizeNodeList True (base, dim) abase stl) (x,y) = + renderParens (x,y) dim . renderF conf node neoTree (x+1, y) + where subSize = remParens asciiSizer conf dim + neoTree = SizeNodeList False (base, subSize) abase stl + +-- Here we make the "simple" rendering, just a conversion. +renderF _ (Block _ w h) _ (x,y) = + (++) [ ((xw, yh), '#') | xw <- [x .. x + w - 1], yh <- [y .. y + h - 1]] +renderF _ (CInteger i) _ (x,y) = (++) . map (\(idx,a) -> ((idx,y), a)) $ zip [x..] (show i) +renderF _ (CFloat d) _ (x,y) = (++) . map (\(idx,a) -> ((idx,y), a)) $ zip [x..] (show d) + +renderF conf (Variable s) _ (x,y) = (++) . map (\(idx,a) -> ((idx,y), a)) . zip [x..] + $ textOfVariable conf s + +renderF conf (NumEntity e) _ (x,y) = (++) . concat $ + [ [((x + xi,y + yi),c) | (xi, c) <- zip [0..] elines] + | (yi, elines) <- zip [0..] $ snd $ textOfEntity conf e] +renderF _ (Truth True) _ (x,y) = (++) $ map (\(idx, a) -> ((idx,y), a)) $ zip [x..] "true" +renderF _ (Truth False) _ (x,y) = (++) $ map (\(idx, a) -> ((idx,y), a)) $ zip [x..] "false" +renderF _ (BinOp _ _ []) _ _ = error "renderF conf - rendering BinOp with no operand." +renderF _ (BinOp _ _ [_]) _ _ = error "renderF conf - rendering BinOp with only one operand." + +renderF conf (Indexes _ f1 f2) (SizeNodeList _ (_,(_,wholeHeight)) idBase (base:subs)) + (x,y) = baseRender . indexRender + where baseRender = renderF conf f1 base (x, y) + (_, indexRender) = renderArgs conf False (x + lw, y + lh) + idBase idHeight + $ zip f2 subs + + (lw, lh) = sizeOfTree base + idHeight = wholeHeight - lh + +renderF conf (BinOp _ OpPow [Indexes _ f1 f2, rest]) + (BiSizeNode False _ (SizeNodeList _ (_,(_,wholeHeight)) idBase (base:subs)) t2) + (x,y) = + baseRender . powRender . indexRender + where baseRender = renderF conf f1 base (x, y + rh) + powRender = renderF conf rest t2 (x + lw, y) + (_, indexRender) = renderArgs conf False (x + lw, y + rh + lh) + idBase idHeight + $ zip f2 subs + + (lw, lh) = sizeOfTree base + ( _, rh) = sizeOfTree t2 + idHeight = wholeHeight - lh + +renderF conf (BinOp _ OpPow [f1,f2]) (BiSizeNode False _ t1 t2) (x,y) = + leftRender . rightRender + where leftRender = renderF conf f1 t1 (x, y + rh) + rightRender = renderF conf f2 t2 (x + lw, y) + (lw, _) = sizeOfTree t1 + (_, rh) = sizeOfTree t2 + +-- Division is of another kind :] +renderF conf (BinOp _ OpDiv [f1,f2]) (BiSizeNode False (_,(w,_)) t1 t2) (x,y) = + (++) [ ((xi,y + lh), '-') | xi <- [x .. x + w - 1]] + . renderF conf f1 t1 (leftBegin , y) + . renderF conf f2 t2 (rightBegin, y + lh + 1) + where (lw, lh) = sizeOfTree t1 + (rw, _) = sizeOfTree t2 + leftBegin = x + (w - lw) `div` 2 + rightBegin = x + (w - rw) `div` 2 + +renderF conf (BinOp _ OpMul [f1,f2]) (BiSizeNode False (base,_) t1 t2) (x,y) = + leftRender . rightRender . (:) ((x + lw, y + base), mulChar) + where (lw, _) = sizeOfTree t1 + leftBase = baseLineOfTree t1 + rightBase = baseLineOfTree t2 + + (leftTop, rightTop) = + if leftBase > rightBase + then (y, y + leftBase - rightBase) + else (y + rightBase - leftBase, y) + + mulChar = case (mulAsDot conf, useUnicode conf) of + (True, True) -> toEnum Unicode.bullet + (True, False) -> '.' + (False, True) -> toEnum Unicode.multiplicationSign + (False, False) -> '*' + + leftRender = renderF conf f1 t1 (x, leftTop) + rightRender = renderF conf f2 t2 (x + lw + 1, rightTop) + +renderF conf (BinOp _ op [f1,f2]) (BiSizeNode False (base,_) t1 t2) (x,y) = + (++) [ ((i, y + base), c) | (i, c) <- zip [x + lw + 1 ..] opChar] + . leftRender . rightRender + where (lw, _) = sizeOfTree t1 + leftBase = baseLineOfTree t1 + rightBase = baseLineOfTree t2 + opChar = binopString op + + (leftTop, rightTop) = + if leftBase > rightBase + then (y, y + leftBase - rightBase) + else (y + rightBase - leftBase, y) + + leftRender = renderF conf f1 t1 (x, leftTop) + rightRender = renderF conf f2 t2 (x + lw + 2 + length opChar + , rightTop) + +renderF conf f@(BinOp _ _ _) node pos = renderF conf (treeIfyBinOp f) node pos + +renderF conf (UnOp _ OpSqrt f) (MonoSizeNode _ (_,(w,2)) s) (x,y) = + (++) [((x, y+1), '\\'), ((x + 1, y + 1), '/')] + . (++) [ ((i, y), '_') | i <- [x + 2 .. x + w - 1] ] + . renderF conf f s (x + 2, y + 1) + +renderF conf (UnOp _ OpSqrt f) (MonoSizeNode _ (_,(w,h)) s) (x,y) = + -- The sub formula + renderF conf f s (leftBegin, y + 1) + -- The top line + . (++) [ ((left,y), '_') | left <- [leftBegin .. x + w - 1] ] + -- big line from bottom to top + . (++) [ ((middleMark + i, y + h - i), '/') | i <- [1 .. h - 1] ] + -- Tiny line from middle to bottom + . (++) [ ((x + i, halfScreen + i), '\\') | i <- [0 .. midEnd]] + where (subW,_) = sizeOfTree s + leftBegin = x + w - subW + middleMark = leftBegin - h + halfScreen = y + h `div` 2 + 1 + midEnd = h `div` 2 - 2 + h `mod` 2 + +renderF conf (UnOp _ OpCeil f) (MonoSizeNode _ (_,(w,h)) s) (x,y) = + renderSquareBracket (x,y) (w,h) True False . renderF conf f s (x + 1,y + 1) + +renderF conf (UnOp _ OpFloor f) (MonoSizeNode _ (_,(w,h)) s) (x,y) = + renderSquareBracket (x,y) (w,h) False True . renderF conf f s (x + 1,y) + +renderF conf (UnOp _ OpFrac f) (MonoSizeNode _ (_,(w,h)) s) (x,y) = + renderBraces (x,y) (w,h) True True . renderF conf f s (x + 1,y) + +renderF conf (UnOp _ OpFactorial f) (MonoSizeNode _ (b,(w,_)) s) (x,y) = + (((x + w - 1, y + b), '!') :) . renderF conf f s (x,y) + +renderF conf (UnOp _ OpNegate f) (MonoSizeNode _ (b,_) s) (x,y) = + (((x,y + b), '-') :) . renderF conf f s (x + 1,y) + +renderF conf (UnOp _ OpExp f) (MonoSizeNode _ (_,(_,h)) s) (x,y) = + (((x, y + h - 1), 'e') :) . renderF conf f s (x + 1, y) + +renderF conf (UnOp _ OpAbs f) (MonoSizeNode _ (_,(w,h)) s) (x,y) = + (++) (concat [ [((x,height), '|'), ((x + w - 1, height), '|')] + | height <- [y .. y + h - 1] ]) + . renderF conf f s (x+1,y) + +renderF conf (UnOp _ op f) (MonoSizeNode _ nodeSize subSize) (x,y) = + renderF conf (app (Variable opName) [f]) + (SizeNodeList False nodeSize b + [EndNode(0,(length opName,1)) ,subSize]) + (x,y) + where (b,_) = sizeExtract subSize + opName = op `obtainProp` OperatorText + +renderF conf (List _ lst) (SizeNodeList False (_, (w, h)) argBase trees) pos@(x,y) = + snd (renderArgs conf False (x+1, y) argBase h sizes) . renderSquareBracket pos (w,h) True True + where sizes = zip lst trees + +renderF conf (App _ func flist) (SizeNodeList False (base, (_,h)) argBase (s:ts)) + (x,y) = + snd (renderArgs conf True (x + fw, y) argBase h mixedList) . renderF conf func s (x,baseLine) + where (fw, _) = sizeOfTree s + baseLine = y + base + mixedList = zip flist ts + +renderF conf (Lambda _ clauses) (SizeNodeClause _ (_,(w,h)) subTrees) (x,y) = + (fst . foldr renderClause (id, y + 1) . reverse $ zip clauses subTrees) + . renderBraces (x,y) (w,h) True True + where renderClause ((args, body), (argBase, trees, _bodyBase, bodyTree)) + (lst, top) = + let (left, rez) = renderArgs conf True (x + 1, top) argBase argsHeight + $ zip args trees + bodyText = renderF conf body bodyTree (left + 3, top) + (_, bodyHeight) = sizeOfTree bodyTree + argsHeight = maximum [ snd $ sizeOfTree tree | tree <- trees] + maxTop = max argsHeight bodyHeight + arrow = (++) [ ((left, top + argBase), '-') + , ((left + 1, top + argBase), '>') ] + in + (arrow . rez . bodyText . lst, maxTop + top + 1) + +renderF conf (Integrate _ ini end what var) + (SizeNodeList False + (_, (w,_h)) _ [iniSize,endSize,whatSize, derVarSize]) + (x,y) = + renderF conf end endSize (x + (integWidth - ew) `div` 2, y) + . renderF conf ini iniSize (max 0 $ x + (integWidth - iw) `div` 2 - 1, bottom + 1) + . renderF conf what whatSize (whatBegin + 1, whatTop) + . renderF conf var derVarSize (varBegin + 1, varTop) + + . (++) [ ((integPos, y + eh + 1), '/'), ((integPos + 1, y + eh), '_') + , ((integPos, bottom),'/'), ((integPos - 1, bottom),'_') + , ((varBegin, varTop + vh `div` 2), 'd')] + + . (++) [ ((integPos, i), '|') | i <- [y + eh + 2 .. bottom - 1] ] + where (ww, wh) = snd $ sizeExtract whatSize + (ew, eh) = snd $ sizeExtract endSize + (iw, _) = snd $ sizeExtract iniSize + (vw, vh) = snd $ sizeExtract derVarSize + + integPos = x + 1 + (integWidth - 4) `div` 2 + whatTop = y + eh + 1 + varTop = whatTop + (wh - vh) `div` 2 + + integWidth = w - 1 - ww - vw + varBegin = x + w - vw - 1 + whatBegin = varBegin - 2 - ww + bottom = y + eh + max 2 wh + +renderF conf (Product _ ini end what) + (SizeNodeList False + (_, (w,_h)) _ [iniSize,endSize,whatSize]) + (x,y) = + renderF conf end endSize (x + (sumWidth - ew) `div` 2, y) + . renderF conf ini iniSize (x + (sumWidth - iw) `div` 2, bottom + 1) + . renderF conf what whatSize (whatBegin + 1, y + eh + 1) + -- Top line + . (++) [ ((i, y + eh), '_') | i <- [x .. whatBegin - 1]] + -- Descending line + . (++) (concat [ [((x,i), '|'), ((whatBegin - 1,i), '|')] + | i <- [ y + eh + 1.. bottom] ]) + where (_, (ww, wh)) = sizeExtract whatSize + (_, (ew, eh)) = sizeExtract endSize + (_, (iw, _)) = sizeExtract iniSize + sumWidth = w - 1 - ww + whatBegin = x + w - 1 - ww + bottom = y + eh + max 2 wh + {-middleStop = wh `div` 2 + if wh `mod` 2 == 0-} + {-then -1 else 0-} + +renderF conf (Derivate _ what var) (BiSizeNode _ (_,(w,_)) whatSize vardSize) (x,y) = + (++) [((x, y + wh - 1), 'd'), ((x, y + wh + 1), 'd')] + . (++) [ ((i, y + wh), '-') | i <- [x .. x + w - 1] ] + . renderF conf what whatSize (x + 2, y) + . renderF conf var vardSize (x + 2, y + wh + 1) + where (_, (_, wh)) = sizeExtract whatSize + +renderF conf (Sum _ ini end what) + (SizeNodeList False + (_, (w,_h)) _ [iniSize,endSize,whatSize]) + (x,y) = + renderF conf end endSize (x + (sumWidth - ew) `div` 2, y) + . renderF conf ini iniSize (x + (sumWidth - iw) `div` 2, bottom + 1) + . renderF conf what whatSize (whatBegin + 1, y + eh + 1) + -- Top line + . (++) [ ((i, y + eh), '_') | i <- [x .. whatBegin - 1]] + -- Bottom line + . (++) [ ((i, bottom), '_') | i <- [x .. whatBegin - 1]] + -- Descending line + . (++) [ ((x + i, y + eh + 1 + i), '\\') | i <- [0 .. middleStop]] + -- Ascending line + . (++) [ ((x + i, bottom - i), '/') | i <- [0 .. middleStop]] + where (_, (ww, wh)) = sizeExtract whatSize + (_, (ew, eh)) = sizeExtract endSize + (_, (iw, _)) = sizeExtract iniSize + sumWidth = w - 1 - ww + whatBegin = x + w - 1 - ww + bottom = y + eh + max 2 wh + middleStop = wh `div` 2 + if wh `mod` 2 == 0 + then -1 else 0 + +renderF conf (Matrix _ _n _m subs) (SizeNodeArray _ (_base,(w,h)) lst) (x,y) = + renderSquareBracket (x,y) (w,h) True True . final + where renderLine (x', y', acc) (formu, ((base,(w',_)),size)) = + let (nodeBase, (nodeWidth, _)) = sizeExtract size + xStart = x' + (w' - nodeWidth) `div` 2 + yStart = y' + (base - nodeBase) + in + (x' + w' + 1, y', renderF conf formu size (xStart, yStart) . acc) + + renderMatrix (x', y', acc) (formulas, sizes) = + let ((_,(_,height)),_) = head sizes + (_,_, acc') = foldl' renderLine (x', y', acc) $ zip formulas sizes + in + (x', y' + height + 1, acc') + + (_,_, final) = foldl' renderMatrix (x + 2, y + 1, id) $ zip subs lst + +renderF _ _ _ _ = error "renderF conf - unmatched case" + diff --git a/EqManips/Renderer/Ascii.hs-boot b/EqManips/Renderer/Ascii.hs-boot new file mode 100644 --- /dev/null +++ b/EqManips/Renderer/Ascii.hs-boot @@ -0,0 +1,8 @@ +module EqManips.Renderer.Ascii where + +import EqManips.Types +import EqManips.Renderer.RenderConf + +formulaTextTable :: Conf -> Formula TreeForm -> [String] +formatFormula :: Conf -> Formula TreeForm -> String + diff --git a/EqManips/Renderer/CharRender.hs b/EqManips/Renderer/CharRender.hs new file mode 100644 --- /dev/null +++ b/EqManips/Renderer/CharRender.hs @@ -0,0 +1,219 @@ +module EqManips.Renderer.CharRender( CharacterSoup, CharacterSoupS + , renderFormula, renderFormulaS + ) where + +{-import Data.List( foldl' )-} +import EqManips.Types +import EqManips.Renderer.Placer +{-import EqManips.Algorithm.Utils-} +import EqManips.Propreties + +type PosX = Int +type PosY = Int +type Width = Int +type Height = Int +type CharacterSoup = [(PosX, PosY, Width, Height, Char)] +type CharacterSoupS = CharacterSoup -> CharacterSoup + +type Pos = (PosX, PosY) + +textOfEntity :: Entity -> ((Int,(Int,Int)), [String]) +textOfEntity Pi = ((0,(2,1)),["pi"]) +textOfEntity Infinite = ((0,(length "infinite",1)), ["infinite"]) +textOfEntity Nabla = ((1,(2,1)), [" _ ","\\/"]) + +-------------------------------------------------- +---- API +-------------------------------------------------- +renderFormula :: Formula TreeForm -> CharacterSoup +renderFormula f = renderFormulaS f [] + +renderFormulaS :: Formula TreeForm -> CharacterSoupS +renderFormulaS forig@(Formula f) = render f formulaSize (0,0) + where formulaSize = sizeTreeOfFormula charSizer forig + +-------------------------------------------------- +---- Constants +-------------------------------------------------- +baseCell :: Int +baseCell = 65536 + +parensWidth :: Int +parensWidth = baseCell `div` 4 + +opSpace :: Int +opSpace = baseCell `div` 6 + +divbarWidthAdd :: Int +divbarWidthAdd = baseCell `div` 10 + +commaSize :: Int +commaSize = baseCell + +-------------------------------------------------- +---- Implementation +-------------------------------------------------- +-- | Sizer for the real equation formatting. +-- Hardly readable, but get job done. +charSizer :: Dimensioner +charSizer = Dimensioner + { unaryDim = \op (base, (w,h)) -> + let s OpNegate = (base, (w + baseCell, h)) + s OpFactorial = (base, (w + baseCell, h)) + s OpAbs = (base, (w + 2 * baseCell, h)) + s OpSqrt = (base + 1, (w + (h * 3) `div` 2, h + 1)) + s OpExp = (h, (baseCell + w, baseCell + h)) + s OpCeil = (base + baseCell, (2 * baseCell+ w, baseCell + h)) + s OpFloor = (base, (2 * baseCell + w, baseCell + h)) + s OpFrac = (base, (2 * baseCell + w, h)) + + s oper = (h `div` 2, (w + opLength + 2 * baseCell, h)) + where opLength = + case oper `getProp` OperatorText of + Just name -> length name * baseCell + Nothing -> error "Unknown operator name" + in s op + + , varSize = \s -> (baseCell, (length s * baseCell, baseCell)) + , intSize = \i -> (baseCell, (length (show i) * baseCell, baseCell)) + , truthSize = \v -> if v then (baseCell, (baseCell * length "true", baseCell)) + else (baseCell, (baseCell * length "false", baseCell)) + + , floatSize = \f -> (baseCell, (length (show f) * baseCell, baseCell)) + + -------------------------------------------------- + ---- Parenthesis + -------------------------------------------------- + , addParens = \(w, h) -> (w + parensWidth * 2, h) + , remParens = \(w, h) -> (w - parensWidth * 2, h) + + , divBar = \(_,(w1,h1)) (_,(w2,h2)) -> + (h1, (max w1 w2 + 2 * divbarWidthAdd, h1 + h2 + 1)) + + , powSize = \(b,(w1,h1)) (_,(w2,h2)) -> + (b + h2, (w1 + w2, h1 + h2)) + + -- We must handle case like this : + -- +-------+ + -- | |+-------+ + -- +-------|+-------+ + -- | || | + -- +-------+| | + -- +-------+ + , binop = \op (bl,(w1,h1)) (br,(w2,h2)) -> + let base = max bl br + oplength = length $ binopString op + nodeSize = base + max (h1 - bl) (h2 - br) + in (base, (w1 + w2 + 2 * opSpace + oplength, nodeSize)) + + , productSize = \(_, (iniw,inih)) (_, (endw,endh)) (_, (whatw,whath)) -> + let height = inih + endh + max 2 whath + sumW = maximum [iniw, endw, 3] + width = sumW + whatw + 1 + in (endh + 1 + whath `div` 2 , (width, height)) + + , sumSize = \(_, (iniw,inih)) (_, (endw,endh)) (_, (whatw,whath)) -> + let height = inih + endh + max (2 * baseCell) whath + (2 * baseCell) + sumW = maximum [iniw, endw, whath, (2 * baseCell)] + width = sumW + whatw + baseCell + in (endh + baseCell + whath `div` (2 * baseCell), (width, height)) + + , integralSize = \(_, (iniw,inih)) (_, (endw,endh)) (_, (whatw,whath)) + (_, (dvarw, dvarh))-> + let height = inih + endh + maximum [2, dvarh, whath] + 2 + sumW = maximum [iniw, endw, whath, 4] + width = sumW + whatw + 2 + dvarw + in (endh + 1 + whath `div` 2 , (width, height)) + + , matrixSize = \lst -> + let mHeight = sum [ h | (_,(_,h)) <- map head lst ] + + length lst + + 1 + firstLine = head lst + mWidth = length firstLine + sum [ w | (_,(w,_)) <- firstLine ] + in + (mHeight `div` 2, (mWidth + 3, mHeight)) + + , derivateSize = \(_,(we,he)) (_,(wv, hv)) -> + (he, (max we wv + 3, he + hv + 1)) + + , blockSize = \(i1,i2,i3) -> (i1, (i2,i3)) + , entitySize = fst . textOfEntity + + , argSize = \(wa, argBase, lower) (nodeBase, (w,h)) -> + (wa + w + commaSize, max argBase nodeBase, max lower (h-nodeBase)) + + , appSize = \(pw, argsBase, argsLeft) (_, (wf, hf)) -> + let finalY = max hf (argsBase + argsLeft) + in ((finalY - hf) `div` 2, (wf + pw, finalY)) + + -- lambdaSize :: [((Int,Int,Int), RelativePlacement)] -> RelativePlacement + , lambdaSize = \poses -> + let clauseCount = length poses + mHeight = 2 + clauseCount + sum + [ max bodyH $ top + bottom | ((_, top, bottom), (_,(_,bodyH))) <- poses ] + mWidth = maximum + [ w + 4 {- " -> " -} + bodyW + | ((w, _, _), (_,(bodyW,_))) <- poses] + in + (mHeight `div` 2, (2 + mWidth, mHeight)) + } + +render :: FormulaPrim -> SizeTree -> Pos -> CharacterSoupS +render (Meta _ f) node pos = render f node pos + +-- In the following matches, we render parenthesis and +-- then recurse to the normal flow for the regular render. +{-render node (MonoSizeNode True (base, dim) st) (x,y) =-} +{--- Parentheses for binop-} +{-render node (BiSizeNode True (base, dim) st1 st2) (x,y) =-} +{--- Parenthesis for something else-} +{-render node (SizeNodeList True (base, dim) abase stl) (x,y) =-} + +{--- Here we make the "simple" rendering, just a conversion.-} +{-render (Block _ w h) _ (x,y) =-} +{-render (Variable s) _ (x,y) =-} +{-render (CInteger i) _ (x,y) =-} +{-render (CFloat d) _ (x,y) =-} +{-render (NumEntity e) _ (x,y) =-} + {-[ [((x + xi,y + yi),c) | (xi, c) <- zip [0..] elines]-} + -- \| (yi, elines) <- zip [0..] $ snd $ textOfEntity e] +{-render (Truth True) _ (x,y) =-} +{-render (Truth False) _ (x,y) =-} +{-render (BinOp _ []) _ _ = error "render - rendering BinOp with no operand."-} +{-render (BinOp _ [_]) _ _ = error "render - rendering BinOp with only one operand."-} + +{-render (BinOp OpPow [f1,f2]) (BiSizeNode False _ t1 t2) (x,y) =-} +{--- Division is of another kind :]-} +{-render (BinOp OpDiv [f1,f2]) (BiSizeNode False (_,(w,_)) t1 t2) (x,y) =-} +{-render (BinOp op [f1,f2]) (BiSizeNode False (base,_) t1 t2) (x,y) =-} +{-render f@(BinOp _ _) node pos = render (treeIfyBinOp f) node pos-} +{-render (UnOp OpSqrt f) (MonoSizeNode _ (_,(w,2)) s) (x,y) =-} +{-render (UnOp OpSqrt f) (MonoSizeNode _ (_,(w,h)) s) (x,y) =-} +{-render (UnOp OpCeil f) (MonoSizeNode _ (_,(w,h)) s) (x,y) =-} +{-render (UnOp OpFloor f) (MonoSizeNode _ (_,(w,h)) s) (x,y) =-} +{-render (UnOp OpFrac f) (MonoSizeNode _ (_,(w,h)) s) (x,y) =-} +{-render (UnOp OpFactorial f) (MonoSizeNode _ (b,(w,_)) s) (x,y) =-} +{-render (UnOp OpNegate f) (MonoSizeNode _ (b,_) s) (x,y) =-} +{-render (UnOp OpExp f) (MonoSizeNode _ (_,(_,h)) s) (x,y) =-} +{-render (UnOp OpAbs f) (MonoSizeNode _ (_,(w,h)) s) (x,y) =-} +{-render (UnOp op f) (MonoSizeNode _ nodeSize subSize) (x,y) =-} +{-render (App func flist) (SizeNodeList False (base, (_,h)) argBase (s:ts)) -} + {-(x,y) =-} +{-render (Lambda clauses) (SizeNodeClause _ (_,(w,h)) subTrees) (x,y) =-} +{-render (Integrate ini end what var)-} + {-(SizeNodeList False-} + {-(_, (w,_h)) _ [iniSize,endSize,whatSize, derVarSize])-} + {-(x,y) =-} +{-render (Product ini end what)-} + {-(SizeNodeList False-} + {-(_, (w,_h)) _ [iniSize,endSize,whatSize])-} + {-(x,y) =-} +{-render (Derivate what var) (BiSizeNode _ (_,(w,_)) whatSize vardSize) (x,y) =-} +{-render (Sum ini end what)-} + {-(SizeNodeList False-} + {-(_, (w,_h)) _ [iniSize,endSize,whatSize])-} + {-(x,y) =-} +{-render (Matrix _n _m subs) (SizeNodeArray _ (_base,(w,h)) lst) (x,y) =-} +render _ _ _ = error "render - unmatched case" + diff --git a/EqManips/Renderer/Cpp.hs b/EqManips/Renderer/Cpp.hs new file mode 100644 --- /dev/null +++ b/EqManips/Renderer/Cpp.hs @@ -0,0 +1,163 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module EqManips.Renderer.Cpp( convertToCpp, convertToCppS ) where + +import Control.Monad.State.Lazy +import Control.Applicative +import Data.Ratio + +import EqManips.Types +import EqManips.Polynome +import EqManips.Algorithm.Utils +import qualified EqManips.ErrorMessages as Err + +data CppConf = CppConf + { failures :: [String] + , nameCount :: Int + } + +type OutContext a = State CppConf a + +convertToCpp :: Formula TreeForm -> String +convertToCpp f = convertToCppS f "" + +convertToCppS :: Formula TreeForm -> ShowS +convertToCppS (Formula f) = fst $ runState (cNo f) defaultConf + +instance Applicative (State s) where + pure = return + (<*>) = ap + +defaultConf :: CppConf +defaultConf = + CppConf { failures = [] + , nameCount = 0 } + +stateUpdater :: (CppConf -> CppConf) -> OutContext () +stateUpdater f = do + context <- get + put $ f context + +genName :: OutContext Int +genName = do + ctxt <- get + let count = nameCount ctxt + put $ ctxt { nameCount = count + 1 } + return count + +outFail :: String -> OutContext ShowS +outFail text = stateUpdater conser >> return id + where conser ctxt = ctxt { failures = text : failures ctxt } + +str :: String -> ShowS +str = (++) + +char :: Char -> ShowS +char = (:) + +cNo :: FormulaPrim -> OutContext ShowS +cNo = cOut Nothing + +cppBinOps :: BinOperator -> ShowS +cppBinOps op = case lookup op localDef of + Just s -> str (' ' : s ++ " ") + Nothing -> str (' ' : binopString op ++ " ") + where localDef = [ (OpAnd, "&&"), (OpOr, "||") + , (OpEq, "=="), (OpNe, "!=") + , (OpAttrib, "=") + ] + +unOpEr :: UnOperator -> String +unOpEr OpNegate = "-" +unOpEr OpAbs = "abs" +unOpEr OpSqrt = "sqrt" +unOpEr OpLn = "log" +unOpEr OpLog = "log10" +unOpEr OpExp = "exp" +unOpEr OpSin = "sin" +unOpEr OpCos = "cos" +unOpEr OpTan = "tan" +unOpEr OpSinh = "sinh" +unOpEr OpCosh = "cosh" +unOpEr OpTanh = "tanh" +unOpEr OpASin = "asin" +unOpEr OpACos = "acos" +unOpEr OpATan = "atan" +unOpEr OpCeil = "ceil" +unOpEr OpFloor = "floor" +unOpEr OpFrac = "" +unOpEr OpFactorial = "" +unOpEr OpASinh = "" +unOpEr OpACosh = "" +unOpEr OpATanh = "" + +cOut :: Maybe (BinOperator, Bool) -> FormulaPrim -> OutContext ShowS +cOut ctxt (Poly _ p) = cOut ctxt (unTagFormula . treeIfyFormula $ convertToFormula p) +cOut _ (CInteger i) = return $ shows i +cOut _ (CFloat i) = return $ shows i +cOut _ (Variable v) = return $ str v +cOut _ (Truth True) = return $ str "true" +cOut _ (Truth False) = return $ str "false" +cOut _ (NumEntity Pi) = return $ str "M_PI" +cOut _ (NumEntity _) = return $ str "" +cOut _ (Indexes _ main lst) = + (.) <$> cOut Nothing main + <*> (concatS <$> sequence [ (\a -> ('[':) . a . (']':)) <$> cOut Nothing index | index <- lst]) + +cOut _ (Fraction f) = return $ char '(' . shows (numerator f) + . str " / " . shows (denominator f) + . char ')' +cOut _ (App _ func args) = + (\fun args' -> fun . char '(' . interspereseS (str ", ") args' . char ')') + <$> cNo func + <*> mapM cNo args + +cOut _ (UnOp _ op f) = + (\sub -> str (unOpEr op) . char '(' . sub . char ')') <$> cNo f + +cOut _ (BinOp _ OpAttrib [a,b]) = + (\left right -> left . str " = " . right . str ";\n") <$> cNo a <*> cNo b + +cOut _ (BinOp _ OpPow [a,b]) = + (\left right -> str "pow( " . left . str ", " . right . str " ) ") <$> cNo a <*> cNo b + +cOut Nothing (BinOp _ op [a,b]) = + (\left right -> left . cppBinOps op . right) <$> cOut (Just (op, False)) a + <*> cOut (Just (op, True)) b + +cOut (Just (parent, right)) f@(BinOp _ op _) + | needParenthesis right parent op = + (\sub -> char '(' . sub . char ')') <$> cNo f + | otherwise = cOut Nothing f + +cOut _ (BinOp _ _ []) = outFail $ Err.empty_binop "C output - " +cOut _ (BinOp _ _ [_]) = outFail $ Err.single_binop "C output - " +cOut _ (BinOp _ _ _) = outFail Err.c_out_bad_binop + +cOut st (Meta _ _ f) = cOut st f +cOut _ (Sum _ begin ende what) = iteration "+" begin ende what +cOut _ (Product _ begin ende what) = iteration "*" begin ende what + +cOut _ (Matrix _ _ _ _) = outFail Err.c_out_matrix +cOut _ (Derivate _ _ _) = outFail Err.c_out_derivate +cOut _ (Integrate _ _ _ _ _) = outFail Err.c_out_integrate +cOut _ (Lambda _ _) = outFail Err.c_out_lambda +cOut _ (Block _ _ _) = outFail Err.c_out_block +cOut _ (Complex _ _) = outFail Err.c_out_complex +cOut _ (List _ _) = outFail Err.c_out_list + +iteration :: String -> FormulaPrim -> FormulaPrim -> FormulaPrim -> OutContext ShowS +iteration op (BinOp _ OpEq [Variable v, iniExpr]) exprEnd what = do + tokenVar <- genName + let tmpVar = "temp_" ++ show tokenVar + initExpr <- cNo iniExpr + exprEnd' <- cNo exprEnd + whatExpr <- cNo what + return $ str "double " . str tmpVar . str ";\n" + . str "for ( int " . str v . str " = " . initExpr . str "; " + . str v . str " < " . exprEnd' . str "; " + . str " )\n" + . str "{\n" + . str tmpVar . char ' ' . str op . str "= " . whatExpr . str ";\n" + . str "}\n" +iteration _ _ _ _ = outFail Err.c_out_bad_iteration + diff --git a/EqManips/Renderer/EqCode.hs b/EqManips/Renderer/EqCode.hs new file mode 100644 --- /dev/null +++ b/EqManips/Renderer/EqCode.hs @@ -0,0 +1,130 @@ +module EqManips.Renderer.EqCode( unparse, unparseS ) where + +import Data.List( foldl' ) +import Data.Ratio + +import EqManips.Types +import EqManips.Propreties +import EqManips.Polynome( convertToFormula ) + +-- | Public function to translate a formula back to it's +-- original notation. NOTE : it's not used as a Show instance... +unparse :: FormulaPrim -> String +unparse f = unparseS f "" + +unparseS :: FormulaPrim -> ShowS +unparseS = deparse maxPrio False + +-- | used to render functions' arguments +argListToString :: [FormulaPrim] -> ShowS +argListToString [] = id +argListToString [f] = deparse maxPrio False f +argListToString lst = foldl' accum (unprint lastElem) reved + where unprint = deparse maxPrio False + accum acc f = unprint f . (',':) . acc + (lastElem:reved) = reverse lst + +-- | only to avoid a weird constant somewhere +maxPrio :: Int +maxPrio = 15 + +-- | Real conversion function, pass down priority +-- and tree direction +deparse :: Int -> Bool -> FormulaPrim -> ShowS +-- INVISIBLE META NINJA !! +deparse i r (Meta _ op f) = (++) (show op) . ('(' :) . deparse i r f . (')':) +deparse i r (Poly _ p) = deparse i r . unTagFormula $ convertToFormula p +deparse i r (Complex _ (real, imag)) = ('(':) + . deparse maxPrio r real + . (++) ") + i * (" + . deparse i r imag . (')':) +deparse _ _ (Truth True) = ("true" ++) +deparse _ _ (Truth False) = ("false" ++) +deparse _ _ (BinOp _ _ []) = + error "The formula is denormalized : a binary operator without any operands" +deparse _ _ (Variable s) = (s ++) +deparse _ _ (Lambda _ _) = id -- NINJA HIDDEN! +deparse _ _ (NumEntity e) = (en e ++) + where en Pi = "pi" + en Nabla = "nabla" + en Infinite = "infinite" + en Ellipsis = "..." +deparse _ _ (CInteger i) = shows i +deparse _ _ (CFloat d) = shows d +deparse _ _ (List _ l) = ('[':) . argListToString l . (']':) +deparse prio left (Indexes _ a b) = deparse prio left a . ("_("++) . argListToString b . (')':) + +deparse _ _ (Block i i1 i2) = + ("block(" ++) . shows i . (',':) . shows i1 . (',' :) . shows i2 . (')' :) + +deparse _ _ (App _ (Variable v) fl) = + (v ++) . ('(' :) . argListToString fl . (')' :) + +deparse _ _ (App _ f1 fl) = + ('(' :) . deparse maxPrio False f1 . (")(" ++) . argListToString fl . (')' :) + +deparse _ _ (Sum _ i i1 i2) = + ("sum(" ++) . argListToString [i, i1, i2] . (')':) + +deparse _ _ (Product _ i i1 i2) = + ("product(" ++) . argListToString [i, i1, i2] . (')':) + +deparse _ _ (Derivate _ i i1) = + ("derivate(" ++) . argListToString [i, i1] . (')':) + +deparse _ _ (Integrate _ i i1 i2 i3) = + ("integrate(" ++) . argListToString [i, i1, i2, i3] . (')':) + +deparse _ _ (UnOp _ OpFactorial f) = ('(':) . deparse maxPrio False f . (")!" ++) +deparse _ _ (UnOp _ op f) = + (++) (unopString op) . + ('(':) . deparse maxPrio False f . (')':) + +deparse _ _ (Fraction f) = + ('(':) . shows (numerator f) + . ('/':) + . shows (denominator f) + . (')':) + + -- Special case... as OpEq is right associative... + -- we must reverse shit for serialisation +deparse oldPrio right (BinOp _ OpEq [f1,f2]) = + let (prio, txt) = (OpEq `obtainProp` Priority, binopString OpEq) + in + if prio > oldPrio || (not right && prio == oldPrio) + then ('(':) + . deparse prio False f1 + . (' ' :) . (txt ++) . (' ':) + . deparse prio True f2 . (')':) + else deparse prio False f1 + . (' ' :) . (txt ++) . (' ':) + . deparse prio True f2 + +deparse oldPrio right (BinOp _ op [f1,f2]) = + let (prio, txt) = (op `obtainProp` Priority, binopString op) + in + if prio > oldPrio || (right && prio == oldPrio) + then ('(':) . deparse prio False f1 + . (' ' :) . (txt ++) . (' ':) + . deparse prio True f2 . (')':) + else deparse prio False f1 + . (' ' :) . (txt ++) . (' ':) + . deparse prio True f2 + +deparse oldPrio right (BinOp _ op (f1:xs)) = + let (prio, txt) = (op `obtainProp` Priority, binopString op) + in + if prio > oldPrio || (right && prio == oldPrio) + then ('(':) . deparse prio False f1 + . (' ':) . (txt ++) . (' ':) + . deparse prio False (binOp op xs) . (')':) + else deparse prio False f1 + . (' ' :) . (txt ++) . (' ':) + . deparse prio False (binOp op xs) + +deparse _ _ (Matrix _ n m fl) = + ("matrix("++) . shows n + . (',':) + . shows m + . (',':) . argListToString (concat fl) . (')':) + diff --git a/EqManips/Renderer/Latex.hs b/EqManips/Renderer/Latex.hs new file mode 100644 --- /dev/null +++ b/EqManips/Renderer/Latex.hs @@ -0,0 +1,152 @@ +module EqManips.Renderer.Latex ( latexRender, latexRenderS ) where + +import Data.Ratio + +import EqManips.Types +import EqManips.Polynome +import EqManips.Algorithm.Utils +import EqManips.Propreties + +import EqManips.Renderer.RenderConf + +latexRender :: Conf -> Formula TreeForm -> String +latexRender conf f = latexRenderS conf f "" + +latexRenderS :: Conf -> Formula TreeForm -> ShowS +latexRenderS conf(Formula f) = str "\\begin{equation*}\n" + . lno conf f + . str "\n\\end{equation*}\n" + +str :: String -> ShowS +str = (++) + +char :: Char -> ShowS +char = (:) + +latexOfEntity :: Entity -> String +latexOfEntity Pi = "\\pi " +latexOfEntity Nabla = "\\nabla " +latexOfEntity Infinite = "\\infty " +latexOfEntity Ellipsis = "\\cdots" + +stringOfUnOp :: UnOperator -> String +stringOfUnOp OpSin = "\\sin " +stringOfUnOp OpSinh = "\\sinh " +stringOfUnOp OpASin = "\\arcsin " +stringOfUnOp OpASinh = "\\arcsinh " +stringOfUnOp OpCos = "\\cos " +stringOfUnOp OpCosh = "\\cosh " +stringOfUnOp OpACos = "\\arccos " +stringOfUnOp OpACosh = "\\arccosh " +stringOfUnOp OpTan = "\\tan " +stringOfUnOp OpTanh = "\\tanh " +stringOfUnOp OpATan = "\\arctan " +stringOfUnOp OpATanh = "\\arctanh " +stringOfUnOp OpLn = "\\ln " +stringOfUnOp OpLog = "\\log " +stringOfUnOp op = error $ "stringOfUnop : unknown op " ++ show op + +stringOfBinOp :: BinOperator -> String +stringOfBinOp OpAdd = "+" +stringOfBinOp OpSub = "-" +stringOfBinOp OpMul = "\\ast" +stringOfBinOp OpDiv = "\\div" +stringOfBinOp OpAnd = " \\and " +stringOfBinOp OpOr = " \\or " +stringOfBinOp OpEq = " = " +stringOfBinOp OpNe = " \\ne " +stringOfBinOp OpLt = " < " +stringOfBinOp OpGt = " > " +stringOfBinOp OpGe = " \\ge " +stringOfBinOp OpLe = " \\le " +stringOfBinOp OpAttrib = " := " +stringOfBinOp _ = error "stringOfBinOp - unknown op" + +lno :: Conf -> FormulaPrim -> ShowS +lno conf = l conf (Nothing, False) + +latexargs :: Conf -> [FormulaPrim] -> ShowS +latexargs _ [] = id +latexargs conf (x:xs) = foldr (\e acc -> lno conf e . str ", " . acc) + (lno conf x) xs + +l :: Conf -> (Maybe BinOperator, Bool) -> FormulaPrim -> ShowS +l conf op (Poly _ p) = l conf op . unTagFormula . treeIfyFormula $ convertToFormula p +l conf op (Fraction f) = l conf op $ (CInteger $ numerator f) / (CInteger $ denominator f) +l conf op (Complex _ c) = l conf op $ complexTranslate c +l conf _ (List _ lst) = str "\\left[" . latexargs conf lst . str "\\right]" +l conf _ (Indexes _ main lst) = lno conf main . str "_{" . latexargs conf lst . char '}' +l _ _ (Block _ _ _) = str "block" +l _ _ (Variable v) = str v +l _ _ (NumEntity e) = str $ latexOfEntity e +l _ _ (Truth t) = shows t +l _ _ (CInteger i) = shows i +l _ _ (CFloat d) = shows d +l conf op (Meta _ _ f) = l conf op f +l _ _ (Lambda _ _clauses) = id + +l conf (Just pop,right) (BinOp _ OpMul [a,b]) + | mulAsDot conf = if needParenthesis right pop OpMul + then str "\\left( " . expr . str "\\right) " + else expr + where expr = l conf (Just OpMul, False) a + . str "\\cdot " + . l conf (Just OpMul, True) b + +l conf (Nothing,_) (BinOp _ OpMul [a,b]) + | mulAsDot conf = + l conf (Just OpMul, False) a . str "\\cdot " . l conf (Just OpMul, True) b + +l conf _ (BinOp _ OpDiv [a,b]) = str "\\frac{" . lno conf a . str "}{" . lno conf b . char '}' +l conf _ (BinOp _ OpPow [a,b]) = char '{' . l conf (Just OpPow, False) a + . str "}^{" . l conf (Just OpPow, True) b . char '}' +l conf (Just pop,right) (BinOp _ op [a,b]) = + if needParenthesis right pop op + then str "\\left( " . expr . str "\\right) " + else expr + where expr = l conf (Just op, False) a + . str (stringOfBinOp op) + . l conf (Just op, True) b + +l conf (Nothing,_) (BinOp _ op [a,b]) = lno conf a . str (stringOfBinOp op) . lno conf b +l _ _ (BinOp _ _ _) = error "latexification require treeified formula" + +-- Unary operators +l conf _ (UnOp _ OpAbs f) = str "\\lvert " . lno conf f . str "\\rvert " +l conf _ (UnOp _ OpFloor f) = str "\\lfloor " . lno conf f . str "\\rfloor" +l conf _ (UnOp _ OpCeil f) = str "\\lceil " . lno conf f . str "\\rceil" +l conf _ (UnOp _ OpFrac f) = str "\\lbrace " . lno conf f . str "\\rbrace" +l conf _ (UnOp _ OpSqrt f) = str "\\sqrt{" . lno conf f . char '}' +l conf _ (UnOp _ OpExp f) = str "\\exp ^ {" . l conf (Just OpPow, True) f . str "} " +l conf _ (UnOp _ OpNegate f) + | f `hasProp` LeafNode = str " -" . lno conf f + | otherwise = str "-\\left( " . lno conf f . str "\\right)" +l conf _ (UnOp _ OpFactorial f) + | f `hasProp` LeafNode = lno conf f . str "!" + | otherwise = str "\\left( " . lno conf f . str "\\right)!" +l conf _ (UnOp _ op f) + | f `hasProp` LeafNode = str (stringOfUnOp op) . lno conf f + | otherwise = str (stringOfUnOp op) . str "\\left(" . lno conf f . str "\\right)" + +l conf _ (Sum _ begin end what) = + str "\\sum_{" . lno conf begin . str "}^{" . lno conf end . str "} " . lno conf what +l conf _ (Product _ begin end what) = + str "\\prod_{" . lno conf begin . str "}^{" . lno conf end . str "} " . lno conf what + +l conf _ (Integrate _ begin end what var) = + str "\\int_{" . lno conf begin . str "}^{" . lno conf end + . str "} \\! " . lno conf what . str " \\, d" . lno conf var + +l conf _ (Derivate _ f var) = + str "\\frac{d " . lno conf f . str "}{ d" . lno conf var . char '}' + +l conf _ (App _ func args) = + lno conf func . str "\\left(" . latexargs conf args . str "\\right)" + where +l conf _ (Matrix _ _ _ lsts) = str "\\begin{bmatrix}\n" + . matrixCells + . str "\n\\end{bmatrix}" + where perLine = interspereseS (str " & ") . map (lno conf) + matrixCells = interspereseS (str "\\\\\n") $ map perLine lsts + + diff --git a/EqManips/Renderer/Mathml.hs b/EqManips/Renderer/Mathml.hs new file mode 100644 --- /dev/null +++ b/EqManips/Renderer/Mathml.hs @@ -0,0 +1,272 @@ +{-# LANGUAGE NewQualifiedOperators #-} +module EqManips.Renderer.Mathml( mathmlRender ) where + +import EqManips.Types hiding ( matrix ) +import EqManips.Algorithm.Utils +import EqManips.Propreties + +import EqManips.Renderer.Latex +import EqManips.Renderer.EqCode +import EqManips.Renderer.RenderConf + +mathmlRender :: Conf -> Formula TreeForm -> String +mathmlRender conf (Formula f) = + str "\n" + . semantics ( presMarkup + . annotation "MathML-Content" contentMarkup + . annotation "Eq-language" (str . cleanify $ unparse f) + . annotation "LaTeX" (str . cleanify . latexRender conf $ Formula f)) + . str "\n" $ "" + where contentMarkup = content f + presMarkup = mrow $ prez conf f + semantics = tagger "semantics" + annotation kind c = + str ("\n") + . c . str "\n\n" + +str :: String -> ShowS +str = (++) + +char :: Char -> ShowS +char = (:) + +mathMlOfEntity :: Entity -> String +mathMlOfEntity Pi = "" +mathMlOfEntity Nabla = "" +mathMlOfEntity Infinite = "" +mathMlOfEntity Ellipsis = "⋯" + +tagger :: String -> ShowS -> ShowS +tagger tag f = str ('<': tag ++ ">") . f . str ("") + +cleanify :: String -> String +cleanify = concatMap deAnchor + where deAnchor '<' = "<" + deAnchor '>' = ">" + deAnchor '&' = "&" + deAnchor a = [a] + +mo, msup, mi, mn, mfrac, mrow, parens, + msubsup, msqrt, mfenced, mtable, + mtd, mtr :: ShowS -> ShowS +mo = tagger "mo" +mi = tagger "mi" +mn = tagger "mn" +mfrac = tagger "mfrac" +mrow = tagger "mrow" +parens f = str "(" . f . str ")" +msubsup = tagger "msubsup" +msup = tagger "msup" +msqrt = tagger "msqrt" + +mfenced f = str "\n" . f . str "\n" +mtable = tagger "mtable" +mtd = tagger "mtd" +mtr = tagger "mtr" + +enclose :: Char -> Char -> ShowS -> ShowS +enclose beg end f = str ("" ++ (beg : "")) . f . str ("" ++ (end : "")) + +prez :: Conf -> FormulaPrim -> ShowS +prez conf = presentation conf Nothing + +--centerdot +-- +presentation :: Conf -> Maybe (BinOperator, Bool) -> FormulaPrim -> ShowS +presentation _ _ (Block _ _ _) = mi $ str "block" +presentation _ _ (Variable v) = mi $ str v +presentation _ _ (NumEntity e) = mn $ str $ mathMlOfEntity e +presentation _ _ (Truth t) = mn $ shows t +presentation _ _ (CInteger i) = mn $ shows i +presentation _ _ (CFloat d) = mn $ shows d +presentation conf inf (Meta _ _ f) = presentation conf inf f +presentation _ _ (Lambda _ _clauses) = id + +presentation conf _ (BinOp _ OpPow [a,b]) = + msup $ mrow (presentation conf (Just (OpPow, False)) a) + . mrow (presentation conf (Just (OpPow, True)) b) + +presentation conf _ (BinOp _ OpDiv [a,b]) = + mfrac $ mrow (prez conf a) + . mrow (prez conf b) + +presentation conf (Just (pop,isRight)) f@(BinOp _ op _) + | needParenthesis isRight pop op = parens $ prez conf f + | otherwise = prez conf f + +presentation conf Nothing (BinOp _ OpMul [a,b]) + | mulAsDot conf = presentation conf (Just (OpMul, False)) a + . mo (str "·") + . presentation conf (Just (OpMul, True)) b + + | otherwise = presentation conf (Just (OpMul, False)) a + . mo (str "×") + . presentation conf (Just (OpMul, True)) b + +presentation conf Nothing (BinOp _ op [a,b]) = + presentation conf (Just (op, False)) a + . mo (str . cleanify $ binopString op) + . presentation conf (Just (op, True)) b + +-- Unary operators +presentation conf _ (UnOp _ OpCeil f) = str "⌈" + . prez conf f + . str "⌉" +presentation conf _ (UnOp _ OpFloor f) = str "⌊" + . prez conf f + . str "⌋" +presentation conf _ (UnOp _ OpFrac f) = enclose '{' '}' $ prez conf f +presentation conf _ (UnOp _ OpAbs f) = enclose '|' '|' $ prez conf f +presentation conf _ (UnOp _ OpSqrt f) = msqrt $ prez conf f +presentation conf _ (UnOp _ OpFactorial f) + | f `hasProp` LeafNode = prez conf f . mo (char '!') + | otherwise = parens (prez conf f) . mo (char '!') +presentation conf _ (UnOp _ OpNegate f) + | f `hasProp` LeafNode = mo (char '-') . prez conf f + | otherwise = mo (char '-') . parens (prez conf f) +presentation conf _ (UnOp _ op f) + | f `hasProp` LeafNode = mo (str $ unopString op) . prez conf f + | otherwise = mo (str $ unopString op) . parens (prez conf f) + +presentation conf _ (Sum _ begin end what) = + msubsup ( mo (str "∑") + . mrow (prez conf begin) + . mrow (prez conf end)) . mrow (prez conf what) + +presentation conf _ (Product _ begin end what) = + msubsup ( mo (str "∏") + . mrow (prez conf begin) + . mrow (prez conf end)) . mrow (prez conf what) + +presentation conf _ (Integrate _ begin end what var) = + msubsup ( mo (str "∫") + . mrow (prez conf begin) + . mrow (prez conf end)) + . mrow (prez conf what . mi (str "d") . prez conf var) + +presentation conf _ (Derivate _ f var) = + mfrac ( mi (char 'd') + . mrow (mi (char 'd') . prez conf var)) . prez conf f + +presentation conf _ (App _ func args) = + prez conf func . parens (interspereseS (mo $ char ',') $ map (prez conf) args) + +presentation conf _ (Matrix _ _ _ lsts) = + mfenced $ mtable $ concatS [mtr $ concatS [ mtd $ prez conf cell | cell <- row] | row <- lsts ] +presentation _ _ f = error $ "\n\nWrong MathML presentation rendering : " ++ unparse f ++ "\n" ++ show f + +----------------------------------------------- +---- Content +----------------------------------------------- + +ci, cn, apply, lowlimit, + uplimit, matrix, matrixrow, + bvar :: ShowS -> ShowS + +ci = tagger "ci" +cn = tagger "cn" +apply = tagger "apply" +lowlimit = tagger "lowlimit" +uplimit = tagger "uplimit" +matrix = tagger "matrix" +matrixrow = tagger "matrixrow" +bvar = tagger "bvar" + +stringOfUnOp :: UnOperator -> String +stringOfUnOp OpSin = "" +stringOfUnOp OpSinh = "" +stringOfUnOp OpASin = "" +stringOfUnOp OpASinh = "" +stringOfUnOp OpCos = "" +stringOfUnOp OpCosh = "" +stringOfUnOp OpACos = "" +stringOfUnOp OpACosh = "" +stringOfUnOp OpTan = "" +stringOfUnOp OpTanh = "" +stringOfUnOp OpATan = "" +stringOfUnOp OpATanh = "" +stringOfUnOp OpLn = "" +stringOfUnOp OpLog = "" +stringOfUnOp OpExp = "" +stringOfUnOp OpAbs = "" +stringOfUnOp OpFloor = "" +stringOfUnOp OpCeil = "" +stringOfUnOp OpSqrt = "" +stringOfUnOp OpFactorial = "" +stringOfUnOp OpNegate = "" +stringOfUnOp OpFrac = "frac" + +stringOfBinOp :: BinOperator -> String +stringOfBinOp OpAdd = "" +stringOfBinOp OpAnd = "" +stringOfBinOp OpDiv = "" +stringOfBinOp OpEq = "" +stringOfBinOp OpGe = "" +stringOfBinOp OpGt = "" +stringOfBinOp OpLe = "" +stringOfBinOp OpLt = "" +stringOfBinOp OpMul = "" +stringOfBinOp OpNe = "" +stringOfBinOp OpOr = "" +stringOfBinOp OpPow = "" +stringOfBinOp OpSub = "" +stringOfBinOp OpAttrib = "" +stringOfBinOp OpLazyAttrib = "" +stringOfBinOp OpCons = "" + +bigOperator :: String -> String -> FormulaPrim -> FormulaPrim -> FormulaPrim + -> ShowS +bigOperator operator var def end what = + apply $ str operator + . bvar (str var) + . lowlimit (content def) + . uplimit (content end) + . content what + +-- | Give 2 xml trees, one for presentation and one +-- for content. Shitty MathML. +content :: FormulaPrim -> ShowS +content (Block _ _ _) = ci $ str "block" +content (Variable v) = ci $ str v +content (NumEntity e) = cn . str $ mathMlOfEntity e +content (Truth True) = str "" +content (Truth False) = str "" +content (CInteger i) = cn $ shows i +content (CFloat d) = cn $ shows d +content (Meta _ _ f) = content f +content (Lambda _ _clauses) = id + +content (UnOp _ op f) = + apply $ str (stringOfUnOp op) + . content f + +content (BinOp _ op lst) = + apply $ str (stringOfBinOp op) + . concatMapS content lst + +content (Product _ (BinOp _ OpEq [Variable v, def]) end what) = + bigOperator "" v def end what + +content (Sum _ (BinOp _ OpEq [Variable v, def]) end what) = + bigOperator "" v def end what + +content (Matrix _ _ _ lsts) = + matrix $ concatS [matrixrow $ concatMapS content row | row <- lsts] + +content (Integrate _ begin end what var) = + apply $ str "" + . bvar (content var) + . lowlimit (content begin) + . uplimit (content end) + . content what + +content (Derivate _ f var) = + apply $ str "" + . bvar (content var) + . content f + +content (App _ func args) = + apply $ content func + . concatMapS content args +content _ = id + diff --git a/EqManips/Renderer/Placer.hs b/EqManips/Renderer/Placer.hs new file mode 100644 --- /dev/null +++ b/EqManips/Renderer/Placer.hs @@ -0,0 +1,295 @@ +module EqManips.Renderer.Placer( SizeTree( .. ) + , Dimensioner( .. ) + , Dimension, BaseLine, RelativePlacement + , sizeExtract + , baseLineOfTree + , sizeTreeOfFormula + , sizeOfTree + , maxPrio + ) where + +import Data.List( foldl', transpose ) +import Data.Ratio + +import EqManips.Types +import EqManips.Polynome +import EqManips.Algorithm.Utils +import EqManips.Propreties +import EqManips.Renderer.RenderConf +import qualified EqManips.ErrorMessages as Err + +type OpPriority = Int +type BaseLine = Int +type Dimension = (Int, Int) + +type RelativePlacement = (BaseLine, Dimension) + +-- | Size tree used to store the block size to +-- render the equation in ASCII +data SizeTree = + EndNode RelativePlacement + | MonoSizeNode Bool RelativePlacement SizeTree + | BiSizeNode Bool RelativePlacement SizeTree SizeTree + | SizeNodeList Bool RelativePlacement BaseLine [SizeTree] + | SizeNodeClause Bool RelativePlacement [(BaseLine, [SizeTree], BaseLine, SizeTree)] + | SizeNodeArray Bool RelativePlacement [[(RelativePlacement, SizeTree)]] + deriving (Eq, Show) + +-- | an "object" which is used to get the placement of all the elements in the equation. +data Dimensioner = Dimensioner + { unaryDim :: Conf -> UnOperator -> RelativePlacement -> RelativePlacement + , varSize :: Conf -> String -> RelativePlacement + , intSize :: Conf -> Integer -> RelativePlacement + , floatSize :: Conf -> Double -> RelativePlacement + , addParens :: Conf -> Dimension -> Dimension + , remParens :: Conf -> Dimension -> Dimension + , divBar :: Conf -> RelativePlacement -> RelativePlacement -> RelativePlacement + , powSize :: Conf -> RelativePlacement -> RelativePlacement -> RelativePlacement + , binop :: Conf -> BinOperator -> RelativePlacement -> RelativePlacement -> RelativePlacement + , argSize :: Conf -> (Int, Int, Int) -> RelativePlacement -> (Int, Int, Int) + , appSize :: Conf -> (Int, Int, Int) -> RelativePlacement -> RelativePlacement + , lambdaSize :: Conf -> [((Int,Int,Int), RelativePlacement)] -> RelativePlacement + , sumSize :: Conf -> RelativePlacement -> RelativePlacement -> RelativePlacement -> RelativePlacement + , productSize :: Conf -> RelativePlacement -> RelativePlacement -> RelativePlacement -> RelativePlacement + , integralSize :: Conf -> RelativePlacement -> RelativePlacement + -> RelativePlacement -> RelativePlacement -> RelativePlacement + , blockSize :: Conf -> (Int, Int, Int) -> RelativePlacement + , matrixSize :: Conf -> [[RelativePlacement]] -> RelativePlacement + , derivateSize :: Conf -> RelativePlacement -> RelativePlacement -> RelativePlacement + , entitySize :: Conf -> Entity -> RelativePlacement + , truthSize :: Conf -> Bool -> RelativePlacement + , listSize :: Conf -> (Int, Int, Int) -> RelativePlacement + + , indexesSize :: Conf -> RelativePlacement -> [RelativePlacement] -> RelativePlacement + , indexPowerSize :: Conf -> RelativePlacement -> [RelativePlacement] -> RelativePlacement -> RelativePlacement + } + +sizeExtract :: SizeTree -> RelativePlacement +sizeExtract (EndNode s) = s +sizeExtract (MonoSizeNode _ s _) = s +sizeExtract (BiSizeNode _ s _ _) = s +sizeExtract (SizeNodeList _ s _ _) = s +sizeExtract (SizeNodeArray _ s _) = s +sizeExtract (SizeNodeClause _ s _) = s + +sizeOfTree :: SizeTree -> (Int, Int) +sizeOfTree = snd . sizeExtract + +baseLineOfTree :: SizeTree -> BaseLine +baseLineOfTree = fst . sizeExtract + +maxPrio :: Int +maxPrio = 100 + +-- | Obtain a size tree for a formula given +-- an desired outputter. +sizeTreeOfFormula :: Conf -> Dimensioner -> Formula TreeForm -> SizeTree +sizeTreeOfFormula conf dim (Formula a) = sizeOfFormula conf dim False maxPrio a + +-- | Compute a size tree for a formula. +-- This size-tree can be used for a following render +sizeOfFormula :: Conf -> Dimensioner -> Bool -> OpPriority -> FormulaPrim -> SizeTree +-- INVISIBLE META NINJA +sizeOfFormula conf sizer a b (Meta _ _ f) = sizeOfFormula conf sizer a b f +-- Automatic conversion POLY NINJA +sizeOfFormula conf sizer a b (Fraction f) = + sizeOfFormula conf sizer a b + $ (CInteger $ numerator f) / (CInteger $ denominator f) + +sizeOfFormula conf sizer a b (Complex _ c) = + sizeOfFormula conf sizer a b $ complexTranslate c +sizeOfFormula conf sizer a b (Poly _ p) = + sizeOfFormula conf sizer a b . unTagFormula . treeIfyFormula $ convertToFormula p +-- Simply the size of rendered text +sizeOfFormula conf sizer _ _ (Variable v) = EndNode $ varSize sizer conf v +sizeOfFormula conf sizer _ _ (CInteger n) = EndNode $ intSize sizer conf n +sizeOfFormula conf sizer _ _ (CFloat f) = EndNode $ floatSize sizer conf f +sizeOfFormula conf sizer _ _ (Truth truthness) = EndNode $ truthSize sizer conf truthness +sizeOfFormula conf sizer _ _ (NumEntity f) = EndNode $ entitySize sizer conf f +sizeOfFormula conf sizer _ _ (Block i1 i2 i3) = + EndNode $ blockSize sizer conf (i1, i2, i3) + +-- Simply put a minus in front of the rest of the formula +sizeOfFormula conf sizer _ _ (UnOp _ op f) = + MonoSizeNode False sizeDim subFormula + where prio = op `obtainProp` Priority + subFormula = sizeOfFormula conf sizer True prio f + sizeDim = unaryDim sizer conf op (sizeExtract subFormula) + +sizeOfFormula _ _ _ _ (BinOp _ _ [_]) = error $ Err.single_binop "sizeOfFormula conf - " +sizeOfFormula _ _ _ _ (BinOp _ _ []) = error $ Err.empty_binop "sizeOfFormula conf - " + +-- do something like that : +-- #### +-- ------ +-- # +-- # +sizeOfFormula conf sizer _ _ (BinOp _ OpDiv [f1,f2]) = + BiSizeNode False sizeDim nodeLeft nodeRight + where nodeLeft = sizeOfFormula conf sizer False maxPrio f1 + nodeRight = sizeOfFormula conf sizer True maxPrio f2 + sizeDim = divBar sizer conf (sizeExtract nodeLeft) (sizeExtract nodeRight) + +-- do something like that +-- %%%%%%% +-- %%%%%%% +-- #### +-- #### +-- ^^^ +-- ^^^ +sizeOfFormula conf sizer isRight prevPrio (BinOp _ OpPow [Indexes _ f1 f2, rest]) = + BiSizeNode needParenthes lastSize (SizeNodeList False lastSize indexBase + $ baseSize:subTrees) + powerUp + where subSize = sizeOfFormula conf sizer False maxPrio + baseSize = subSize f1 + powerUp = subSize rest + subTrees = map subSize f2 + lastSize = indexPowerSize sizer conf (sizeExtract baseSize) + (map sizeExtract subTrees) + (sizeExtract powerUp) + + (_, indexBase, _) = argSizes sizer conf subTrees + needParenthes = needParenthesisPrio isRight prevPrio OpPow + +-- do something like that +-- #### +-- #### +-- ^^^ +-- ^^^ +sizeOfFormula conf sizer _ _ (Indexes _ f1 f2) = + (SizeNodeList False lastSize indexBase $ baseSize:subTrees) + where subSize = sizeOfFormula conf sizer False maxPrio + baseSize = subSize f1 + subTrees = map subSize f2 + + lastSize = indexesSize sizer conf (sizeExtract baseSize) + (map sizeExtract subTrees) + + (_, indexBase, _) = argSizes sizer conf subTrees + +-- do something like that +-- %%%%%%% +-- %%%%%%% +-- #### ^ +-- #### +sizeOfFormula conf sizer _isRight _prevPrio (BinOp _ OpPow [f1,f2]) = + BiSizeNode False sizeDim nodeLeft nodeRight + where nodeLeft = sizeOfFormula conf sizer False prioOfPow f1 + nodeRight = sizeOfFormula conf sizer True prioOfPow f2 + prioOfPow = OpPow `obtainProp` Priority + sizeDim = powSize sizer conf (sizeExtract nodeLeft) (sizeExtract nodeRight) + +-- add 3 char : ###### ! ####### +-- we add spaces around operators +sizeOfFormula conf sizer isRight prevPrio (BinOp _ op [formula1, formula2]) = + BiSizeNode needParenthes sizeDim nodeLeft nodeRight + where prio = op `obtainProp` Priority + needParenthes = needParenthesisPrio isRight prevPrio op + + nodeLeft = sizeOfFormula conf sizer False prio formula1 + nodeRight = sizeOfFormula conf sizer True prio formula2 + + (base, s) = binop sizer conf op (sizeExtract nodeLeft) (sizeExtract nodeRight) + + sizeDim = if needParenthes + then (base, addParens sizer conf s) + else (base, s) + +sizeOfFormula conf sizer r p f@(BinOp _ _ _) = + sizeOfFormula conf sizer r p $ treeIfyBinOp f + +sizeOfFormula conf sizer _isRight _prevPrio (Integrate _ inite end what dx) = + SizeNodeList False sizeDim 0 trees + where sof = sizeOfFormula conf sizer False maxPrio + trees = map sof [inite, end, what, dx] + [iniDim, endDim, whatDim, dxDim] = map sizeExtract trees + sizeDim = integralSize sizer conf iniDim endDim whatDim dxDim + +sizeOfFormula conf sizer _ _ (Matrix _ _ _ exprs) = + SizeNodeArray False sizeDim mixedMatrix + where lineMapper = map (sizeOfFormula conf sizer False maxPrio) + sizeMatrix = map lineMapper exprs + + sizeDim = matrixSize sizer conf dimensionMatrix + + baseLineExtractor :: (Int, Int) -> SizeTree -> (Int,Int) + baseLineExtractor (base, depth) size = + let (base', (_,h')) = sizeExtract size + in (max base base', max depth (h' - base')) + + heights :: [(Int,Int)] + heights = map (foldl' baseLineExtractor (0,0)) sizeMatrix + + widths :: [Int] + widths = + [ maximum $ map widthOf column | column <- transpose sizeMatrix ] + + widthOf :: SizeTree -> Int + widthOf = fst . snd . sizeExtract + + dimensionMatrix = + [ [(bases, (w, bases + depth)) | w <- widths] + | (bases, depth) <- heights] + + mixedMatrix = + [ zip dims sizes + | (dims, sizes) <- zip dimensionMatrix sizeMatrix] + +sizeOfFormula conf sizer _isRight _prevPrio (Product _ inite end what) = + SizeNodeList False sizeDim 0 trees + where sof = sizeOfFormula conf sizer False maxPrio + trees = map sof [inite, end, what] + [iniDim, endDim, whatDim] = map sizeExtract trees + sizeDim = productSize sizer conf iniDim endDim whatDim + + +sizeOfFormula conf sizer _isRight _prevPrio (Derivate _ what vard) = + BiSizeNode False sizeDim whatDim vardDim + where whatDim = sizeOfFormula conf sizer False maxPrio what + vardDim = sizeOfFormula conf sizer False maxPrio vard + sizeDim = derivateSize sizer conf (sizeExtract whatDim) + (sizeExtract vardDim) + +sizeOfFormula conf sizer _isRight _prevPrio (Sum _ inite end what) = + SizeNodeList False sizeDim 0 trees + where sof = sizeOfFormula conf sizer False maxPrio + trees = map sof [inite, end, what] + [iniDim, endDim, whatDim] = map sizeExtract trees + sizeDim = sumSize sizer conf iniDim endDim whatDim + +sizeOfFormula conf sizer _ _ (List _ lst) = + SizeNodeList False wholeSize listBase trees + where trees = map (sizeOfFormula conf sizer False maxPrio) lst + wholeSize = listSize sizer conf size + size@(_, listBase, _) = argSizes sizer conf trees + +-- do something like this : +-- ####### +-- %%%% ####### +-- %%%% ####### +-- ####### +sizeOfFormula conf sizer _ _ (App _ f1 f2) = + SizeNodeList False sizeDim argsBase (funcSize : trees) + where subSize = sizeOfFormula conf sizer False maxPrio + trees = map subSize f2 + funcSize = subSize f1 + + accumulated = argSizes sizer conf trees + sizeDim = appSize sizer conf accumulated (sizeExtract funcSize) + (_, argsBase, _) = accumulated + +sizeOfFormula conf sizer _ _ (Lambda _ clauses) = SizeNodeClause False nodeSize finalTree + where subSize = sizeOfFormula conf sizer False maxPrio + subTrees = [ (map subSize args, subSize body) | (args, body) <- clauses ] + subPlacement = [(argSizes sizer conf args, sizeExtract body) | (args, body) <- subTrees] + nodeSize = lambdaSize sizer conf subPlacement + finalTree = [ (argBase, argTrees, bodyBase, bodyTree) + | ( (argTrees, bodyTree) + , ((_, argBase,_),(bodyBase,_)) ) <- zip subTrees subPlacement] + +-- | Compute size for all args and return (width, aboveBaseLine, belowBaseline) +argSizes :: Dimensioner -> Conf -> [SizeTree] -> (Int, Int, Int) +argSizes sizer conf args = foldl' sizeExtractor (0, 0, 0) args + where sizeExtractor acc = argSize sizer conf acc . sizeExtract + diff --git a/EqManips/Renderer/RenderConf.hs b/EqManips/Renderer/RenderConf.hs new file mode 100644 --- /dev/null +++ b/EqManips/Renderer/RenderConf.hs @@ -0,0 +1,51 @@ +module EqManips.Renderer.RenderConf( confLoad + , Conf( .. ) + , defaultRenderConf + ) where + +import Data.Char( isSpace ) + +data Conf = Conf + { mulAsDot :: Bool + , packNumVarMul :: Bool + , noBigOpOverSize :: Bool + , useUnicode :: Bool + } + +defaultRenderConf :: Conf +defaultRenderConf = Conf + { mulAsDot = True + , packNumVarMul = False + , noBigOpOverSize = False + , useUnicode = False + } + +keyParser :: [(String, Conf -> String -> Conf)] +keyParser = + [ ("mulasdot" , \c v -> c{ mulAsDot = permissiveBool v } ) + , ("packnumvarmul" , \c v -> c{ packNumVarMul = permissiveBool v} ) + , ("nobigopoversize", \c v -> c{ noBigOpOverSize = permissiveBool v} ) + , ("use_unicode" , \c v -> c{ useUnicode = permissiveBool v } ) + ] + +trim :: String -> String +trim = f . f + where f = reverse . dropWhile isSpace + +permissiveBool :: String -> Bool +permissiveBool "1" = True +permissiveBool "yes" = True +permissiveBool "true" = True +permissiveBool "True" = True +permissiveBool _ = False + +confRead :: String -> Conf -> Conf +confRead ('#':_) c = c +confRead s c = case lookup (trim key) keyParser of + Just parser -> parser c $ trim value + Nothing -> c + where (key, value) = break ('=' ==) s + +confLoad :: [String] -> Conf +confLoad = foldr confRead defaultRenderConf + diff --git a/EqManips/Renderer/Sexpr.hs b/EqManips/Renderer/Sexpr.hs new file mode 100644 --- /dev/null +++ b/EqManips/Renderer/Sexpr.hs @@ -0,0 +1,91 @@ +module EqManips.Renderer.Sexpr( sexprRender, sexprRenderS ) where + +import Data.Ratio +import EqManips.Types +import EqManips.Polynome +import EqManips.Algorithm.Utils + +sexprRender :: Formula anyForm -> String +sexprRender f = sexprRenderS f "" + +sexprRenderS :: Formula anyForm -> ShowS +sexprRenderS (Formula f) = sexprS f + +str :: String -> ShowS +str = (++) + +char :: Char -> ShowS +char = (:) + +sexprS :: FormulaPrim -> ShowS +sexprS (Complex _ (re, im)) = str "(complex " . sexprS re . char ' ' . sexprS im . char ')' +sexprS (Fraction f) = sexprS $ (CInteger $ numerator f) / (CInteger $ denominator f) +sexprS (Poly _ v@(PolyRest _)) = sexprS . unTagFormula $ convertToFormula v +sexprS (Poly _ (Polynome v lst)) = + str "(poly " . str v . char ' ' . concatMapS coeffPrinter lst . char ')' + where coeffSexpr = sexprS . unTagFormula . convertToFormula . PolyRest + coeffPrinter (coeff, polyn) = + char '(' . coeffSexpr coeff . str ", " + . sexprS (poly polyn) + . str ") " + +sexprS (List _ lst) = + str "(list " . concatMapS (\a -> char ' ' . sexprS a) lst . str ") " + +sexprS (Indexes _ main lst) = + str "(indexes " . sexprS main . char ' ' + . concatMapS (\a -> char ' ' . sexprS a) lst . str ") " + +sexprS (Block _ _ _) = str "(block)" +sexprS (Variable v) = str v +sexprS (NumEntity e) = shows e +sexprS (Truth t) = shows t +sexprS (CInteger i) = shows i +sexprS (CFloat d) = shows d +sexprS (Meta _ op f) = char '(' . shows op . char ' ' . sexprS f . char ')' +sexprS (Lambda _ clauses) = + str "(lambda " . concatMapS clauseRender clauses + . char ')' + where clauseRender (args, body) = + str "((" . interspereseS (' ':) (map sexprS args) . str ") " + . sexprS body + . char ')' + +sexprS (BinOp _ op lst) = + char '(' . str (binopString op) + . concatMapS (\a -> char ' ' . sexprS a) lst + . char ')' + +sexprS (UnOp _ op f) = char '(' . str (unopString op) . char ' ' + . sexprS f . char ')' + +sexprS (Sum _ begin end what) = + str "(sum " . sexprS begin . char ' ' + . sexprS end . char ' ' + . sexprS what . char ')' + +sexprS (Product _ begin end what) = + str "(product " . sexprS begin . char ' ' + . sexprS end . char ' ' + . sexprS what . char ')' + +sexprS (Integrate _ begin end what var) = + str "(integral " . sexprS begin . char ' ' + . sexprS end . char ' ' + . sexprS what . char ' ' + . sexprS var . char ')' + +sexprS (Derivate _ f var) = + str "(derivate " . sexprS f . char ' ' + . sexprS var . char ')' + +sexprS (App _ func args) = + str "(apply " . sexprS func . char ' ' + . interspereseS (' ':) (map sexprS args) + . char ')' + +sexprS (Matrix _ n m lsts) = + str "(matrix " . shows n . char ' ' . shows m . char ' ' + . concatS [concatMapS (\a -> (' ':) . sexprS a) lst | lst <- lsts] + . char ')' + diff --git a/EqManips/Renderer/Sexpr.hs-boot b/EqManips/Renderer/Sexpr.hs-boot new file mode 100644 --- /dev/null +++ b/EqManips/Renderer/Sexpr.hs-boot @@ -0,0 +1,7 @@ +module EqManips.Renderer.Sexpr where + +import {-# SOURCE #-} EqManips.Types + +sexprRender :: Formula anyForm -> String +sexprRenderS :: Formula anyForm -> ShowS + diff --git a/EqManips/Types.hs b/EqManips/Types.hs new file mode 100644 --- /dev/null +++ b/EqManips/Types.hs @@ -0,0 +1,753 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE Rank2Types #-} +module EqManips.Types + ( FormulaPrim( .. ) + , Formula( .. ) + + -- | Tell that the formula is in form binop op [a,b ...] + , ListForm + -- | Tell that formula is in form Binop op [a,b] + , TreeForm + + , hashOfFormula + , BinOperator( .. ) + , UnOperator( .. ) + , Entity( .. ) + + , binopString + , unopString + + -- | Exported only to permit the main program to display + -- accurate help. + , binopDefs + -- | For more information about others unary operator, + -- refer to the link section. + , realUnopOperators + + -- | To query associativity side + , AssocSide(..) + -- | Return type for associativity side + , OpAssoc( .. ) + -- | Gain access to operator's priority + , Priority(.. ) + , LeafNode( .. ) + , OpProp( .. ) + , OperatorText(..) + + , MetaOperation( .. ) + , Polynome( .. ), PolyCoeff( .. ) + , coeffPredicate, polyCoeffCast + , foldf + , canDistributeOver + , distributeOver + + , binOp, unOp, complex, meta + , app, summ, productt, derivate + , integrate, lambda, matrix, poly + , indexes, list + ) where + +import Data.Ord( comparing ) +import Data.Monoid( Monoid( .. ), getSum ) +import qualified Data.Monoid as Monoid +import qualified EqManips.ErrorMessages as Err + +import Data.Bits +import Data.Ratio +import Data.List( foldl', foldl1' ) +import Data.Maybe( fromJust ) + +import EqManips.Propreties +import {-# SOURCE #-} EqManips.Polynome() +import {-# SOURCE #-} EqManips.Renderer.Sexpr + +-- | All Binary operators +data BinOperator = + -- | '+' + OpAdd + -- | '-' + | OpSub + -- | '*' + | OpMul + -- | '/' + | OpDiv + -- | '^' + | OpPow + + | OpAnd -- ^ '&' + | OpOr -- ^ '|' + + + | OpEq -- ^ '=' + | OpNe -- ^ '/=' + | OpLt -- ^ '<' + | OpGt -- ^ '>' + | OpGe -- ^ '>=' + | OpLe -- ^ '<=' + + | OpLazyAttrib -- ^ ':>' + | OpAttrib -- ^ ':=' + | OpCons -- ^ '::' + deriving (Eq,Show,Enum) + +-- | All `unary` operators are in there. some are mathematical +-- functions. They're present here, because it's easier to pattern +-- match them this way +data UnOperator = + OpNegate | OpAbs | OpSqrt + + | OpSin | OpSinh | OpASin | OpASinh + | OpCos | OpCosh | OpACos | OpACosh + | OpTan | OpTanh | OpATan | OpATanh + + | OpLn | OpLog | OpExp + | OpFactorial + | OpCeil | OpFloor | OpFrac + deriving (Eq, Show, Enum) + +-- | Some entity which cannot be represented in other mannear +data Entity = + Pi + | Nabla + | Infinite + | Ellipsis -- ^ ... no value can be bound to it + deriving (Eq, Show, Ord, Enum) + + +data MetaOperation = + -- | Avoid an evaluation, replace itself by the + -- without touching it. + Hold + -- | Inverse of hold, whenever encountered in + -- evaluation, should force an evaluation. + | Force + | Expand -- ^ trigger an expend operation + | Cleanup -- ^ trigger a basic formula cleanup + | LambdaBuild -- ^ To generate a full blown Lambda + | Sort -- ^ To sort the formula + deriving (Eq, Show, Read, Enum) + +type FloatingValue = Double +type HashResume = Int + +-- | Main type manipulated by the software. +-- All relevant instances for numeric types +-- are provided for ease of use +data FormulaPrim = + Variable String + | NumEntity Entity + | Truth Bool + | CInteger Integer + | CFloat FloatingValue + | Fraction (Ratio Integer) + | Complex HashResume (FormulaPrim , FormulaPrim) + + -- | To index nDimensional data + | Indexes HashResume FormulaPrim [FormulaPrim] + -- | Yay, adding list to the language + | List HashResume [FormulaPrim] + + -- | FunName arguments + | App HashResume FormulaPrim [FormulaPrim] + -- | LowBound highbound expression + | Sum HashResume FormulaPrim FormulaPrim FormulaPrim + -- | LowBound highbound expression + | Product HashResume FormulaPrim FormulaPrim FormulaPrim + + -- | Derivate expression withVar + | Derivate HashResume FormulaPrim FormulaPrim + + -- | lowBound highBound expression dx + | Integrate HashResume FormulaPrim FormulaPrim FormulaPrim FormulaPrim + + -- | -1 for example + | UnOp HashResume UnOperator FormulaPrim + + -- | Represent a function. a function + -- can have many definitions. The applied + -- one must be the first in the list which + -- unify with the applied parameters. + | Lambda HashResume [( [FormulaPrim] {- clause args -} + , FormulaPrim {- clause body -}) + ] {- clauses -} + + -- | f1 op f2 + | BinOp HashResume BinOperator [FormulaPrim] + + -- | Width, Height, all formulas + | Matrix HashResume Int Int [[FormulaPrim]] + + -- | Form that can be used to make nice simplification. + | Poly HashResume Polynome + + -- | Used for debug + | Block Int Int Int + + -- | A meta operation is an operation used + -- by the sysem, but that doesn't appear in the + -- normal output. + | Meta HashResume MetaOperation FormulaPrim + deriving (Eq, Show) + +-------------------------------------------------- +---- Hash construction +-------------------------------------------------- +hashOfFormula :: FormulaPrim -> HashResume +hashOfFormula (CInteger i) = fromIntegral i +hashOfFormula (Variable s) = sum $ map fromEnum s +hashOfFormula (NumEntity e) = fromEnum e +hashOfFormula (Truth True) = maxBound +hashOfFormula (Truth False) = minBound +hashOfFormula (CFloat f) = fromEnum f +hashOfFormula (Fraction frac) = fromIntegral (numerator frac) + + fromIntegral (denominator frac) + +hashOfFormula (Complex hash _) = hash +hashOfFormula (Indexes hash _ _) = hash +hashOfFormula (List hash _) = hash +hashOfFormula (App hash _ _) = hash +hashOfFormula (Sum hash _ _ _) = hash +hashOfFormula (Product hash _ _ _) = hash +hashOfFormula (Derivate hash _ _) = hash +hashOfFormula (Integrate hash _ _ _ _) = hash +hashOfFormula (UnOp hash _ _) = hash +hashOfFormula (Lambda hash _) = hash +hashOfFormula (BinOp hash _ _) = hash +hashOfFormula (Matrix hash _ _ _) = hash +hashOfFormula (Poly hash _) = hash +hashOfFormula (Block _ _ _) = 0 +hashOfFormula (Meta hash _ _) = hash + +listHasher :: [FormulaPrim] -> HashResume +listHasher = foldl' hasher 0 + where hasher acc formula = + (acc `rotateL` 3) `xor` hashOfFormula formula + + +polyCoeffHash :: PolyCoeff -> HashResume +polyCoeffHash (CoeffFloat f) = truncate $ 1000 * f +polyCoeffHash (CoeffInt i) = fromInteger i +polyCoeffHash (CoeffRatio r) = 100 * (fromInteger $ numerator r) + + (fromInteger $ denominator r) + +polynomeHash :: Polynome -> HashResume +polynomeHash (PolyRest p) = polyCoeffHash p +polynomeHash (Polynome var coeffList) = varHash + coeffHash + where varHash = sum $ map fromEnum var + hasher acc (coeff, subPoly) = + (acc `rotateR` 2) `xor` ( polyCoeffHash coeff + + polynomeHash subPoly ) + coeffHash = foldl' hasher 0 coeffList + +app :: FormulaPrim -> [FormulaPrim] -> FormulaPrim +app what lst = App hash what lst + where hash = (1 `shiftL` 3) `xor` (wHash `rotateL` 4) `xor` hashLst + wHash = hashOfFormula what + hashLst = listHasher lst + +summ :: FormulaPrim -> FormulaPrim -> FormulaPrim -> FormulaPrim +summ a b c = Sum hash a b c + where hash = (0xFF `shiftL` 15) + listHasher [a, b, c] + +productt :: FormulaPrim -> FormulaPrim -> FormulaPrim -> FormulaPrim +productt a b c = Product hash a b c + where hash = (0xFF `shiftL` 25) + listHasher [a, b, c] + +derivate :: FormulaPrim -> FormulaPrim -> FormulaPrim +derivate what v = Derivate hash what v + where hash = (0xCA03 `shiftL` 10) + (hashWhat `rotateL` 16) + hashVar + hashWhat = hashOfFormula what + hashVar = hashOfFormula v + +integrate :: FormulaPrim -> FormulaPrim -> FormulaPrim -> FormulaPrim -> FormulaPrim +integrate beg end what var = Integrate hash beg end what var + where hash = 0xF00000F00 + hashSub + hashSub = listHasher [beg, end, what, var] + +lambda :: [([FormulaPrim], FormulaPrim)] -> FormulaPrim +lambda clauses = Lambda hash clauses + where hash = xor 14 + $ foldr (\x acc -> (acc `rotateL` 2) + x) 0 + [listHasher subs + hashOfFormula ap | (subs, ap) <- clauses] + +matrix :: Int -> Int -> [[FormulaPrim]] -> FormulaPrim +matrix n m mlines = Matrix hash n m mlines + where hash = ((n * m) `shiftL` 4) + 0xFF + subHash + subHash = sum $ map listHasher mlines + +poly :: Polynome -> FormulaPrim +poly createdPoly = Poly (polynomeHash createdPoly) createdPoly + +binOp :: BinOperator -> [FormulaPrim] -> FormulaPrim +binOp op lst = BinOp hash op lst + where hash = (4 `xor` (hashOp `shiftL` 2)) + listHasher lst + hashOp = fromEnum op + +unOp :: UnOperator -> FormulaPrim -> FormulaPrim +unOp op sub = UnOp hash op sub + where hash = (5 `xor` (hashOp `shiftL` 4)) + subHash + subHash = hashOfFormula sub + hashOp = fromEnum op + +complex :: (FormulaPrim, FormulaPrim) -> FormulaPrim +complex (re, im) = Complex hash (re, im) + where hash = 7 + reHash + imHash `rotateR` 4 + reHash = hashOfFormula re + imHash = hashOfFormula im + +meta :: MetaOperation -> FormulaPrim -> FormulaPrim +meta op sub = Meta hash op sub + where hash = (6 `xor` (opHash `shiftL` 8)) + (subHash `rotateR` 4) + subHash = hashOfFormula sub + opHash = fromEnum op + +indexes :: FormulaPrim -> [FormulaPrim] -> FormulaPrim +indexes (Indexes _initHash a b) lst = Indexes hash a $ b ++ lst + where hash = 0xAAAAAA `xor` (listHasher $ b ++ lst) + +indexes a b = Indexes hash a b + where hash = 0xAAAAAA `xor` (listHasher b) + +list :: [FormulaPrim] -> FormulaPrim +list lst = List hash lst + where hash = 0xBBBBBB `xor` listHasher lst + +-- | Special binOp declaration used to merge two previous binary +-- operators. Update the hash rather than perform full recalculation. +binOpMerger :: BinOperator -> FormulaPrim -> FormulaPrim -> FormulaPrim +binOpMerger op (BinOp _ op1 lst1) (BinOp _ op2 lst2) + | op == op1 && op == op2 = binOp op $ lst1 ++ lst2 +binOpMerger op (BinOp _ op1 lst1) node2 + | op == op1 = binOp op $ lst1 ++ [node2] +binOpMerger op node1 (BinOp _ op2 lst2) + | op == op2 = binOp op $ node1 : lst2 +binOpMerger op node1 node2 = binOp op [node1, node2] + +-- | Type used to carry some meta information +-- with the type system. +-- - formula Form : how is handled the binop form +newtype Formula formulaForm = Formula { unTagFormula :: FormulaPrim } + deriving (Eq, {-Show,-} Ord) + +-- | Type token for format of the form [a,b,c,d,e...] +data ListForm +-- | Type token for format of the form [a,b] +data TreeForm +-- | Ok the data doesn't have any specific form + +-- | Coefficient for polynoms +data PolyCoeff = + CoeffFloat FloatingValue + | CoeffInt Integer + | CoeffRatio (Ratio Integer) + deriving (Show, Read) + +-- | This type store polynome in a recursive way, as presented +-- in chapter 3 of "Algorithm for Computer Algebra". It's a +-- recursive linked list +data Polynome = + Polynome String [(PolyCoeff, Polynome)] + | PolyRest PolyCoeff + deriving (Eq, Show, Read) + +instance Eq PolyCoeff where + (==) = coeffPredicate (==) + +coeffPredicate :: (forall a. Ord a => a -> a -> Bool) -> PolyCoeff -> PolyCoeff -> Bool +coeffPredicate op c1 c2 = eval $ polyCoeffCast c1 c2 + where eval (CoeffInt i1, CoeffInt i2) = i1 `op` i2 + eval (CoeffFloat f1, CoeffFloat f2) = f1 `op` f2 + eval (CoeffRatio r1, CoeffRatio r2) = r1 `op` r2 + eval _ = error Err.polynom_bad_casting + +-- | polyCoeffCast autocast to the same level +polyCoeffCast :: PolyCoeff -> PolyCoeff -> (PolyCoeff, PolyCoeff) +polyCoeffCast (CoeffInt i1) (CoeffInt i2) = (CoeffInt i1, CoeffInt i2) +polyCoeffCast (CoeffFloat f1) (CoeffFloat f2) = (CoeffFloat f1,CoeffFloat f2) +polyCoeffCast (CoeffRatio r1) (CoeffRatio r2) = (CoeffRatio r1, CoeffRatio r2) +polyCoeffCast (CoeffInt i1) (CoeffRatio r2) = (CoeffRatio $ i1 % 1, CoeffRatio r2) +polyCoeffCast (CoeffRatio r1) (CoeffInt i2) = (CoeffRatio r1, CoeffRatio $ i2 % 1) +polyCoeffCast (CoeffInt i1) (CoeffFloat f2) = (CoeffFloat $ fromInteger i1, CoeffFloat f2) +polyCoeffCast (CoeffFloat f1) (CoeffInt i2) = (CoeffFloat f1, CoeffFloat $ fromInteger i2) +polyCoeffCast (CoeffFloat f1) (CoeffRatio r2) = (CoeffFloat f1, CoeffFloat $ fromRational r2) +polyCoeffCast (CoeffRatio r1) (CoeffFloat f2) = (CoeffFloat $ fromRational r1, CoeffFloat f2) + +infixl 4 <<>> + +(<<>>) :: Ordering -> Ordering -> Ordering +a <<>> b = ordIt a + where ordIt EQ = b + ordIt o = o + +----------------------------------------------------------- +-- Ord def, used to sort-out '+' list for exemples +----------------------------------------------------------- +instance Show (Formula anyForm) where + showsPrec _ (Formula a) = + ("{-"++) + . sexprRenderS (Formula a) + . (++) "-} Formula (" + . shows a . (++) ")" + +instance Ord PolyCoeff where + compare left right = case polyCoeffCast left right of + (CoeffInt a, CoeffInt b) -> compare a b + (CoeffFloat a, CoeffFloat b) -> compare a b + (CoeffRatio a, CoeffRatio b) -> compare a b + _ -> error "Bad cast" + +instance Ord Polynome where + compare (PolyRest a) (PolyRest b) = compare a b + compare (Polynome v1 c1) (Polynome v2 c2) + | v1 /= v2 = compare v1 v2 + | otherwise = case compare coeff1 coeff2 of + EQ -> compare sub1 sub2 + a -> a + where (coeff1, sub1) = last c1 + (coeff2, sub2) = last c2 + compare (Polynome _ _) _ = LT + compare _ (Polynome _ _) = GT + +instance Ord FormulaPrim where + -- Ignoring meta in comparisons + compare (Meta _ _ f) f2 = compare f f2 + compare f (Meta _ _ f2) = compare f f2 + + compare (NumEntity e1) (NumEntity e2) = compare e1 e2 + compare (UnOp _ _ f1) (UnOp _ _ f2) = compare f1 f2 + + compare (CInteger i) (CInteger i2) = compare i i2 + compare (CFloat f) (CFloat f2) = compare f f2 + compare (CInteger i) (CFloat f) = compare (fromIntegral i) f + compare (CFloat f) (CInteger i) = compare f $ fromIntegral i + compare (CFloat _) _ = LT + compare (CInteger _) _ = LT + + compare (Poly _ p1) (Poly _ p2) = compare p1 p2 + compare (Poly _ _) _ = LT + compare _ (Poly _ _) = GT + + -- x < y + compare (Variable v) (Variable v1) = compare v v1 + -- Variable last + compare (Variable _) _ = LT + + compare _ (CInteger _) = GT + compare _ (CFloat _) = GT + compare _ (Block _ _ _) = LT + compare _ (NumEntity _) = GT + + -- we don't sort matrixes, because the mul + compare (Matrix _ _ _ _) (Matrix _ _ _ _) = EQ + compare _ (Matrix _ _ _ _) = LT + compare (Matrix _ _ _ _) _ = LT + + compare (BinOp _ OpPow [Variable v1, p1]) + (BinOp _ OpPow [Variable v2, p2]) + | p1 == p2 = compare v1 v2 + | otherwise = compare p1 p2 + + compare (BinOp _ OpPow a) (BinOp _ OpPow b) = + case comparing length a b of + LT -> LT + EQ -> foldl' (\acc (a', b') -> acc <<>> compare a' b') EQ $ zip a b + GT -> GT + + compare (BinOp _ OpPow _) _ = GT + compare _ (BinOp _ OpPow _) = LT + + compare (BinOp _ op (BinOp _ OpPow (Variable v1: p1: _):_)) + (BinOp _ op' (BinOp _ OpPow (Variable v2: p2: _):_)) + | op == op' && v1 == v2 && op `elem` [OpMul, OpDiv] = compare p1 p2 + + compare (BinOp _ op (_:(BinOp _ OpPow (Variable v1: p1: _):_))) + (BinOp _ op' (_:(BinOp _ OpPow (Variable v2: p2: _):_))) + | op == op' && v1 == v2 && op `elem` [OpMul, OpDiv] = compare p1 p2 + + compare (BinOp _ _ f1) (BinOp _ _ f2) = compare f1 f2 + + compare (Derivate _ w _) (Derivate _ w' _) = compare w w' + compare (Derivate _ _ _) (Integrate _ _ _ _ _) = LT + compare (Derivate _ _ _) _ = GT + + compare (Integrate _ _ _ w _) (Integrate _ _ _ w' _) = compare w w' + compare (Integrate _ _ _ _ _) _ = GT + compare (Product _ l h w) (Product _ l' h' w') = + compare l l' <<>> compare h h' <<>> compare w w' + compare (Product _ _ _ _) _ = GT + + compare (Sum _ l h w) (Sum _ l' h' w') = + compare l l' <<>> compare h h' <<>> compare w w' + compare (Sum _ _ _ _) _ = GT + + compare (App _ _ _) _ = LT + + compare (Block _ _ _) _ = GT + compare (NumEntity _) _ = LT + compare f1 f2 = comparing nodeCount f1 f2 + where nodeCount = getSum . foldf + (\_ a -> Monoid.Sum $ getSum a + 1) + (Monoid.Sum 0 :: Monoid.Sum Int) + +----------------------------------------------------------- +-- Side Associativity +----------------------------------------------------------- +-- | Used to retrieve association property of operators. +-- It's only a type token +data AssocSide = AssocSide + deriving (Eq) + +-- | The implementation of property operators +data OpAssoc = OpAssocLeft | OpAssocRight + deriving (Eq, Show) + +-- | Help to query operator associativity +instance Property BinOperator AssocSide OpAssoc where + getProps OpLazyAttrib = [(AssocSide, OpAssocRight)] + getProps OpAttrib = [(AssocSide, OpAssocRight)] + getProps OpEq = [(AssocSide, OpAssocRight)] + getProps OpCons = [(AssocSide, OpAssocRight)] + getProps _ = [(AssocSide, OpAssocLeft)] + +----------------------------------------------------------- +-- General operator property +----------------------------------------------------------- +-- | Some use full informations which can be used for$ +-- transformation based on operators. Distributivity +-- is handled elsewhere because we need to specify which +-- operator we can distribute uppon. +data OpProp = Associativ -- ^ if (a . b) . c <=> a . (b . c) + | Commutativ -- ^ if a . b = b . a + | Distributiv -- ^ if a . (b ! c) <=> a . b ! a . c + -- /!\ must check on what it is distributiv + | InverseOp -- ^ Inverse operation + deriving (Eq, Show) + +emptyProps :: e -> [p] -> [(p,e)] +emptyProps = map . flip (,) + +instance Property BinOperator OpProp BinOperator where + getProps OpEq = [] + + getProps OpAnd = [] + getProps OpOr = [] + getProps OpNe = [] + getProps OpLe = [] + getProps OpGe = [] + getProps OpLt = [] + getProps OpGt = [] + + getProps OpPow = [] + getProps OpAttrib = [] + getProps OpCons = [] + getProps OpLazyAttrib = [] + + getProps OpSub = [(InverseOp, OpAdd)] + getProps OpAdd = + (InverseOp, OpSub) : emptyProps OpAdd [Associativ, Commutativ] + getProps OpMul = + (InverseOp, OpDiv) : emptyProps OpMul [Associativ, Commutativ, Distributiv] + getProps OpDiv = + (InverseOp, OpMul) : emptyProps OpDiv [Distributiv] + +canDistributeOver :: BinOperator -> BinOperator -> Bool +canDistributeOver op1 = (`elem` distributeOver op1) + +distributeOver :: BinOperator -> [BinOperator] +distributeOver OpMul = [OpAdd, OpSub] +distributeOver OpDiv = [OpAdd, OpSub] +distributeOver OpOr = [OpAnd] +distributeOver _ = [] + +----------------------------------------------------------- +-- Priority Property +----------------------------------------------------------- +data Priority = Priority deriving Eq + +instance Property BinOperator Priority Int where + getProps op = [(Priority, first. fromJust $ lookup op binopDefs)] + where first (f,_,_) = f + +instance Property UnOperator Priority Int where + getProps OpFactorial = [(Priority, 0)] + getProps OpNegate = [(Priority, 1)] + getProps OpExp = [(Priority, 2)] + getProps _ = [(Priority, 1000)] + +----------------------------------------------------------- +-- Leaf Property +----------------------------------------------------------- +data LeafNode = LeafNode deriving Eq + +instance Property FormulaPrim LeafNode Bool where + getProps (Variable _) = [(LeafNode, True)] + getProps (CInteger _) = [(LeafNode, True)] + getProps (CFloat _) = [(LeafNode, True)] + getProps (NumEntity _) = [(LeafNode, True)] + getProps _ = [(LeafNode, False)] + + hasProp (Variable _) _ = True + hasProp (CInteger _) _ = True + hasProp (CFloat _) _ = True + hasProp (NumEntity _) _ = True + hasProp _ _ = False + +----------------------------------------------------------- +-- Text +----------------------------------------------------------- +data OperatorText = OperatorText deriving Eq + +instance Property UnOperator OperatorText String where + getProps op = [(OperatorText, fromJust $ lookup op unOpNames)] + +-- | Priority and textual representation +-- of binary operators +binopDefs :: [(BinOperator, (Int, String, String))] +binopDefs = + [ (OpAttrib, (8, ":=", "Attribution operator")) + , (OpLazyAttrib, (8, ":>", "Lazy attribution operator")) + , (OpCons,(7, "::", "List appending operator")) + , (OpAnd, (6, "&", "Logical and operator")) + , (OpOr, (6, "|", "Logical or operator")) + , (OpEq, (5, "=", "Equality operator")) + , (OpNe, (5, "/=", "Different operator")) + , (OpLt, (5, "<" , "Lower than operator")) + , (OpGt, (5, ">" , "Greater than operator")) + , (OpGe, (5, ">=", "Greater or equal operator")) + , (OpLe, (5, "<=", "Lower or equal operator")) + , (OpAdd, (4, "+", "Addition operator")) + , (OpSub, (4, "-", "Substraction operator")) + , (OpMul, (3, "*", "Multiplication operator")) + , (OpDiv, (3, "/", "Division/fraction operator")) + , (OpPow, (2, "^", "Power operator")) + ] + +binopString :: BinOperator -> String +binopString a = second . fromJust $ lookup a binopDefs + where second (_, s, _) = s + +unopString :: UnOperator -> String +unopString a = fromJust $ lookup a unOpNames + +realUnopOperators :: [(UnOperator, String, String)] +realUnopOperators = [ (OpNegate, "-", "Negation operator, put it before expression (-x)") + , (OpFactorial, "!", "Factorial operator, put it after expression (x!)") + ] + +-- | Textual representation of "unary" operators +unOpNames :: [(UnOperator, String)] +unOpNames = [ (op, reprez) | (op, reprez,_) <- realUnopOperators] ++ + [ (OpAbs, "abs") + , (OpSqrt, "sqrt") + + , (OpSin, "sin") + , (OpASin, "asin") + , (OpSinh, "sinh") + , (OpASinh, "asinh") + + , (OpCos, "cos") + , (OpACos, "acos") + , (OpCosh, "cosh") + , (OpACosh, "acosh") + + , (OpTan, "tan") + , (OpATan, "atan") + , (OpTanh, "tanh") + , (OpATanh, "atanh") + + , (OpLn, "ln") + , (OpLog, "log") + + , (OpExp, "exp") + , (OpCeil, "ceil") + , (OpFloor, "floor") + , (OpFrac, "frac") + ] + +------------------------------------------- +---- Formula Folding +------------------------------------------- +foldf :: (Monoid b) + => (FormulaPrim -> b -> b) -> b -> FormulaPrim -> b +foldf f acc m@(Meta _ _ fo) = f m $ foldf f acc fo +foldf f acc fo@(UnOp _ _ sub) = f fo $ foldf f acc sub +foldf f acc fo@(App _ def args) = + f fo (foldf f listAcc def) + where listAcc = foldr f acc args + +foldf f acc fo@(BinOp _ _ args) = + f fo $ foldr f acc args + +foldf f acc fo@(Sum _ ini end what) = f fo finalAcc + where whatAcc = foldf f acc what + iniAcc = foldf f acc ini + endAcc = foldf f acc end + finalAcc = whatAcc `mappend` iniAcc `mappend` endAcc + +foldf f acc fo@(Product _ ini end what) = f fo finalAcc + where whatAcc = foldf f acc what + iniAcc = foldf f acc ini + endAcc = foldf f acc end + finalAcc = whatAcc `mappend` iniAcc `mappend` endAcc + +foldf f acc fo@(Integrate _ ini end what var) = f fo finalAcc + where whatAcc = foldf f acc what + iniAcc = foldf f acc ini + endAcc = foldf f acc end + varAcc = foldf f acc var + finalAcc = whatAcc `mappend` iniAcc + `mappend` endAcc `mappend` varAcc + +foldf f acc fo@(Derivate _ what var) = f fo $ whatAcc `mappend` varAcc + where whatAcc = foldf f acc what + varAcc = foldf f acc var + +foldf f acc fo@(Matrix _ _ _ cells) = f fo finalAcc + where lineFolder acc' formu = acc' `mappend` foldf f acc formu + rowAccs = [ foldl' lineFolder mempty row | row <- cells] + finalAcc = foldl1' mappend rowAccs + +foldf f acc fo = f fo acc + +---------------------------------------- +---- Strong and valid instances ---- +---------------------------------------- +instance Num FormulaPrim where + (+) = binOpMerger OpAdd + (-) = binOpMerger OpSub + (*) = binOpMerger OpMul + negate = unOp OpNegate + abs = unOp OpAbs + signum (CInteger n) = CInteger (signum n) + signum (CFloat f) = CFloat (signum f) + signum _ = CInteger 0 + fromInteger = CInteger . fromInteger + +instance Fractional FormulaPrim where + (/) = binOpMerger OpDiv + recip b = binOp OpDiv [CInteger 1, b] + fromRational a = binOp OpDiv [ int $ numerator a + , int $ denominator a] + where int = CInteger . fromInteger + +instance Floating FormulaPrim where + pi = CFloat pi + exp = unOp OpExp + sqrt = unOp OpSqrt + log = unOp OpLn + (**) = binOpMerger OpPow + sin = unOp OpSin + cos = unOp OpCos + tan = unOp OpTan + asin = unOp OpASin + acos = unOp OpACos + atan = unOp OpATan + sinh = unOp OpSinh + cosh = unOp OpCosh + tanh = unOp OpTanh + asinh = unOp OpASinh + acosh = unOp OpACosh + atanh = unOp OpATanh + diff --git a/EqManips/Types.hs-boot b/EqManips/Types.hs-boot new file mode 100644 --- /dev/null +++ b/EqManips/Types.hs-boot @@ -0,0 +1,7 @@ +module EqManips.Types where + +data Formula a +data ListForm +data PolyCoeff +data Polynome + diff --git a/EqManips/UnicodeSymbols.hs b/EqManips/UnicodeSymbols.hs new file mode 100644 --- /dev/null +++ b/EqManips/UnicodeSymbols.hs @@ -0,0 +1,645 @@ +module EqManips.UnicodeSymbols where + +varAssoc :: [(String, String)] +varAssoc = map (\(v, i) -> (v, [toEnum i])) + [ ("alpha", alpha) + , ("beta", beta) + , ("chi", chi) + , ("gamma", gamma) + , ("delta", delta) + , ("theta", theta) + , ("rho" , rho) + , ("phi", phi) + , ("tau", tau) + , ("omega", omega) + , ("lambda", lambda) + , ("sigma", sigma) + , ("mu", mu) + , ("psi", psi) + , ("pi", EqManips.UnicodeSymbols.pi) + , ("infinity", infinity) + ] + +midlineDots :: Int +midlineDots = 0x22EF {- ⋯ -} + +------------------------------------ +-- Miscellaneou mathematical symbols +------------------------------------ +forAll :: Int +forAll = 0x2200 {- ∀ -} + +exist :: Int +exist = 0x2203 {- ∃ -} + +notExist :: Int +notExist = 0x2204 {- ∄ -} + +empty :: Int +empty = 0x2205 {- ∅ -} + +increment :: Int +increment = 0x2206 {- ∆ -} + +nabla :: Int +nabla = 0x2207 {- ∇ -} + +----------------------------------- +-- Set membership +----------------------------------- +elementof :: Int +elementof = 0x2208 {- ∈ -} + +notelementof :: Int +notelementof = 0x2209 {- ∉ -} + +smallelementof :: Int +smallelementof = 0x220A {- ∊ -} + +contains :: Int +contains = 0x220b {- ∋ -} + +smallcontains :: Int +smallcontains = 0x220D {- ∍ -} + + +----------------------------------- +-- N-ary operators +---------------------------------- +product :: Int +product = 0x220F {- ∏ -} + +coproduct :: Int +coproduct = 0x2210 {- ∐ -} + +sum :: Int +sum = 0x2211 {- ∑ -} + + +----------------------------------- +-- Simple operators +----------------------------------- +minus :: Int +minus = 0x2212 {- − -} + +multiplicationSign :: Int +multiplicationSign = 0x00D7 {- × -} + +minusorplus :: Int +minusorplus = 0x2213 {- ∓ -} + +dotplus :: Int +dotplus = 0x2214 {- ∔ -} + +divsplash :: Int +divsplash = 0x2215 {- ∕ -} + +setminus :: Int +setminus = 0x2216 {- ∖ -} + +asterisk :: Int +asterisk = 0x2217 {- ∗ -} + +ring :: Int +ring = 0x2218 {- ∘ -} + +bullet :: Int +bullet = 0x2219 {- ∙ -} + +squareroot :: Int +squareroot = 0x221A {- √ -} + +cuberoot :: Int +cuberoot = 0x221B {- ∛ -} + +fouthroot :: Int +fouthroot = 0x221C {- ∜ -} + +proportionalto :: Int +proportionalto = 0x221D {- ∝ -} + + + +----------------------------------- +-- Miscellaneous math symbols +----------------------------------- +infinity :: Int +infinity = 0x221E {- ∞ -} + +rightangle :: Int +rightangle = 0x221F {- ∟ -} + +angle :: Int +angle = 0x2220 {- ∠ -} + +measuredangle :: Int +measuredangle = 0x2221 {- ∡ -} + +sphericalangle :: Int +sphericalangle = 0x2222 {- ∢ -} + + +----------------------------------- +-- Operators 2 the return +----------------------------------- +divides :: Int +divides = 0x2223 {- ∣ -} + +doesntdivide :: Int +doesntdivide = 0x2224 {- ∤ -} + +parrallelto :: Int +parrallelto = 0x2225 {- ∥ -} + +unparallelto :: Int +unparallelto = 0x2226 {- ∦ -} + +-------------------------------------------------- +---- Weird letters +-------------------------------------------------- +doubleStruckItalicSmalld :: Int +doubleStruckItalicSmalld = 0x2146 + +----------------------------------- +-- Logical and sets operators +----------------------------------- +logicalNot :: Int +logicalNot = 0x00AC {- ¬ -} + +logicalAnd :: Int +logicalAnd = 0x2227 {- ∧ -} + +logicalOr :: Int +logicalOr = 0x2228 {- ∨ -} + +intersection :: Int +intersection = 0x2229 {- ∩ -} + +union :: Int +union = 0x222A {- ∪ -} + + + +----------------------------------- +-- Integrals +----------------------------------- +integral :: Int +integral = 0x222B {- ∫ -} + +integralDouble :: Int +integralDouble = 0x222C {- ∬ -} + +integralTriple :: Int +integralTriple = 0x222D {- ∭ -} + +contourIntegral :: Int +contourIntegral = 0x222E {- ∮ -} + +surfaceIntegral :: Int +surfaceIntegral = 0x222F {- ∯ -} + +volumeIntegral :: Int +volumeIntegral = 0x2230 {- ∰ -} + +clockwiseIntegral :: Int +clockwiseIntegral = 0x2231 {- ∱ -} + +clockwiseCountourIntegral :: Int +clockwiseCountourIntegral = 0x2232 {- ∲ -} + +anticlockWiseContourIntegral :: Int +anticlockWiseContourIntegral = 0x2233 {- ∳ -} + + +-- Misc math symbols +therefor :: Int +therefor = 0x2234 {- ∴ -} + +because :: Int +because = 0x2235 {- ∵ -} + + +-- Relatioons +ratio :: Int +ratio = 0x2236 {- ∶ -} + + +proportion :: Int +proportion = 0x2237 {- ∷ -} + + +-- operator +dotMinus :: Int +dotMinus = 0x2238 {- ∸ -} + + +-- Relation +excess :: Int +excess = 0x2239 {- ∹ -} + + +-- Operator +geometricProportion :: Int +geometricProportion = 0x223A {- ∺ -} + + +----------------------------------- +-- Relations +----------------------------------- +homothetic :: Int +homothetic = 0x223B {- ∻ -} + +tilde :: Int +tilde = 0x223C {- ∼ -} + +reversedTilde :: Int +reversedTilde = 0x223D {- ∽ -} + +invertedLazys :: Int +invertedLazys = 0x223E {- ∾ -} + + +-- Misc math symbol +sineWave :: Int +sineWave = 0x223F {- ∿ -} + + +-- Operator +wreathProduct :: Int +wreathProduct = 0x2240 {- ≀ -} + +notTilde :: Int +notTilde = 0x2241 {- ≁ -} + +minusTilde :: Int +minusTilde = 0x2242 {- ≂ -} + +asymEqualTo :: Int +asymEqualTo = 0x2243 {- ≃ -} + +notAsymEqualTo :: Int +notAsymEqualTo = 0x2244 {- ≄ -} + +aproxEqualTo :: Int +aproxEqualTo = 0x2245 {- ≅ -} + +aproxButNotEqualTo :: Int +aproxButNotEqualTo = 0x2246 {- ≆ -} + +neitherAproxNorEqual :: Int +neitherAproxNorEqual = 0x2247 {- ≇ -} + +almostEqual :: Int +almostEqual = 0x2248 {- ≈ -} + +notAlmostEqual :: Int +notAlmostEqual = 0x2249 {- ≉ -} + +almostEqualorEqual :: Int +almostEqualorEqual = 0x224A {- ≊ -} + +tripleTilde :: Int +tripleTilde = 0x224B {- ≋ -} + +allEqualTo :: Int +allEqualTo = 0x224C {- ≌ -} + +equavalent :: Int +equavalent = 0x224D {- ≍ -} + +geomEquiv :: Int +geomEquiv = 0x224E {- ≎ -} + +diffBetween :: Int +diffBetween = 0x224F {- ≏ -} + +approachLimit :: Int +approachLimit = 0x2250 {- ≐ -} + +geomEqual :: Int +geomEqual = 0x2251 {- ≑ -} + +aproxEqual :: Int +aproxEqual = 0x2252 {- ≒ -} + +imageOf :: Int +imageOf = 0x2253 {- ≓ -} + +colonEquals :: Int +colonEquals = 0x2254 {- ≔ -} + +equalsColon :: Int +equalsColon = 0x2255 {- ≕ -} + +ringInEqual :: Int +ringInEqual = 0x2256 {- ≖ -} + +ringEqualTo :: Int +ringEqualTo = 0x2257 {- ≗ -} + +correspondsTo :: Int +correspondsTo = 0x2258 {- ≘ -} + +estimates :: Int +estimates = 0x2259 {- ≙ -} + +equiangularTo :: Int +equiangularTo = 0x225A {- ≚ -} + +starEquals :: Int +starEquals = 0x225B {- ≛ -} + +deltaEqual :: Int +deltaEqual = 0x225C {- ≜ -} + +equalByDef :: Int +equalByDef = 0x225D {- ≝ -} + +measuredBy :: Int +measuredBy = 0x225E {- ≞ -} + +questionedEqualTo :: Int +questionedEqualTo = 0x225F {- ≟ -} + +notEqualTo :: Int +notEqualTo = 0x2260 {- ≠ -} + +identicalTo :: Int +identicalTo = 0x2261 {- ≡ -} + +notIdenticalTo :: Int +notIdenticalTo = 0x2262 {- ≢ -} + +strictlyEquivalentTo :: Int +strictlyEquivalentTo = 0x2263 {- ≣ -} + +lessThanOrEqualTo :: Int +lessThanOrEqualTo = 0x2264 {- ≤ -} + +greaterThanOrEqualTo :: Int +greaterThanOrEqualTo = 0x2265 {- ≥ -} + +lessThanOverEqualTo :: Int +lessThanOverEqualTo = 0x2266 {- ≦ -} + +greaterThanOverEqualTo :: Int +greaterThanOverEqualTo = 0x2267 {- ≧ -} + +lessThanButNotEqual :: Int +lessThanButNotEqual = 0x2268 {- ≨ -} + +greaterThanButnotEqualTo :: Int +greaterThanButnotEqualTo = 0x2269 {- ≩ -} + +muchLessThan :: Int +muchLessThan = 0x226A {- ≪ -} + +muchGreaterThan :: Int +muchGreaterThan = 0x226B {- ≫ -} + +between :: Int +between = 0x226C {- ≬ -} + +notEquivalentTo :: Int +notEquivalentTo = 0x226D {- ≭ -} + +notLessThan :: Int +notLessThan = 0x226E {- ≮ -} + +notGreaterThan :: Int +notGreaterThan = 0x226F {- ≯ -} + +neitherLessThanNorEqualTo :: Int +neitherLessThanNorEqualTo = 0x2270 {- ≰ -} + +subset :: Int +subset = 0x2282 {- ⊂ -} + +superset :: Int +superset = 0x2283 {- ⊃ -} + +notASubset :: Int +notASubset = 0x2284 {- ⊄ -} + +notASuperset :: Int +notASuperset = 0x2285 {- ⊅ -} + +subsetOrEqualTo :: Int +subsetOrEqualTo = 0x2286 {- ⊆ -} + +superSetOrEqual :: Int +superSetOrEqual = 0x2287 {- ⊇ -} + +neitherSubsetNorEqual :: Int +neitherSubsetNorEqual = 0x2288 {- ⊈ -} + +neitherSupersetNorEqual :: Int +neitherSupersetNorEqual = 0x2289 {- ⊉ -} + +subsetWithNotEqual :: Int +subsetWithNotEqual = 0x228A {- ⊊ -} + +supersetofWithNotEqual :: Int +supersetofWithNotEqual = 0x228B {- ⊋ -} + +-- operators +multiset :: Int +multiset = 0x228C {- ⊌ -} + +multisetMult :: Int +multisetMult = 0x228D {- ⊍ -} + +multisetUnion :: Int +multisetUnion = 0x228E {- ⊎ -} + + +-- greek letters +alpha :: Int +alpha = 0x03B1 {- α -} + +beta :: Int +beta = 0x03B2 {- β -} + +chi :: Int +chi = 0x03C7 {- χ -} + +gamma :: Int +gamma = 0x3B3 {- γ -} + +delta :: Int +delta = 0x03B4 {- δ -} + +epslion :: Int +epslion = 0x03B6 {- ε -} + +theta :: Int +theta = 0x3B8 {- θ -} + +pi :: Int +pi = 0x03C0 {- π -} + +rho :: Int +rho = 0x03C1 {- ρ -} + +phi :: Int +phi = 0x03C6 {- φ -} + +tau :: Int +tau = 0x03C4 {- τ -} + +omega :: Int +omega = 0x03C9 {- ω -} + +lambda :: Int +lambda = 0x03BB {- λ -} + +sigma :: Int +sigma = 0x03C3 {- σ -} + +mu :: Int +mu = 0x03BC {- μ -} + +psi :: Int +psi = 0x03C8 {- ψ -} + +xor :: Int +xor = 0x22BB {- ⊻ -} + + +-- Relation +{- + = 0x228F {- ⊏ -} + = 0x2290 {- ⊐ -} + = 0x2291 {- ⊑ -} + = 0x2292 {- ⊒ -} + = 0x2293 {- ⊓ -} + = 0x2294 {- ⊔ -} + = 0x2295 {- ⊕ -} + = 0x2296 {- ⊖ -} + = 0x2297 {- ⊗ -} + = 0x2298 {- ⊘ -} + = 0x2299 {- ⊙ -} + = 0x229A {- ⊚ -} + = 0x229B {- ⊛ -} + = 0x229C {- ⊜ -} + = 0x229D {- ⊝ -} + = 0x229E {- ⊞ -} + = 0x229F {- ⊟ -} + = 0x22A0 {- ⊠ -} + = 0x22A1 {- ⊡ -} + = 0x22A2 {- ⊢ -} + = 0x22A3 {- ⊣ -} + = 0x22A4 {- ⊤ -} + = 0x22A5 {- ⊥ -} + = 0x22A6 {- ⊦ -} + = 0x22A7 {- ⊧ -} + = 0x22A8 {- ⊨ -} + = 0x22A9 {- ⊩ -} + = 0x22AA {- ⊪ -} + = 0x22AB {- ⊫ -} + = 0x22AC {- ⊬ -} + = 0x22AD {- ⊭ -} + = 0x22AE {- ⊮ -} + = 0x22AF {- ⊯ -} + = 0x22B0 {- ⊰ -} + = 0x22B1 {- ⊱ -} + = 0x22B2 {- ⊲ -} + = 0x22B3 {- ⊳ -} + = 0x22B4 {- ⊴ -} + = 0x22B5 {- ⊵ -} + = 0x22B6 {- ⊶ -} + = 0x22B7 {- ⊷ -} + = 0x22B8 {- ⊸ -} + = 0x22B9 {- ⊹ -} + = 0x22BA {- ⊺ -} + = 0x22BC {- ⊼ -} + = 0x22BD {- ⊽ -} + = 0x22BE {- ⊾ -} + = 0x22BF {- ⊿ -} + = 0x22C0 {- ⋀ -} + = 0x22C1 {- ⋁ -} + = 0x22C2 {- ⋂ -} + = 0x22C3 {- ⋃ -} + = 0x22C4 {- ⋄ -} + = 0x22C5 {- ⋅ -} + = 0x22C6 {- ⋆ -} + = 0x22C7 {- ⋇ -} + = 0x22C8 {- ⋈ -} + = 0x22C9 {- ⋉ -} + = 0x22CA {- ⋊ -} + = 0x22CB {- ⋋ -} + = 0x22CC {- ⋌ -} + = 0x22CD {- ⋍ -} + = 0x22CE {- ⋎ -} + = 0x22CF {- ⋏ -} + = 0x22D0 {- ⋐ -} + = 0x22D1 {- ⋑ -} + = 0x22D2 {- ⋒ -} + = 0x22D3 {- ⋓ -} + = 0x22D4 {- ⋔ -} + = 0x22D5 {- ⋕ -} + = 0x22D6 {- ⋖ -} + = 0x22D7 {- ⋗ -} + = 0x22D8 {- ⋘ -} + = 0x22D9 {- ⋙ -} + = 0x22DA {- ⋚ -} + = 0x22DB {- ⋛ -} + = 0x22DC {- ⋜ -} + = 0x22DD {- ⋝ -} + = 0x22DE {- ⋞ -} + = 0x22DF {- ⋟ -} + = 0x22E0 {- ⋠ -} + = 0x22E1 {- ⋡ -} + = 0x22E2 {- ⋢ -} + = 0x22E3 {- ⋣ -} + = 0x22E4 {- ⋤ -} + = 0x22E5 {- ⋥ -} + = 0x22E6 {- ⋦ -} + = 0x22E7 {- ⋧ -} + = 0x22E8 {- ⋨ -} + = 0x22E9 {- ⋩ -} + = 0x22EA {- ⋪ -} + = 0x22EB {- ⋫ -} + = 0x22EC {- ⋬ -} + = 0x22ED {- ⋭ -} + = 0x22EE {- ⋮ -} + = 0x22EF {- ⋯ -} + = 0x22F0 {- ⋰ -} + = 0x22F1 {- ⋱ -} + = 0x22F2 {- ⋲ -} + = 0x22F3 {- ⋳ -} + = 0x22F4 {- ⋴ -} + = 0x22F5 {- ⋵ -} + = 0x22F6 {- ⋶ -} + = 0x22F7 {- ⋷ -} + = 0x22F8 {- ⋸ -} + = 0x22F9 {- ⋹ -} + = 0x22FA {- ⋺ -} + = 0x22FB {- ⋻ -} + = 0x22FC {- ⋼ -} + = 0x22FD {- ⋽ -} + = 0x22FE {- ⋾ -} + = 0x22FF {- ⋿ -} +-} +{- +Dump for others chars, to lazy to prepare them + = 0x2271 {- ≱ -} + = 0x2272 {- ≲ -} + = 0x2273 {- ≳ -} + = 0x2274 {- ≴ -} + = 0x2275 {- ≵ -} + = 0x2276 {- ≶ -} + = 0x2277 {- ≷ -} + = 0x2278 {- ≸ -} + = 0x2279 {- ≹ -} + = 0x227A {- ≺ -} + = 0x227B {- ≻ -} + = 0x227C {- ≼ -} + = 0x227D {- ≽ -} + = 0x227E {- ≾ -} + = 0x227F {- ≿ -} + = 0x2280 {- ⊀ -} + = 0x2281 {- ⊁ -} + + --} + diff --git a/Repl.hs b/Repl.hs new file mode 100644 --- /dev/null +++ b/Repl.hs @@ -0,0 +1,59 @@ +module Repl( repl ) where + +import qualified Data.Map as Map + +import EqManips.Algorithm.Utils +import EqManips.Types +import EqManips.Renderer.Ascii +import EqManips.Renderer.RenderConf +import EqManips.BaseLibrary +import EqManips.InputParser.EqCode +import EqManips.EvaluationContext + +import System.IO + +type Context = Map.Map String (Formula ListForm) +type Evaluator = Formula ListForm -> EqContext (Formula ListForm) + +repl :: Evaluator -> IO () +repl evaluator = do + putStrLn "Eq - interactive mode" + putStrLn "exit to quit the program\n" + doer (Just defaultSymbolTable) + + where doer (Just c) = evalExpr evaluator c >>= doer + doer Nothing = return () + +printErrors :: [(Formula TreeForm, String)] -> IO () +printErrors = + mapM_ (\(f,s) -> do putStrLn s + putStrLn $ formatFormula defaultRenderConf f) + +parseErrorPrint :: (Show a) => b -> a -> IO b +parseErrorPrint c err = do + putStr "Error : " + putStr $ show err + return c + +evalExpr :: Evaluator -> Context -> IO (Maybe Context) +evalExpr operation prevContext = do + putStr "> " + hFlush stdout + exprText <- getLine + case exprText of + [] -> evalExpr operation prevContext + "exit" -> return Nothing + _ -> do + let formulaList = parseProgramm exprText + either (parseErrorPrint (Just prevContext)) + (\formulal -> do + let rez = performLastTransformationWithContext prevContext + $ mapM operation formulal + + printErrors $ errorList rez + putStr . formatFormula defaultRenderConf + . treeIfyFormula $ result rez + return . Just $ context rez + ) + formulaList + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + +main = defaultMain + diff --git a/formulaMain.hs b/formulaMain.hs new file mode 100644 --- /dev/null +++ b/formulaMain.hs @@ -0,0 +1,327 @@ +import EqManips.Types +import EqManips.Algorithm.Utils +import EqManips.Algorithm.Cleanup +import EqManips.Renderer.Ascii +import EqManips.Renderer.Latex +import EqManips.Renderer.Mathml +import EqManips.Renderer.RenderConf + +#ifdef _DEBUG +import EqManips.Renderer.Sexpr +#endif + +import Control.Monad + +import System.Environment +import System.Exit +import System.IO +import qualified System.IO as Io + +import System.Console.GetOpt + +import Data.List( find, intersperse ) +import Data.Maybe( fromMaybe ) + +import qualified Data.Map as Map + +-- Just to be able to compile... +import EqManips.Algorithm.Eval +import EqManips.EvaluationContext +import EqManips.Preprocessor +import EqManips.Linker +import EqManips.BaseLibrary +import EqManips.InputParser.MathML +import EqManips.InputParser.EqCode + +import Repl + +-- Debugging +{-import EqManips.Renderer.CharRender-} + +data Flag = + Output + | Input + | Unicode + | SupportedFunction + | SupportedOperators + | SupportedPreprocLanguages + deriving Eq + +version :: String +version = "1.0" + +commonOption :: [OptDescr (Flag, String)] +commonOption = + [ Option "o" ["output"] (ReqArg ((,) Output) "FILE") "output FILE" + , Option "f" ["file"] (ReqArg ((,) Input) "FILE") "input FILE, use - for stdin" + , Option "u" ["unicode"] (NoArg (Unicode, "")) "Output with unicode character set" + ] + +askingOption :: [OptDescr (Flag, String)] +askingOption = + [ Option "" ["functions"] (NoArg (SupportedFunction,"")) + "Ask for defined function list" + , Option "" ["operators"] (NoArg (SupportedOperators,"")) + "Ask for defined operator list" + , Option "" ["languages"] (NoArg (SupportedPreprocLanguages,"")) + "Ask for supported languages for the preprocessor" + ] + +preprocOptions :: [OptDescr (Flag, String)] +preprocOptions = commonOption + +formatOption :: [OptDescr (Flag, String)] +formatOption = commonOption + +-- | Helper function to get file names for input/output +getInputOutput :: [(Flag, String)] -> [String] -> (IO String, IO Handle) +getInputOutput opts args = ( inputFile + , do o <- outputFile + hSetEncoding o utf8 + return o) + where outputFile = maybe (return stdout) (flip openFile WriteMode) + (lookup Output opts) + + inputFile = maybe (return $ head args) infiler + (lookup Input opts) + + infiler "-" = Io.hGetContents stdin + infiler f = Io.readFile f + +filterCommand :: (String -> String) -> [String] -> IO Bool +filterCommand transformator args = do + text <- input + output <- outputFile + Io.putStr text + Io.putStr "==========================================\n" + Io.hPutStrLn output $ transformator text + Io.putStr "==========================================\n\n" + hClose output + return True + where (opt, left, _) = getOpt Permute formatOption args + (input, outputFile) = getInputOutput opt left + +-- | Command which just format an equation +-- without affecting it's form. +formatCommand :: (Conf -> Formula TreeForm -> String) -> [String] -> IO Bool +formatCommand formulaFormater args = do + formulaText <- input + let formula = perfectParse formulaText + output <- outputFile + either (parseErrorPrint output) + (\formula' -> do + Io.hPutStrLn output . formulaFormater conf $ treeIfyFormula formula' + hClose output + return True) + formula + where (opt, left, _) = getOpt Permute formatOption args + (input, outputFile) = getInputOutput opt left + conf = defaultRenderConf{ useUnicode = Unicode `lookup` opt /= Nothing } + +printErrors :: [(Formula TreeForm, String)] -> IO () +printErrors = + mapM_ (\(f,s) -> do Io.putStrLn s + Io.putStrLn $ formatFormula defaultRenderConf f) + +parseErrorPrint :: (Show a) => Handle -> a -> IO Bool +parseErrorPrint finalFile err = do + Io.hPutStr finalFile "Error : " + Io.hPutStr finalFile $ show err + hClose finalFile + return False + +-- | Give the user some information about the defined +-- elements. This help cannot lie =) +introspect :: [String] -> IO Bool +introspect args = do + when ((SupportedFunction, "") `elem` opts) + (do Io.putStrLn "Supported functions :" + Io.putStrLn "=====================" + Io.putStrLn "Built-in functions :" + Io.putStrLn "--------------------" + mapM_ (Io.putStrLn . ('\t':) . fst) $ unaryFunctions ++ metaFunctionList + mapM_ Io.putStrLn + [ '\t': name ++ '(' : (concat . intersperse ", " $ map fst params) ++ ")" + | (name, (_,_,params,_)) <- multiParamsFunctions] + + Io.putStrLn "\nBase library functions :" + Io.putStrLn "------------------------" + mapM_ (Io.putStrLn . ('\t':)) $ Map.keys defaultSymbolTable + ) + + when ((SupportedOperators, "") `elem` opts) + (do Io.putStrLn "Supported operators : " + Io.putStrLn "=====================" + + Io.putStrLn "\nBinary operators (Priority - name - description)" + Io.putStrLn "------------------------------------------------" + let names = [n | (_,(_,n,_)) <- binopDefs] + maxName = maximum $ map length names + binFormat (prio, name, descr) = '\t': + show prio ++ " - " ++ name + ++ replicate (maxName - length name) ' ' + ++ " - " ++ descr + mapM_ (Io.putStrLn . binFormat . snd) binopDefs + + Io.putStrLn "\nUnary operators (name - description)" + Io.putStrLn "------------------------------------" + mapM_ (Io.putStrLn . (\(_, n, d) -> '\t' : n ++ " - " ++ d)) realUnopOperators) + + when ((SupportedPreprocLanguages, "") `elem` opts) + (do Io.putStrLn "Supported languages for preprocessing :" + Io.putStrLn "=======================================" + let maxi = maximum [ length n | (n, _) <- kindAssociation ] + preprocFormat (ext, lang) = + '\t' : ext ++ replicate (maxi - length ext) ' ' + ++ " - " + ++ languageName lang + mapM_ (Io.putStrLn . preprocFormat) kindAssociation + ) + + return True + where (opts, _, _) = getOpt Permute askingOption args + +preprocessCommand :: [String] -> IO Bool +preprocessCommand args = + if inName == "" + then do print "Error, no input name given" + return False + else do + outFile <- processFile inName + Io.writeFile outName outFile + return True + where (opts, _, _) = getOpt Permute preprocOptions args + inName = fromMaybe "" (lookup Input opts) + outName = fromMaybe inName (lookup Output opts) + +transformParseFormula :: (Formula ListForm -> EqContext (Formula ListForm)) -> [String] + -> IO Bool +transformParseFormula operation args = do + formulaText <- input + finalFile <- outputFile + + let formulaList = parseProgramm formulaText + either (parseErrorPrint finalFile) + (\formulal -> do +#ifdef _DEBUG + mapM_ (\a-> do Io.hPutStr finalFile $ sexprRender a + Io.hPutStr finalFile "\n") formulal + hFlush finalFile +#endif + let rez = performLastTransformationWithContext defaultSymbolTable + $ mapM operation formulal +#ifdef _DEBUG + Io.hPutStrLn finalFile "\n####### #########" + printTrace finalFile rez + Io.hPutStrLn finalFile "####### #########\n" + Io.hPutStrLn finalFile . show $ result rez + Io.hPutStrLn finalFile . sexprRender $ result rez +#endif + printErrors $ errorList rez + Io.hPutStr finalFile . formatFormula conf . treeIfyFormula $ result rez + hClose finalFile + + return . null $ errorList rez) + formulaList + + where (opt, left, _) = getOpt Permute formatOption args + (input, outputFile) = getInputOutput opt left + conf = defaultRenderConf{ useUnicode = Unicode `lookup` opt /= Nothing } + +printVer :: IO () +printVer = + Io.putStrLn $ "EqManips " ++ version ++ " command list" + +helpCommand :: [String] -> IO Bool +helpCommand [] = do + printVer + Io.putStrLn "" + mapM_ printCommand commandList + Io.putStrLn "" + return True + where maxCommandLen = 4 + maximum [ length c | (c,_,_,_) <- commandList ] + spaces = repeat ' ' + printCommand (com, hlp, _, _) = + Io.putStrLn $ ' ' : com + ++ take (maxCommandLen - length com) spaces + ++ hlp + +helpCommand (x:_) = case find (\(x',_,_,_) -> x' == x) commandList of + Just (_, hlp, _, options) -> do + printVer + Io.putStrLn $ usageInfo hlp options + return True + Nothing -> do Io.putStrLn $ "Unknown command " ++ x + return False + +#ifdef _GHCI_DEBUG +transformParseDebug :: (Formula ListForm -> EqContext (Formula ListForm)) -> String + -> IO Bool +transformParseDebug operation formulaText = do + let formulaList = parseProgramm formulaText + either (parseErrorPrint stdout) + (\formulal -> do + let rez = performLastTransformationWithContext defaultSymbolTable + $ mapM operation formulal +#ifdef _DEBUG + mapM (\a-> do hPutStr stdout $ sexprRender a + hPutStr stdout "\n") formulal + Io.hPutStrLn stdout "\n####### #########" + printTrace stdout rez + Io.hPutStrLn stdout "####### #########\n" + Io.hPutStrLn stdout . sexprRender $ result rez +#endif + printErrors $ errorList rez + Io.hPutStr stdout . formatFormula . treeIfyFormula $ result rez + return True + ) + formulaList + +evalDebug :: String -> IO Bool +evalDebug = transformParseDebug evalGlobalLossyStatement +#endif + +commandList :: [(String, String, [String] -> IO Bool, [OptDescr (Flag, String)])] +commandList = + [ ("cleanup", "Perform trivial simplification on formula" + , transformParseFormula (return . cleanup), commonOption) + , ("eval", "Try to evaluate/reduce the formula" + , transformParseFormula evalGlobalLossyStatement, commonOption) + , ("exacteval", "Try to evaluate/reduce the formula, without performing lossy operation" + , transformParseFormula evalGlobalLosslessStatement, commonOption) + , ("format", "Load and display the formula in ASCII Art" + , formatCommand formatFormula, commonOption) + , ("interactive", "Invoke Eq as an interactive prompt", + (\_ -> do repl evalGlobalLossyStatement + return True), []) + , ("latexify", "Translate the formula into latex" + , formatCommand latexRender, commonOption) + , ("mathmlify", "Translate the formula into MathML" + , formatCommand mathmlRender, commonOption) + , ("toraw", "Show internal representation of formula" + , formatCommand $ const show, commonOption) + , ("help", "Ask specific help for a command, or this" + , helpCommand, []) + , ("preprocess", "Parse a source file and apply inline action in it" + , preprocessCommand, commonOption) + , ("demathmlify", "Try to transform a MathML Input to EQ language" + , filterCommand mathMlToEqLang', commonOption) + , ("show" , "Try to retrieve some information about supported options" + , introspect, askingOption) + -- , ( , ) + ] + +reducedCommand :: [(String, [String] -> IO Bool)] +reducedCommand = map (\(n,_,a,_) -> (n,a)) commandList + +main :: IO () +main = do + args <- getArgs + if null args + then error "No command given, try the help command" + else case lookup (head args) reducedCommand of + Just c -> c (tail args) >>= systemReturn + Nothing -> error $ "Unknown command " ++ head args + where systemReturn True = exitWith ExitSuccess + systemReturn False = exitWith $ ExitFailure 1 +