Eq (empty) → 1.0
raw patch · 51 files changed
+8684/−0 lines, 51 filesdep +HaXmldep +arraydep +basesetup-changed
Dependencies added: HaXml, array, base, containers, filepath, mtl, parsec
Files
- CharArray.hs +14/−0
- Eq.cabal +95/−0
- EqManips/Algorithm/Cleanup.hs +235/−0
- EqManips/Algorithm/Derivative.hs +219/−0
- EqManips/Algorithm/EmptyMonad.hs +26/−0
- EqManips/Algorithm/Eval.hs +53/−0
- EqManips/Algorithm/Eval/Complex.hs +112/−0
- EqManips/Algorithm/Eval/Floating.hs +138/−0
- EqManips/Algorithm/Eval/GenericEval.hs +547/−0
- EqManips/Algorithm/Eval/GlobalStatement.hs +71/−0
- EqManips/Algorithm/Eval/Meta.hs +49/−0
- EqManips/Algorithm/Eval/Polynomial.hs +143/−0
- EqManips/Algorithm/Eval/Ratio.hs +50/−0
- EqManips/Algorithm/Eval/Types.hs +41/−0
- EqManips/Algorithm/Eval/Utils.hs +58/−0
- EqManips/Algorithm/Expand.hs +45/−0
- EqManips/Algorithm/Inject.hs +67/−0
- EqManips/Algorithm/Simplify.hs +115/−0
- EqManips/Algorithm/Unification.hs +229/−0
- EqManips/Algorithm/Utils.hs +321/−0
- EqManips/BaseLibrary.hs +8/−0
- EqManips/Conf.hs +5/−0
- EqManips/Domain.hs +60/−0
- EqManips/ErrorMessages.hs +108/−0
- EqManips/EvaluationContext.hs +255/−0
- EqManips/FormulaIterator.hs +235/−0
- EqManips/FormulaIterator.hs-boot +27/−0
- EqManips/InputParser/EqCode.hs +174/−0
- EqManips/InputParser/MathML.hs +226/−0
- EqManips/Linker.hs +260/−0
- EqManips/Polynome.hs +592/−0
- EqManips/Polynome.hs-boot +8/−0
- EqManips/Preprocessor.hs +223/−0
- EqManips/Propreties.hs +36/−0
- EqManips/Renderer/Ascii.hs +656/−0
- EqManips/Renderer/Ascii.hs-boot +8/−0
- EqManips/Renderer/CharRender.hs +219/−0
- EqManips/Renderer/Cpp.hs +163/−0
- EqManips/Renderer/EqCode.hs +130/−0
- EqManips/Renderer/Latex.hs +152/−0
- EqManips/Renderer/Mathml.hs +272/−0
- EqManips/Renderer/Placer.hs +295/−0
- EqManips/Renderer/RenderConf.hs +51/−0
- EqManips/Renderer/Sexpr.hs +91/−0
- EqManips/Renderer/Sexpr.hs-boot +7/−0
- EqManips/Types.hs +753/−0
- EqManips/Types.hs-boot +7/−0
- EqManips/UnicodeSymbols.hs +645/−0
- Repl.hs +59/−0
- Setup.hs +4/−0
- formulaMain.hs +327/−0
+ CharArray.hs view
@@ -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
+ Eq.cabal view
@@ -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 <vincent.berthoux@gmail.com>+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+
+ EqManips/Algorithm/Cleanup.hs view
@@ -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+
+ EqManips/Algorithm/Derivative.hs view
@@ -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)+
+ EqManips/Algorithm/EmptyMonad.hs view
@@ -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)+
+ EqManips/Algorithm/Eval.hs view
@@ -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+
+ EqManips/Algorithm/Eval/Complex.hs view
@@ -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+
+ EqManips/Algorithm/Eval/Floating.hs view
@@ -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+
+ EqManips/Algorithm/Eval/GenericEval.hs view
@@ -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"+
+ EqManips/Algorithm/Eval/GlobalStatement.hs view
@@ -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+
+ EqManips/Algorithm/Eval/Meta.hs view
@@ -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)+
+ EqManips/Algorithm/Eval/Polynomial.hs view
@@ -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+
+ EqManips/Algorithm/Eval/Ratio.hs view
@@ -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+
+ EqManips/Algorithm/Eval/Types.hs view
@@ -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++
+ EqManips/Algorithm/Eval/Utils.hs view
@@ -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+
+ EqManips/Algorithm/Expand.hs view
@@ -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]+
+ EqManips/Algorithm/Inject.hs view
@@ -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
+ EqManips/Algorithm/Simplify.hs view
@@ -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+
+ EqManips/Algorithm/Unification.hs view
@@ -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+
+ EqManips/Algorithm/Utils.hs view
@@ -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+
+ EqManips/BaseLibrary.hs view
@@ -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"]]])]))]+
+ EqManips/Conf.hs view
@@ -0,0 +1,5 @@+module EqManips.Conf where++maxRecursiveDepth :: Int+maxRecursiveDepth = 256+
+ EqManips/Domain.hs view
@@ -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+
+ EqManips/ErrorMessages.hs view
@@ -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"
+ EqManips/EvaluationContext.hs view
@@ -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+
+ EqManips/FormulaIterator.hs view
@@ -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+
+ EqManips/FormulaIterator.hs-boot view
@@ -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
+ EqManips/InputParser/EqCode.hs view
@@ -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]+
+ EqManips/InputParser/MathML.hs view
@@ -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+
+ EqManips/Linker.hs view
@@ -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+
+ EqManips/Polynome.hs view
@@ -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"+
+ EqManips/Polynome.hs-boot view
@@ -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+
+ EqManips/Preprocessor.hs view
@@ -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+ ++
+ EqManips/Propreties.hs view
@@ -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+
+ EqManips/Renderer/Ascii.hs view
@@ -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"+
+ EqManips/Renderer/Ascii.hs-boot view
@@ -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+
+ EqManips/Renderer/CharRender.hs view
@@ -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"+
+ EqManips/Renderer/Cpp.hs view
@@ -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+
+ EqManips/Renderer/EqCode.hs view
@@ -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) . (')':)+
+ EqManips/Renderer/Latex.hs view
@@ -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++
+ EqManips/Renderer/Mathml.hs view
@@ -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 "<math xmlns=\"http://www.w3.org/1998/Math/MathML\">\n"+ . semantics ( presMarkup + . annotation "MathML-Content" contentMarkup+ . annotation "Eq-language" (str . cleanify $ unparse f)+ . annotation "LaTeX" (str . cleanify . latexRender conf $ Formula f))+ . str "</math>\n" $ ""+ where contentMarkup = content f+ presMarkup = mrow $ prez conf f+ semantics = tagger "semantics"+ annotation kind c =+ str ("<annotation-xml encoding=\"" ++ kind ++ "\">\n")+ . c . str "\n</annotation-xml>\n"++str :: String -> ShowS+str = (++)++char :: Char -> ShowS+char = (:)++mathMlOfEntity :: Entity -> String+mathMlOfEntity Pi = "<pi/>"+mathMlOfEntity Nabla = "<grad/>"+mathMlOfEntity Infinite = "<infinity/>"+mathMlOfEntity Ellipsis = "⋯"++tagger :: String -> ShowS -> ShowS+tagger tag f = str ('<': tag ++ ">") . f . str ("</" ++ tag ++ ">")++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 "<mo>(</mo>" . f . str "<mo>)</mo>"+msubsup = tagger "msubsup"+msup = tagger "msup"+msqrt = tagger "msqrt"++mfenced f = str "<mfenced open=\"[\" close=\"]\">\n" . f . str "</mfenced>\n"+mtable = tagger "mtable"+mtd = tagger "mtd"+mtr = tagger "mtr"++enclose :: Char -> Char -> ShowS -> ShowS+enclose beg end f = str ("<mo>" ++ (beg : "</mo>")) . f . str ("<mo>" ++ (end : "</mo>"))++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 "<mo>⌈</mo>"+ . prez conf f + . str "<mo>⌉</mo>"+presentation conf _ (UnOp _ OpFloor f) = str "<mo>⌊</mo>"+ . prez conf f + . str "<mo>⌋</mo>"+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 = "<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 OpExp = "<exp/>"+stringOfUnOp OpAbs = "<abs/>"+stringOfUnOp OpFloor = "<floor/>"+stringOfUnOp OpCeil = "<ceiling/>"+stringOfUnOp OpSqrt = "<root/>"+stringOfUnOp OpFactorial = "<factorial/>"+stringOfUnOp OpNegate = "<minus/>"+stringOfUnOp OpFrac = "<ci>frac</ci>"++stringOfBinOp :: BinOperator -> String+stringOfBinOp OpAdd = "<plus/>"+stringOfBinOp OpAnd = "<and/>"+stringOfBinOp OpDiv = "<quotient/>"+stringOfBinOp OpEq = "<eq/>"+stringOfBinOp OpGe = "<geq/>"+stringOfBinOp OpGt = "<gt/>"+stringOfBinOp OpLe = "<leq/>"+stringOfBinOp OpLt = "<lt/>"+stringOfBinOp OpMul = "<times/>"+stringOfBinOp OpNe = "<neq/>"+stringOfBinOp OpOr = "<or/>"+stringOfBinOp OpPow = "<power/>"+stringOfBinOp OpSub = "<minus/>"+stringOfBinOp OpAttrib = "<!-- Attrib -->"+stringOfBinOp OpLazyAttrib = "<!-- LazyAttrib -->"+stringOfBinOp OpCons = "<!-- Cons -->"++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 "<true/>"+content (Truth False) = str "<false/>"+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 "<product/>" v def end what++content (Sum _ (BinOp _ OpEq [Variable v, def]) end what) =+ bigOperator "<sum/>" v def end what++content (Matrix _ _ _ lsts) =+ matrix $ concatS [matrixrow $ concatMapS content row | row <- lsts]++content (Integrate _ begin end what var) =+ apply $ str "<int/>"+ . bvar (content var)+ . lowlimit (content begin)+ . uplimit (content end)+ . content what++content (Derivate _ f var) =+ apply $ str "<diff/>"+ . bvar (content var)+ . content f++content (App _ func args) = + apply $ content func+ . concatMapS content args+content _ = id+
+ EqManips/Renderer/Placer.hs view
@@ -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+
+ EqManips/Renderer/RenderConf.hs view
@@ -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+
+ EqManips/Renderer/Sexpr.hs view
@@ -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 ')'+
+ EqManips/Renderer/Sexpr.hs-boot view
@@ -0,0 +1,7 @@+module EqManips.Renderer.Sexpr where++import {-# SOURCE #-} EqManips.Types++sexprRender :: Formula anyForm -> String+sexprRenderS :: Formula anyForm -> ShowS+
+ EqManips/Types.hs view
@@ -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+
+ EqManips/Types.hs-boot view
@@ -0,0 +1,7 @@+module EqManips.Types where++data Formula a+data ListForm+data PolyCoeff+data Polynome+
+ EqManips/UnicodeSymbols.hs view
@@ -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 {- ⊁ -}++ --}+
+ Repl.hs view
@@ -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+
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple++main = defaultMain+
+ formulaMain.hs view
@@ -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####### <TRACE> #########"+ printTrace finalFile rez+ Io.hPutStrLn finalFile "####### </TRACE> #########\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####### <TRACE> #########"+ printTrace stdout rez+ Io.hPutStrLn stdout "####### </TRACE> #########\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+