Eq 1.1 → 1.1.1
raw patch · 104 files changed
+10083/−9466 lines, 104 filesdep +template-haskelldep +transformersdep ~arraydep ~containersdep ~filepath
Dependencies added: template-haskell, transformers
Dependency ranges changed: array, containers, filepath, mtl, parsec
Files
- CharArray.hs +0/−20
- Eq.cabal +112/−98
- EqManips/Algorithm/Cleanup.hs +0/−242
- EqManips/Algorithm/Derivative.hs +0/−219
- EqManips/Algorithm/EmptyMonad.hs +0/−19
- EqManips/Algorithm/Eval.hs +0/−53
- EqManips/Algorithm/Eval/Complex.hs +0/−112
- EqManips/Algorithm/Eval/Floating.hs +0/−138
- EqManips/Algorithm/Eval/GenericEval.hs +0/−546
- EqManips/Algorithm/Eval/GlobalStatement.hs +0/−71
- EqManips/Algorithm/Eval/Meta.hs +0/−49
- EqManips/Algorithm/Eval/Polynomial.hs +0/−143
- EqManips/Algorithm/Eval/Ratio.hs +0/−50
- EqManips/Algorithm/Eval/Types.hs +0/−41
- EqManips/Algorithm/Eval/Utils.hs +0/−58
- EqManips/Algorithm/Expand.hs +0/−45
- EqManips/Algorithm/Inject.hs +0/−67
- EqManips/Algorithm/Simplify.hs +0/−118
- EqManips/Algorithm/StackVM/Stack.hs +0/−200
- EqManips/Algorithm/Unification.hs +0/−224
- EqManips/Algorithm/Utils.hs +0/−321
- EqManips/BaseLibrary.hs +0/−8
- EqManips/Conf.hs +0/−5
- EqManips/Domain.hs +0/−60
- EqManips/ErrorMessages.hs +0/−108
- EqManips/EvaluationContext.hs +0/−256
- EqManips/FormulaIterator.hs +0/−235
- EqManips/FormulaIterator.hs-boot +0/−27
- EqManips/InputParser/EqCode.hs +0/−174
- EqManips/InputParser/MathML.hs +0/−215
- EqManips/Linker.hs +0/−260
- EqManips/Polynome.hs +0/−594
- EqManips/Polynome.hs-boot +0/−8
- EqManips/Preprocessor.hs +0/−223
- EqManips/Propreties.hs +0/−36
- EqManips/Renderer/Ascii.hs +0/−656
- EqManips/Renderer/Ascii.hs-boot +0/−8
- EqManips/Renderer/Ascii2DGrapher.hs +0/−463
- EqManips/Renderer/CharRender.hs +0/−219
- EqManips/Renderer/Cpp.hs +0/−159
- EqManips/Renderer/EqCode.hs +0/−130
- EqManips/Renderer/Latex.hs +0/−152
- EqManips/Renderer/Mathml.hs +0/−271
- EqManips/Renderer/Placer.hs +0/−295
- EqManips/Renderer/RenderConf.hs +0/−51
- EqManips/Renderer/Sexpr.hs +0/−91
- EqManips/Renderer/Sexpr.hs-boot +0/−7
- EqManips/Types.hs +0/−753
- EqManips/Types.hs-boot +0/−7
- EqManips/UnicodeSymbols.hs +0/−645
- Language/Eq.hs +38/−0
- Language/Eq/Algorithm/Cleanup.hs +244/−0
- Language/Eq/Algorithm/Derivative.hs +221/−0
- Language/Eq/Algorithm/EmptyMonad.hs +19/−0
- Language/Eq/Algorithm/Eval.hs +53/−0
- Language/Eq/Algorithm/Eval/Complex.hs +112/−0
- Language/Eq/Algorithm/Eval/Floating.hs +142/−0
- Language/Eq/Algorithm/Eval/GenericEval.hs +563/−0
- Language/Eq/Algorithm/Eval/GlobalStatement.hs +71/−0
- Language/Eq/Algorithm/Eval/Meta.hs +49/−0
- Language/Eq/Algorithm/Eval/Polynomial.hs +162/−0
- Language/Eq/Algorithm/Eval/Ratio.hs +56/−0
- Language/Eq/Algorithm/Eval/Types.hs +41/−0
- Language/Eq/Algorithm/Eval/Utils.hs +58/−0
- Language/Eq/Algorithm/Expand.hs +45/−0
- Language/Eq/Algorithm/Inject.hs +71/−0
- Language/Eq/Algorithm/Simplify.hs +203/−0
- Language/Eq/Algorithm/StackVM/Stack.hs +207/−0
- Language/Eq/Algorithm/Unification.hs +224/−0
- Language/Eq/Algorithm/Utils.hs +322/−0
- Language/Eq/BaseLibrary.hs +121/−0
- Language/Eq/CharArray.hs +20/−0
- Language/Eq/Conf.hs +5/−0
- Language/Eq/Domain.hs +60/−0
- Language/Eq/ErrorMessages.hs +108/−0
- Language/Eq/EvaluationContext.hs +256/−0
- Language/Eq/FormulaIterator.hs +235/−0
- Language/Eq/FormulaIterator.hs-boot +27/−0
- Language/Eq/InputParser/EqCode.hs +163/−0
- Language/Eq/InputParser/MathML.hs +222/−0
- Language/Eq/Linker.hs +276/−0
- Language/Eq/Polynome.hs +594/−0
- Language/Eq/Polynome.hs-boot +8/−0
- Language/Eq/Preprocessor.hs +223/−0
- Language/Eq/Propreties.hs +36/−0
- Language/Eq/QuasiQuote.hs +111/−0
- Language/Eq/Renderer/Ascii.hs +657/−0
- Language/Eq/Renderer/Ascii.hs-boot +8/−0
- Language/Eq/Renderer/Ascii2DGrapher.hs +573/−0
- Language/Eq/Renderer/CharRender.hs +219/−0
- Language/Eq/Renderer/Cpp.hs +161/−0
- Language/Eq/Renderer/EqCode.hs +130/−0
- Language/Eq/Renderer/Latex.hs +152/−0
- Language/Eq/Renderer/Mathml.hs +307/−0
- Language/Eq/Renderer/Placer.hs +295/−0
- Language/Eq/Renderer/RenderConf.hs +58/−0
- Language/Eq/Renderer/Sexpr.hs +94/−0
- Language/Eq/Renderer/Sexpr.hs-boot +7/−0
- Language/Eq/Repl.hs +84/−0
- Language/Eq/Types.hs +761/−0
- Language/Eq/Types.hs-boot +7/−0
- Language/Eq/UnicodeSymbols.hs +645/−0
- Repl.hs +0/−59
- formulaMain.hs +447/−457
− CharArray.hs
@@ -1,20 +0,0 @@-{-# 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--charArrayToString :: (Enum i, Ix i, IArray a Char)- => a (i,i) Char -> String-charArrayToString = concat . reverse - . map (++ "\n") . linesOfArray-
Eq.cabal view
@@ -1,98 +1,112 @@-Name: Eq-Version: 1.1-Synopsis: Render math formula in ASCII, and perform some simplifications-Build-Type: Simple-Category: Language, Math-Cabal-Version: >= 1.4-Homepage: http://twinside.free.fr/eq/-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.Algorithm.StackVM.Stack- , 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.Ascii2DGrapher- , 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-+Name: Eq +Version: 1.1.1 +Synopsis: Render math formula in ASCII, and perform some simplifications +Build-Type: Simple +Category: Language, Math +Cabal-Version: >= 1.6 +Homepage: http://twinside.free.fr/eq/ +Description: + Haskell formula manipulation program + . + Changelog : + . + Version 1.1.1: + . + * Fixing some rendering bug + . + * Updating all the dependencies + +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: Language.Eq + , Language.Eq.Algorithm.Cleanup + , Language.Eq.Algorithm.Derivative + , Language.Eq.Algorithm.EmptyMonad + , Language.Eq.Algorithm.Eval + , Language.Eq.Algorithm.Eval.Complex + , Language.Eq.Algorithm.Eval.Floating + , Language.Eq.Algorithm.Eval.GenericEval + , Language.Eq.Algorithm.Eval.GlobalStatement + , Language.Eq.Algorithm.Eval.Meta + , Language.Eq.Algorithm.Eval.Polynomial + , Language.Eq.Algorithm.Eval.Ratio + , Language.Eq.Algorithm.Eval.Types + , Language.Eq.Algorithm.Eval.Utils + , Language.Eq.Algorithm.Expand + , Language.Eq.Algorithm.Inject + , Language.Eq.Algorithm.Simplify + , Language.Eq.Algorithm.Unification + , Language.Eq.Algorithm.Utils + , Language.Eq.Algorithm.StackVM.Stack + , Language.Eq.BaseLibrary + , Language.Eq.Conf + , Language.Eq.Domain + , Language.Eq.ErrorMessages + , Language.Eq.EvaluationContext + , Language.Eq.FormulaIterator + , Language.Eq.InputParser.EqCode + , Language.Eq.InputParser.MathML + , Language.Eq.Linker + , Language.Eq.Polynome + , Language.Eq.Preprocessor + , Language.Eq.Propreties + , Language.Eq.QuasiQuote + , Language.Eq.Renderer.Ascii + , Language.Eq.Renderer.Ascii2DGrapher + , Language.Eq.Renderer.CharRender + , Language.Eq.Renderer.Cpp + , Language.Eq.Renderer.EqCode + , Language.Eq.Renderer.Latex + , Language.Eq.Renderer.Mathml + , Language.Eq.Renderer.Placer + , Language.Eq.Renderer.RenderConf + , Language.Eq.Renderer.Sexpr + , Language.Eq.Types + , Language.Eq.UnicodeSymbols + , Language.Eq.CharArray + , Language.Eq.Repl + + Build-Depends: base >= 4.1 && < 5.0 + , parsec >= 3.1 && < 3.2 + , HaXml >= 1.9 && < 2.0 + , mtl >= 2.1 && < 2.2 + , transformers >= 0.2 && < 0.4 + , template-haskell >= 2.7 && < 2.8 + , containers >= 0.4 && < 0.5 + , filepath >= 1.3 && < 1.4 + , array >= 0.4 && < 0.5 +
− EqManips/Algorithm/Cleanup.hs
@@ -1,242 +0,0 @@-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 (UnOp _ OpNegate (CInteger 1)) x = Left $ negate x-mul x (UnOp _ OpNegate (CInteger 1)) = Left $ negate 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 x (UnOp _ OpNegate (CInteger 1)) = Left $ negate 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 _ OpDiv [UnOp _ OpNegate (NumEntity Pi), CInteger 3]) = Fraction $ 1 % 2-cosinus (BinOp _ OpDiv [UnOp _ OpNegate (NumEntity Pi)- ,UnOp _ OpNegate (CInteger 3)]) = Fraction $ 1 % 2-cosinus (BinOp _ OpDiv [NumEntity Pi, UnOp _ OpNegate (CInteger 3)]) = Fraction $ 1 % 2-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
@@ -1,219 +0,0 @@-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
@@ -1,19 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE Rank2Types #-}-module EqManips.Algorithm.EmptyMonad( fromEmptyMonad, asAMonad ) where--import Control.Applicative-import Control.Monad.Identity---- | 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
@@ -1,53 +0,0 @@-{-# 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
@@ -1,112 +0,0 @@-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
@@ -1,138 +0,0 @@-{-# 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
@@ -1,546 +0,0 @@-{-# 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 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
@@ -1,71 +0,0 @@-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
@@ -1,49 +0,0 @@-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
@@ -1,143 +0,0 @@-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
@@ -1,50 +0,0 @@-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
@@ -1,41 +0,0 @@-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
@@ -1,58 +0,0 @@-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
@@ -1,45 +0,0 @@-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
@@ -1,67 +0,0 @@-{-# 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
@@ -1,118 +0,0 @@-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 (Variable v) (BinOp _ OpDiv [a, somethingWithV])-}--{- if c == b then a * c - b = (a-1) * c -}-subSimplification eval first@(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/StackVM/Stack.hs
@@ -1,200 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module EqManips.Algorithm.StackVM.Stack( compileExpression- , evalProgram - , ValueType- ) where--import Control.Applicative-import Data.List( foldl' )--import EqManips.Types-import EqManips.Polynome-import EqManips.Algorithm.Cleanup( cleanupFormulaPrim )--type ValueType = Double--data StackOperand =- Add | Sub | Mul | Div- | Pow | Negate | Abs | Sqrt- | Sin | Sinh | ASin | ASinh- | Cos | Cosh | ACos | ACosh- | Tan | Tanh | ATan | ATanh- | Ln | Log | Exp- | Ceil | Floor | Frac- | LoadX- | LoadY- | LoadConst ValueType- deriving Show--type CompiledExpression = [StackOperand]--type MachineWorld = [ValueType]---- | bla-evalProgram :: CompiledExpression -> ValueType -> ValueType- -> ValueType-evalProgram program x y = head $ foldl' (evalOperation x y) [] program---- | Main eval function.-evalOperation :: ValueType -> ValueType -> MachineWorld- -> StackOperand- -> MachineWorld-evalOperation _ _ rest (LoadConst v) = v : rest-evalOperation x _ rest LoadX = x : rest-evalOperation _ y rest LoadY = y : rest--evalOperation _ _ (v1:v2:rest) Add = (v2 + v1) : rest-evalOperation _ _ (v1:v2:rest) Sub = (v2 - v1) : rest-evalOperation _ _ (v1:v2:rest) Mul = (v2 * v1) : rest-evalOperation _ _ (v1:v2:rest) Div = (v2 / v1) : rest-evalOperation _ _ (v1:v2:rest) Pow = (v2 ** v1) : rest--evalOperation _ _ (v1:rest) Negate = (-v1) : rest-evalOperation _ _ (v1:rest) Abs = (-v1) : rest-evalOperation _ _ (v1:rest) Sqrt = sqrt v1 : rest-evalOperation _ _ (v1:rest) Sin = sin v1 : rest-evalOperation _ _ (v1:rest) Sinh = sinh v1 : rest-evalOperation _ _ (v1:rest) ASin = asin v1 : rest-evalOperation _ _ (v1:rest) ASinh = asinh v1 : rest-evalOperation _ _ (v1:rest) Cos = cos v1 : rest-evalOperation _ _ (v1:rest) Cosh = cosh v1 : rest-evalOperation _ _ (v1:rest) ACos = acos v1 : rest-evalOperation _ _ (v1:rest) ACosh = acosh v1 : rest-evalOperation _ _ (v1:rest) Tan = tan v1 : rest-evalOperation _ _ (v1:rest) Tanh = tanh v1 : rest-evalOperation _ _ (v1:rest) ATan = atan v1 : rest-evalOperation _ _ (v1:rest) ATanh = atanh v1 : rest-evalOperation _ _ (v1:rest) Ln = log v1 : rest-evalOperation _ _ (v1:rest) Log = (log v1 / log 10) : rest-evalOperation _ _ (v1:rest) Exp = exp v1 : rest--evalOperation _ _ (v1:rest) Ceil = (fromInteger $ ceiling v1) : rest-evalOperation _ _ (v1:rest) Floor = (fromInteger $ floor v1) : rest-evalOperation _ _ (v1:rest) Frac = v' : rest- where (_, v') = properFraction v1 :: (Int,Double)--evalOperation _ _ [] _ = error "Stack VM : empty stack."-evalOperation _ _ _ _ = error "Stack VM : stack underflow"---stackOpOfBinop :: BinOperator -> Maybe StackOperand-stackOpOfBinop OpAdd = Just Add -stackOpOfBinop OpSub = Just Sub -stackOpOfBinop OpMul = Just Mul -stackOpOfBinop OpDiv = Just Div -stackOpOfBinop OpPow = Just Pow -stackOpOfBinop _ = Nothing--stackOpOfUnop :: UnOperator -> StackOperand-stackOpOfUnop OpNegate = Negate -stackOpOfUnop OpAbs = Abs -stackOpOfUnop OpSqrt = Sqrt-stackOpOfUnop OpSin = Sin -stackOpOfUnop OpSinh = Sinh -stackOpOfUnop OpASin = ASin -stackOpOfUnop OpASinh = ASinh-stackOpOfUnop OpCos = Cos -stackOpOfUnop OpCosh = Cosh -stackOpOfUnop OpACos = ACos -stackOpOfUnop OpACosh = ACosh-stackOpOfUnop OpTan = Tan -stackOpOfUnop OpTanh = Tanh -stackOpOfUnop OpATan = ATan -stackOpOfUnop OpATanh = ATanh-stackOpOfUnop OpLn = Ln -stackOpOfUnop OpLog = Log -stackOpOfUnop OpExp = Exp-stackOpOfUnop OpFactorial =- error "Cannot be compiled"-stackOpOfUnop OpCeil = Ceil -stackOpOfUnop OpFloor = Floor -stackOpOfUnop OpFrac = Frac---- | Convert a polynome into a formula to provide the minimal--- formula in term of multiplication need.-convertPolynomeToEvalFormula :: Polynome -> Maybe FormulaPrim-convertPolynomeToEvalFormula (PolyRest c) = Just $ coefToFormula c-convertPolynomeToEvalFormula (Polynome [var] polyCoeffs) - | var == 'x' || var == 'y' = do- firstTransfo <- convertPolynomeToEvalFormula firstSub- (lastCoeff, lastFormu) <-- foldl' prefCoeff (Just (firstCoeff, firstTransfo)) restCoeff- pure . cleanupFormulaPrim $ lastFormu * fvar ** coefToFormula lastCoeff- where ((firstCoeff,firstSub):restCoeff) = reverse polyCoeffs- fvar = Variable [var]-- multCoeff :: FormulaPrim -> PolyCoeff -> PolyCoeff -> FormulaPrim- -> (PolyCoeff, FormulaPrim)- multCoeff rez _ 0 subFormu = (0 , rez + subFormu)- multCoeff rez 0 coeff subFormu = (coeff - 1, rez * fcoeff * fvar * subFormu)- where fcoeff = coefToFormula coeff- multCoeff rez prevCoeff coeff subFormu =- (coeff, (rez * fvar ** thisCoeff + 1) * subFormu)- where thisCoeff = coefToFormula $ prevCoeff - coeff-- prefCoeff :: Maybe (PolyCoeff, FormulaPrim) -> (PolyCoeff, Polynome)- -> Maybe (PolyCoeff, FormulaPrim)- prefCoeff Nothing _ = Nothing- prefCoeff (Just (prevCoeff, rez)) (coeff, sub) = do- multCoeff rez prevCoeff coeff <$> convertPolynomeToEvalFormula sub- --convertPolynomeToEvalFormula (Polynome _ _) = Nothing--compileExpression :: FormulaPrim -> Either String CompiledExpression-compileExpression (Poly _ p) =- maybe (Left "Wrong variable name in expression") compileExpression- $ convertPolynomeToEvalFormula p--compileExpression (Variable "x") = Right [LoadX]-compileExpression (Variable "y") = Right [LoadY]-compileExpression (NumEntity Pi) = Right [LoadConst pi]-compileExpression (NumEntity _) = - Left "Can't compile numeric entity"-compileExpression (Variable v) =- Left $ "Can't compile expression with unbound variable ("- ++ v ++ ")"-compileExpression (CInteger i) = Right [LoadConst $ fromInteger i]-compileExpression (CFloat f) = Right [LoadConst f]-compileExpression (Fraction f) = Right [LoadConst $ fromRational f]-compileExpression (UnOp _ OpFactorial _) =- Left "Cannot compile factorial expression"-compileExpression (UnOp _ op sub) =- (++ [stackOpOfUnop op]) <$> compileExpression sub--compileExpression (BinOp _ op formulas) =- case stackOpOfBinop op of- Just stackOp -> case mapM compileExpression formulas of- Left err -> Left err- Right [] -> Left "Stack VM : Empty binop"- Right [x] -> Right x- Right (x:xs) ->- Right $ x ++ foldr (\lst acc -> lst ++ (stackOp : acc)) [] xs- Nothing -> Left "Error non continuous operators used"-compileExpression (App _ _ _) =- Left "No function call allowed in compiled expression."-compileExpression (Sum _ _ _ _) =- Left "No sum allowed."-compileExpression (Product _ _ _ _) =- Left "No product allowed."-compileExpression (Indexes _ _ _) =- Left "No indexes allowed in compiled exprression."-compileExpression (List _ _) =- Left "No lists allowed in compiled exprression."-compileExpression (Complex _ _) =- Left "No complex arithmetic allowed in compiled expression."-compileExpression (Lambda _ _) = - Left "No lambda allowed in compiled expression."-compileExpression (Matrix _ _ _ _) = - Left "No matrix allowed in compiled expression."-compileExpression (Truth _) = - Left "No boolean expression allowed for compilation."-compileExpression (Derivate _ _ _) = - Left "No derivation allowed in compilation."-compileExpression (Integrate _ _ _ _ _) = - Left "No integration allowed in compilation."-compileExpression (Block _ _ _) = - Left "There is some errors in expressions."-compileExpression (Meta _ _ _) =- Left "No meta operations allowed in compilation."-
− EqManips/Algorithm/Unification.hs
@@ -1,224 +0,0 @@-{-# 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 =~=--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
@@ -1,321 +0,0 @@--- | 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
@@ -1,8 +0,0 @@-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
@@ -1,5 +0,0 @@-module EqManips.Conf where--maxRecursiveDepth :: Int-maxRecursiveDepth = 256-
− EqManips/Domain.hs
@@ -1,60 +0,0 @@-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
@@ -1,108 +0,0 @@-{-# 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
@@ -1,256 +0,0 @@-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 */- , emptyContext- ) 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
@@ -1,235 +0,0 @@-{-# 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
@@ -1,27 +0,0 @@-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
@@ -1,174 +0,0 @@-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
@@ -1,215 +0,0 @@-{-# 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--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
@@ -1,260 +0,0 @@--- | 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
@@ -1,594 +0,0 @@-{-# 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 headSum- . 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]- where headSum lst@((o,_):_) = (o, sum $ map snd lst)- headSum [] = error "Polynome.hs - headSum - error Empty list"--------------------------------------------------------- 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
@@ -1,8 +0,0 @@-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
@@ -1,223 +0,0 @@-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
@@ -1,36 +0,0 @@-{-# 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
@@ -1,656 +0,0 @@-{-# 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
@@ -1,8 +0,0 @@-module EqManips.Renderer.Ascii where--import EqManips.Types-import EqManips.Renderer.RenderConf--formulaTextTable :: Conf -> Formula TreeForm -> [String]-formatFormula :: Conf -> Formula TreeForm -> String-
− EqManips/Renderer/Ascii2DGrapher.hs
@@ -1,463 +0,0 @@--- | This module implement an ASCII Art graph plotter,--- using subdivision to provide good looking ascii graph.-module EqManips.Renderer.Ascii2DGrapher(- -- * Plotting configuration- PlotConf( .. )- , ScalingType( .. )- , Dimension( .. )- , defaultPlotConf- -- * Da Ploting LAUNCHER !!- , plot2DExpression- ) where--import Data.Array.Unboxed-import Text.Printf--import EqManips.Types-import qualified EqManips.Algorithm.StackVM.Stack as VM---- | Alias in case I want to change in the future.-type ValueType = Double---- | (Begin, End), all inclusive-type PlotRange = (ValueType, ValueType)--data ScalingType =- Linear- | Logarithmic- deriving Show--data Dimension = Dimension- { minVal :: ValueType- , maxVal :: ValueType- , projectionSize :: Int- , scaling :: ScalingType- , drawAxis :: Bool- , labelPrecision :: Int- , labelEvery :: Maybe Int- }- deriving Show--data PlotConf = PlotConf- { xDim :: Dimension- , yDim :: Dimension- , draw0Axis :: Bool- , graphTitle :: Maybe String- }- deriving Show--defaultPlotConf :: PlotConf-defaultPlotConf = PlotConf- { xDim = Dimension- { minVal = 0.0- , maxVal = 10.0- , projectionSize = 50- , scaling = Linear- , drawAxis = False- , labelPrecision = 4- , labelEvery = Just 7- }-- , yDim = Dimension- { minVal = -5.0- , maxVal = 5.0- , projectionSize = 30- , scaling = Linear- , drawAxis = False- , labelPrecision = 4- , labelEvery = Just 4- }-- , draw0Axis = False- , graphTitle = Nothing- }--doubleShow :: Dimension -> ValueType -> String-doubleShow dim = printf "%.*f" (labelPrecision dim)--dimensionRange :: Dimension -> PlotRange-dimensionRange dim = (minVal dim, maxVal dim)--canvasSize :: PlotConf -> (Int, Int)-canvasSize conf = ( projectionSize $ xDim conf- , projectionSize $ yDim conf)---- | Translate a list of write on the x (width) axis with--- a given amount. Perform no operation if translation amount--- is 0.-translateX :: Int -> [((Int, Int), Char)] -> [((Int, Int), Char)]-translateX 0 lst = lst-translateX i lst = [ ((x + i, y), c) | ((x,y), c) <- lst ]---- | Same thing as 'translateX' but with the y (height) axis.-translateY :: Int -> [((Int, Int), Char)] -> [((Int, Int), Char)]-translateY 0 lst = lst-translateY i lst = [ ((x, y + i), c) | ((x,y), c) <- lst ]---- | Add some vertical labels-addYAxisLabel :: Dimension -> ValSuccessor -> CharCanvas -> CharCanvas-addYAxisLabel dim successor rez@(((xPos, shiftHeight), adds), vals) =- case (drawAxis dim, labelEvery dim) of- (_, Nothing) -> rez- (False, _) -> rez- (True, Just size) ->- (((xShift, shiftHeight), adds), vals' ++ draw shiftHeight (minVal dim))- where maxHeight = projectionSize dim + shiftHeight-- xShift = max 8 xPos- vals' = translateX (xShift - xPos) vals- - apply val 0 = val- apply val times = apply (successor val) $ times - 1-- draw y yVal- | y >= maxHeight = []- | otherwise = - let indicator = ((xShift - 1, y), '+')- future = draw (y + size) (apply yVal size)- in indicator :- [((xP, y), c) | (xP, c) <- zip [0.. xShift - 2] - $ doubleShow dim yVal] ++- future---- | Represent a tuple of canvas extension and a list--- of characters. It's ((leftAdd, bottomAdd), (rightAdd, topAdd))-type CharCanvas =- (((Int,Int),(Int,Int)), [((Int,Int), Char)])--addXAxisLabel :: Dimension -> ValSuccessor -> CharCanvas -> CharCanvas-addXAxisLabel dim successor rez@(((shiftWidth, yPos), (addX, addY)), vals) = - case (drawAxis dim, labelEvery dim) of- (_, Nothing) -> rez- (False, _) -> rez- (True, Just size) ->- (((shiftWidth, yPos)- ,(rightShift, addY) ), vals ++ draw shiftWidth (minVal dim))- where maxWidth = projectionSize dim + shiftWidth-- apply val 0 = val- apply val times = apply (successor val) $ times - 1-- rightShift = max addX - $ size - (projectionSize dim `rem` size)-- draw x xVal- | x >= maxWidth = []- | otherwise = - let indicator = ((x - 1,1), '|')- future = draw (x + size) (apply xVal size)- in indicator : [((xPos, 0), c)- | (xPos, c) <- zip [x - 1.. x + size - 3] - $ doubleShow dim xVal] ++ future- -addTitle :: PlotConf -> Maybe String -> CharCanvas -> CharCanvas-addTitle _ Nothing a = a-addTitle conf (Just t) (((shiftWidth, shiftHeight), adds), vals) =- (((shiftWidth, shiftHeight + 2), adds), toAdd ++ translateY 2 vals)- where begin = (projectionSize (xDim conf) - length t) `div` 2- toAdd = [((x,0), c) | (x,c) <- zip [begin ..] t]--add0Axis :: PlotConf -> Scaler -> CharCanvas -> CharCanvas -add0Axis conf scaler original@(((shiftWidth, shiftHeight), adds), vals) =- if y < 0 then original else- ( ((wShift, shiftHeight), adds)- , ((wShift - nominalShift + 1, y), '0') : - line ++ translateX valShift vals)- where w = projectionSize $ xDim conf- h = projectionSize $ yDim conf- y = scaler 0- line = if y >= 0 && y < h- then [((x, y), '-') | - x <- [wShift .. wShift + (w - 1)]]- else []- nominalShift = 4- wShift = max nominalShift shiftWidth- valShift = if shiftWidth >= nominalShift- then shiftWidth - wShift- else wShift - shiftWidth--addYAxis :: PlotConf -> Scaler -> CharCanvas -> CharCanvas-addYAxis conf _scaler (((shiftWidth, shiftHeight), adds), vals) =- ( ((wShift, shiftHeight), adds)- , line ++ translateX valShift vals)- where h = projectionSize $ yDim conf- x = nominalShift - 1- line = [((x, y), '|') | - y <- [shiftHeight .. shiftHeight + (h - 1)]]- nominalShift = 4- wShift = max nominalShift shiftWidth- valShift = if shiftWidth >= nominalShift- then shiftWidth - wShift- else wShift - shiftWidth---addXaxis :: PlotConf -> Scaler -> CharCanvas -> CharCanvas-addXaxis conf _ (((shiftWidth, shiftHeight), adds), vals) =- ( ((shiftWidth, hShift), adds)- , line ++ translateY valShift vals)- where line = [((x, hShift - 1), '_') - | x <- [shiftWidth ..(w - 1) + shiftWidth]]- w = projectionSize $ xDim conf- nominalShift = 2- hShift = max nominalShift shiftHeight- valShift = hShift - shiftHeight---- | Equivalent of 'when' but non-monadic.-doWhen :: Bool -> (a -> a) -> a -> a-doWhen False _ a = a-doWhen True f a = f a---- | Function in charge of adding all the plot axis--- to the generated character stream-addAxis :: PlotConf- -> (Scaler, Scaler)- -> (ValSuccessor, ValSuccessor)- -> [((Int, Int), Char)]- -> CharCanvas-addAxis conf (widthScaler, heightScaler) (xSucc, ySucc) a = - doWhen (graphTitle conf /= Nothing)- (addTitle conf $ graphTitle conf)- . doWhen (labelEvery (yDim conf) /= Nothing)- (addYAxisLabel (yDim conf) ySucc)- . doWhen (drawAxis $ yDim conf)- (addYAxis conf heightScaler)- . doWhen (labelEvery (xDim conf) /= Nothing)- (addXAxisLabel (xDim conf) xSucc)- . doWhen (drawAxis $ xDim conf)- (addXaxis conf widthScaler)- . doWhen (draw0Axis conf)- (add0Axis conf heightScaler) $ (((0,0), (0,0)), a)----- | User function to start a plot. Handle all the scary--- configuration before starting the plot.-plot2DExpression :: PlotConf -> FormulaPrim- -> Either String (UArray (Int, Int) Char)-plot2DExpression conf formula =- case VM.compileExpression formula of- Left err -> Left err- Right prog ->- let successor = widthSuccessor $ xDim conf- (_,ySuccessor) = widthSuccessor $ yDim conf- yScaler = sizeMapper $ yDim conf- xScaler = sizeMapper $ xDim conf- (xBegin, xEnd) = dimensionRange $ xDim conf- size@(w, h) = canvasSize conf- graph = plot2D size xEnd- (flip (VM.evalProgram prog) 0)- successor xScaler yScaler- xBegin- (((shiftX, shiftY), (addX, addY)), graph') =- addAxis conf (xScaler, yScaler) (snd successor, ySuccessor) graph- in Right $ accumArray (\_ e -> e) ' '- ((0, 0) ,(w + shiftX + addX - 1, h + shiftY + addY - 1)) $- [v | v@((x,_),_) <- graph', - x < w + shiftX + addX,- x >= 0]----- | This type is a transformation from function--- result to screen space.-type Scaler = ValueType -> Int---- | Function used to find the next \'x\' element--- to be plotted.-type ValSuccessor =- ValueType -> ValueType---- | Equivalent of the 'succ' function of the--- 'Enum' class, with a linear scale.-widthSuccessor :: Dimension -> (ValSuccessor, ValSuccessor)-widthSuccessor dim = case (scaling dim, minVal dim > 0) of- (Linear, _) -> (\v -> v - addVal, \v -> v + addVal)- where addVal = (vMax - vMin) / toEnum (projectionSize dim - 2)- (vMin, vMax) = dimensionRange dim- (Logarithmic, True) -> (\v -> v / mulVal,\v -> v * mulVal)- where mulVal = (vMax / vMin) ** (1.0 / toEnum (projectionSize dim - 1))- (vMin, vMax) = dimensionRange dim- (Logarithmic, False) -> (\v -> vPrev (v + vAdd) - vAdd- ,\v -> vNext (v + vAdd) - vAdd)- where (vMin, vMax) = dimensionRange dim- bigpsilon = 0.1- vAdd = 0.1 + negate vMin- (vPrev, vNext) = widthSuccessor $ - dim { minVal = bigpsilon- , maxVal = vMax - vMin + bigpsilon}- ----- | How to map the height value onto the screen,--- by taking tinto action the 'canvas' size-sizeMapper :: Dimension -> (ValueType -> Int)-sizeMapper dim = - let (vMin, vMax) = dimensionRange dim- fullSize = projectionSize dim- in case (scaling dim, vMin > 0) of- (Linear, _) -> \val -> truncate $ (val - vMin) * scaler- where scaler = toEnum fullSize / (vMax - vMin + 1)-- (Logarithmic, True) -> \val -> truncate $ (log val - vMin') * scaler- where (vMin', vMax') = (log vMin, log vMax)- scaler = toEnum fullSize / (abs (vMax' - vMin') + 1)-- (Logarithmic, False) -> \val -> truncate $ (log $ val - vMin') * scaler- where (vMin', vMax') = (log 0.1, log $ vMax - vMin)- scaler = toEnum fullSize / (abs (vMax' - vMin') + 1)-- --- | Describe the action that the plotter must--- accomplish in order to draw a function-data DrawAction =- ActionStop -- ^ Stop the ploting/subdivision for this value- | SubdivideBoth Char -- ^ Halve the x interval and continue plotting, on both ends- | SubdivideUpper Char -- ^ Halve and continue only on the upper part.- | SubdivideLower Char -- ^ Halve and continue only on the lower part.- | SubdivideIgnore -- ^ Halve and continue both ends but don't write any char.- | Continue Char -- ^ Continue with the current interval, adn write a char.--neighbour :: ValueType -> ValueType -> Bool-neighbour y1 y2 = abs (y1 - y2) < 0.05---- | Given a successor function given as parameter,--- it will return a successor function going half--- as far as the previous one. Work with backward--- functions to.-rangeSplitter :: ValSuccessor -> ValSuccessor-rangeSplitter f x = x + (f x - x) / 2---- | As side is inversed when drawing backward,--- this function help to choose a representation--- given the current direction and a 'Forward'--- assention or 'Backward' descent.-sideChar :: Direction -- ^ Current drawing direction- -> Direction -- ^ Assention or descent- -> Char-sideChar Forward Forward = '/'-sideChar Forward Backward = '\\'-sideChar Backward a = sideChar Forward $ inverseDirection a---- | Given two samples, give an Ascii representation--- and information to the plotter on how to continue--- the drawing.-charOf :: Direction -- ^ Current plotting direction- -> Int -- ^ Canvas height- -> Int -- ^ Absciss in canvas space of the previous value.- -> (ValueType, Int) -- ^ Value and canvas position of the current value.- -> (ValueType, Int) -- ^ Value and canvas position of the current value.- -> DrawAction -- ^ What to do next-charOf direction height screenPrev (y1, screenY1) (y2, screenY2)- | isNaN y1 = ActionStop- | isInfinite y1 && screenY1 >= 0 && screenY1 < height =- SubdivideBoth '|'- | isInfinite y1 = SubdivideIgnore- -- We are out of the drawing box, stop- -- the drawing for the current value of x- | screenY1 >= height || screenY1 < 0 = ActionStop- - - -- The two values are in a different cell,- -- we need to refine the values.- | abs (screenY1 - screenY2) > 1 && abs (screenY1 - screenPrev) > 1- = SubdivideBoth '|'- - | abs (screenY1 - screenY2) > 1 = SubdivideUpper '|'- - | abs (screenY1 - screenPrev) > 1 = SubdivideLower '|'- - -- If values are sufisently near, draw a flat- -- line and continue- | neighbour y1 y2 = Continue '-'- - -- We are ascending, but not enough to subdivide,- -- continue to the next x- | y1 < y2 = Continue $ sideChar direction Forward- - -- Descending...- | y1 > y2 = Continue $ sideChar direction Backward- - -- y1 more or less equal y2- | otherwise = Continue '-'----- | Happy float-epsilon :: ValueType-epsilon = 0.00000000000001---- | Type used when plotting, to inform--- the subdivision direction.-data Direction = Forward | Backward- deriving Eq---- | Inverse the direction, equivalent of--- 'not', but for 'Direction'-inverseDirection :: Direction -> Direction-inverseDirection Forward = Backward-inverseDirection Backward = Forward---- | The real plotting function, calling it is rather complex,--- due to the number of thing to take into account, favor the use--- of a more high level function like 'plot2DExpression'-plot2D :: (Int, Int) -- ^ Size of the canvas in number of cells- -> ValueType -- ^ End value for x- -> (ValueType -> ValueType) -- ^ The function to be evaluated- -> (ValSuccessor, ValSuccessor) -- ^ x Successor function, backward, forward,- -> Scaler -- ^ Function to translate xVal to canvas position- -> Scaler -- ^ Function to translate (f xVal) to canvas position- -> ValueType -- ^ The \'current\' ploted value, xBegin for first call- -> [((Int, Int),Char)] -- ^ Woohoo, the result, to be stored in an array-plot2D (_width, height) xStop f widthSucc xPlot yPlot xInit = - subPlot widthSucc (xInit - epsilon, xStop) Forward 0 xInit- where subPlot successors@(xPrev, xSucc)- interval@(xBegin, xEnd) - direction prevScreen x- | direction == Forward && (x <= xBegin || x >= xEnd) = []- | direction == Backward && (x <= xEnd || x >= xBegin) = []- | otherwise =- let val = f x- xNext = if direction == Forward then xSucc x- else xPrev x- screenY = yPlot val- midPoint = (x + xNext) / 2- halfSuccessors@(halfPrev, halfSucc) =- (rangeSplitter $ rangeSplitter xPrev- ,rangeSplitter $ rangeSplitter xSucc)-- (subPrev, subSucc) = if direction == Forward- then (halfPrev, halfSucc)- else (halfSucc, halfPrev)- midInfo = yPlot $ f midPoint-- lowerRange = subPlot halfSuccessors - (midPoint, xBegin)- (inverseDirection direction)- midInfo - $ subPrev midPoint-- upperRange = subPlot halfSuccessors- (midPoint, xNext) - direction- midInfo- $ subSucc midPoint-- midChar = if midInfo > 0 && midInfo < height- then [((xPlot midPoint, midInfo), '|')]- else []- future = subPlot successors interval direction- screenY xNext--- in case charOf direction height prevScreen- (val, screenY) (f xNext, yPlot $ f xNext) of - ActionStop -> future- Continue c -> ((xPlot x, screenY), c) : future-- SubdivideLower c ->- lowerRange ++ midChar ++ ((xPlot x, screenY),c) : future- SubdivideUpper c ->- upperRange ++ midChar ++ ((xPlot x, screenY),c) : future- SubdivideBoth c ->- lowerRange ++ upperRange ++- midChar ++ ((xPlot x, screenY),c) : future- SubdivideIgnore ->- lowerRange ++ upperRange ++ midChar ++ future-
− EqManips/Renderer/CharRender.hs
@@ -1,219 +0,0 @@-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
@@ -1,159 +0,0 @@-{-# 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--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
@@ -1,130 +0,0 @@-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
@@ -1,152 +0,0 @@-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
@@ -1,271 +0,0 @@-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
@@ -1,295 +0,0 @@-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
@@ -1,51 +0,0 @@-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
@@ -1,91 +0,0 @@-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
@@ -1,7 +0,0 @@-module EqManips.Renderer.Sexpr where--import {-# SOURCE #-} EqManips.Types--sexprRender :: Formula anyForm -> String-sexprRenderS :: Formula anyForm -> ShowS-
− EqManips/Types.hs
@@ -1,753 +0,0 @@-{-# 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
@@ -1,7 +0,0 @@-module EqManips.Types where--data Formula a-data ListForm-data PolyCoeff-data Polynome-
− EqManips/UnicodeSymbols.hs
@@ -1,645 +0,0 @@-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 {- ⊁ -}-- --}-
+ Language/Eq.hs view
@@ -0,0 +1,38 @@+module Language.Eq( + module Language.Eq.Algorithm.Eval, + module Language.Eq.EvaluationContext, + module Language.Eq.Preprocessor, + module Language.Eq.Linker, + module Language.Eq.BaseLibrary, + module Language.Eq.InputParser.MathML, + module Language.Eq.InputParser.EqCode, + + module Language.Eq.Types, + module Language.Eq.Algorithm.Utils, + module Language.Eq.Algorithm.Cleanup, + module Language.Eq.Renderer.Ascii, + module Language.Eq.Renderer.Latex, + module Language.Eq.Renderer.Mathml, + module Language.Eq.Renderer.RenderConf, + + module Language.Eq.Renderer.Ascii2DGrapher +) where + +import Language.Eq.Algorithm.Eval +import Language.Eq.EvaluationContext +import Language.Eq.Preprocessor +import Language.Eq.Linker +import Language.Eq.BaseLibrary +import Language.Eq.InputParser.MathML +import Language.Eq.InputParser.EqCode + +import Language.Eq.Types +import Language.Eq.Algorithm.Utils +import Language.Eq.Algorithm.Cleanup +import Language.Eq.Renderer.Ascii +import Language.Eq.Renderer.Latex +import Language.Eq.Renderer.Mathml +import Language.Eq.Renderer.RenderConf + +import Language.Eq.Renderer.Ascii2DGrapher +
+ Language/Eq/Algorithm/Cleanup.hs view
@@ -0,0 +1,244 @@+module Language.Eq.Algorithm.Cleanup ( cleanup + , cleanupFormulaPrim + , cleanupRules ) where + +import Language.Eq.Types +import Language.Eq.Polynome +import Language.Eq.FormulaIterator +import Language.Eq.Algorithm.Utils +import Data.Ratio + +import qualified Language.Eq.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 (UnOp _ OpNegate (CInteger 1)) x = Left $ negate x +mul x (UnOp _ OpNegate (CInteger 1)) = Left $ negate 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 x (UnOp _ OpNegate (CInteger 1)) = Left $ negate 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 (BinOp _ OpMul (CInteger i: rest)) (CInteger i2) = + Left . binOp OpMul $ Fraction (i % i2) : rest +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 +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 _ OpDiv [UnOp _ OpNegate (NumEntity Pi), CInteger 3]) = Fraction $ 1 % 2 +cosinus (BinOp _ OpDiv [UnOp _ OpNegate (NumEntity Pi) + ,UnOp _ OpNegate (CInteger 3)]) = Fraction $ 1 % 2 +cosinus (BinOp _ OpDiv [NumEntity Pi, UnOp _ OpNegate (CInteger 3)]) = Fraction $ 1 % 2 +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]) + | b /= 0 = Fraction (a % b) +rules (BinOp _ OpDiv [UnOp _ OpNegate (CInteger a), CInteger b]) + | b /= 0 = 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 +
+ Language/Eq/Algorithm/Derivative.hs view
@@ -0,0 +1,221 @@+module Language.Eq.Algorithm.Derivative( derivateFormula + , Var ) where + +import Control.Applicative +import Control.Monad( foldM ) +import Data.Monoid( Monoid( .. ), Any( .. ) ) + +import qualified Language.Eq.ErrorMessages as Err + +import Language.Eq.Types +import Language.Eq.Polynome +import Language.Eq.EvaluationContext +import Language.Eq.Algorithm.Inject +import Language.Eq.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@(UnOp _ OpMatrixWidth _) _var = eqError f Err.deriv_no_matrix + d f@(UnOp _ OpMatrixHeight _) _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) +
+ Language/Eq/Algorithm/EmptyMonad.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE Rank2Types #-} +module Language.Eq.Algorithm.EmptyMonad( fromEmptyMonad, asAMonad ) where + +import Control.Applicative +import Control.Monad.Identity + +-- | 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) +
+ Language/Eq/Algorithm/Eval.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE Rank2Types #-} +module Language.Eq.Algorithm.Eval( reduce + , exactReduce + , evalGlobalLossyStatement + , evalGlobalLosslessStatement + ) where + +import Language.Eq.Types + +import Language.Eq.Algorithm.Cleanup + +import Language.Eq.Algorithm.Eval.GenericEval +import Language.Eq.Algorithm.Eval.GlobalStatement +import Language.Eq.Algorithm.Eval.Floating +import Language.Eq.Algorithm.Eval.Polynomial +import Language.Eq.Algorithm.Eval.Ratio +import Language.Eq.Algorithm.Eval.Complex +import Language.Eq.Algorithm.Eval.Types + +import Language.Eq.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 +
+ Language/Eq/Algorithm/Eval/Complex.hs view
@@ -0,0 +1,112 @@+module Language.Eq.Algorithm.Eval.Complex( complexEvalRules ) where + +{-import qualified Language.Eq.ErrorMessages as Err-} +import Control.Applicative( (<$>), (<*>) ) +import Language.Eq.Types +import Language.Eq.Algorithm.Utils +import Language.Eq.Algorithm.Eval.Utils +import Language.Eq.Algorithm.Eval.Types + +#ifdef _DEBUG +import Language.Eq.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 +
+ Language/Eq/Algorithm/Eval/Floating.hs view
@@ -0,0 +1,142 @@+{-# 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 Language.Eq.Algorithm.Eval.Floating ( evalFloat, floatEvalRules ) where + +import Control.Applicative + +import Data.Maybe( fromMaybe ) +import Data.Ratio + +import qualified Language.Eq.ErrorMessages as Err +import Language.Eq.Algorithm.Eval.Types +import Language.Eq.Algorithm.Eval.Utils +import Language.Eq.EvaluationContext +import Language.Eq.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 : factorial - " + funOf OpMatrixWidth = + error $ Err.not_here "unop : MatrixWidth - " + funOf OpMatrixHeight = + error $ Err.not_here "unop : MatrixHeight - " + +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 +
+ Language/Eq/Algorithm/Eval/GenericEval.hs view
@@ -0,0 +1,563 @@+{-# LANGUAGE Rank2Types #-} +module Language.Eq.Algorithm.Eval.GenericEval ( eval ) where + +import Data.Ratio + +import qualified Language.Eq.ErrorMessages as Err +import Control.Applicative +import Language.Eq.Types +import Language.Eq.Conf +import Language.Eq.EvaluationContext +import Language.Eq.Algorithm.Cleanup +import Language.Eq.Algorithm.Inject +import Language.Eq.Algorithm.Derivative +import Language.Eq.Algorithm.Utils +import Language.Eq.Algorithm.Eval.Meta + +import Language.Eq.Algorithm.Unification +import Language.Eq.Algorithm.Eval.Types +import Language.Eq.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 + +-------------------------------------------------- +---- 'matrixWidth' +-------------------------------------------------- +matrixWidthEval :: EvalFun +matrixWidthEval (Matrix _ width _ _) = return . CInteger $ toInteger width +matrixWidthEval f = return $ unOp OpMatrixWidth f + +-------------------------------------------------- +---- 'matrixHeight' +-------------------------------------------------- +matrixHeightEval :: EvalFun +matrixHeightEval (Matrix _ _ height _) = return . CInteger $ toInteger height +matrixHeightEval f = return $ unOp OpMatrixHeight 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 columnsCount rowCount $ 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 && 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 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 + injectedBody <- inject $ Formula body + popContext + body' <- evaluator $ unTagFormula injectedBody +#ifdef _DEBUG + addTrace ("body' | " ++ show body', treeIfyFormula $ Formula body') +#endif + 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 _ OpMatrixWidth f) = matrixWidthEval =<< evaluator f +eval evaluator (UnOp _ OpMatrixHeight f) = matrixHeightEval =<< 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" +
+ Language/Eq/Algorithm/Eval/GlobalStatement.hs view
@@ -0,0 +1,71 @@+module Language.Eq.Algorithm.Eval.GlobalStatement( evalGlobalStatement ) where + +import qualified Language.Eq.ErrorMessages as Err +import Language.Eq.Types +import Language.Eq.EvaluationContext + +import Language.Eq.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 +
+ Language/Eq/Algorithm/Eval/Meta.hs view
@@ -0,0 +1,49 @@+module Language.Eq.Algorithm.Eval.Meta ( metaEval + , metaFilter + ) where + +import Control.Applicative +import Data.List( sort ) + +import Language.Eq.Algorithm.Utils +import Language.Eq.Algorithm.Expand +import Language.Eq.Algorithm.Cleanup +import Language.Eq.Algorithm.Eval.Types +import Language.Eq.Types +import Language.Eq.EvaluationContext +import Language.Eq.FormulaIterator + +import qualified Language.Eq.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 _ [(args, body)])) = do + args' <- mapM (metaFilter (\a -> unTagFormula <$> (evaluator $ Formula a))) args + body' <- metaFilter (\a -> unTagFormula <$> (evaluator $ Formula a)) body + return . Formula $ lambda [(args', 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) +
+ Language/Eq/Algorithm/Eval/Polynomial.hs view
@@ -0,0 +1,162 @@+module Language.Eq.Algorithm.Eval.Polynomial( polyEvalRules, checkPolynomeBinding' ) where + +import Control.Applicative +import Data.Either( partitionEithers ) + +import qualified Language.Eq.ErrorMessages as Err +import Language.Eq.Types +import Language.Eq.Polynome +import Language.Eq.EvaluationContext +import Language.Eq.Algorithm.Cleanup +import Language.Eq.Algorithm.Utils +import Language.Eq.Algorithm.Eval.Utils +import Language.Eq.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) + +----------------------------------------------- +---- '/' +----------------------------------------------- +-- | Handle the division operator. Nicely handle the case +-- of division by 0. +power :: EvalOp +power (Poly _ p) (CInteger i) = left . poly $ p ^ i +power 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 $ binopize added + where added = [if degree /= 1 + then formulize subPoly * (subst ** coefToFormula degree) + else formulize subPoly * subst | (degree, subPoly) <- coefs] + formulize (PolyRest coeff) = coefToFormula coeff + formulize normalPolynome = poly normalPolynome + + binopize [a] = a + binopize a = binOp OpAdd a + +checkPolynomeBinding' :: Polynome -> EqContext FormulaPrim +checkPolynomeBinding' p = either poly id <$> checkPolynomeBinding return p + +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 _ (BinOp _ OpPow fs) = binEval OpPow power power fs +polyEvalRules evaluator (Poly _ pol@(Polynome _ _)) = do + checkPolynomeBinding evaluator pol + >>= either (return . poly) return +polyEvalRules _ end = return end +
+ Language/Eq/Algorithm/Eval/Ratio.hs view
@@ -0,0 +1,56 @@+module Language.Eq.Algorithm.Eval.Ratio( ratioEvalRules ) where + +{-import qualified Language.Eq.ErrorMessages as Err-} +import Language.Eq.Types +import Language.Eq.Algorithm.Eval.Utils +import Language.Eq.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 (CInteger i) (Fraction r) = left . Fraction $ toRational i + r +add (Fraction r) (CInteger i) = left . Fraction $ r + toRational i +add a b = right (a,b) + +----------------------------------------------- +---- '-' +----------------------------------------------- +sub :: EvalOp +sub (Fraction r1) (Fraction r2) = left . Fraction $ r1 - r2 +sub (CInteger i) (Fraction r) = left . Fraction $ toRational i - r +sub (Fraction r) (CInteger i) = left . Fraction $ r - toRational i +sub a b = right (a,b) + +----------------------------------------------- +---- '*' +----------------------------------------------- +mul :: EvalOp +mul (Fraction r1) (Fraction r2) = left . Fraction $ r1 * r2 +mul (CInteger i) (Fraction r) = left . Fraction $ toRational i * r +mul (Fraction r) (CInteger i) = left . Fraction $ r * toRational i +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 +
+ Language/Eq/Algorithm/Eval/Types.hs view
@@ -0,0 +1,41 @@+module Language.Eq.Algorithm.Eval.Types( EvalOp + , EvalFun + , FormulOperator + , EvalPredicate + , FormulaEvaluator + , taggedEvaluator, deTagEvaluator + ) where + +import Language.Eq.Types +import Language.Eq.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 + +
+ Language/Eq/Algorithm/Eval/Utils.hs view
@@ -0,0 +1,58 @@+module Language.Eq.Algorithm.Eval.Utils( left + , right + , binOpReducer + , binEval + ) where + +import Control.Applicative +import Data.List( sort, foldl' ) + +import Language.Eq.Types +import Language.Eq.EvaluationContext +import Language.Eq.Algorithm.Eval.Types +import Language.Eq.Algorithm.Utils +import Language.Eq.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 +
+ Language/Eq/Algorithm/Expand.hs view
@@ -0,0 +1,45 @@+module Language.Eq.Algorithm.Expand ( expand ) where + +import Language.Eq.Types +import Language.Eq.Algorithm.Utils +import Language.Eq.FormulaIterator +import Language.Eq.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] +
+ Language/Eq/Algorithm/Inject.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE ScopedTypeVariables #-} +module Language.Eq.Algorithm.Inject( inject ) where + +import Control.Applicative +import Language.Eq.Types +import Language.Eq.FormulaIterator +import Language.Eq.EvaluationContext +import Language.Eq.Algorithm.Utils +import Language.Eq.Algorithm.Eval.Polynomial + +-- | 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 (Poly _ po@(Polynome _ _)) = checkPolynomeBinding' po + +injectIntern f@(Meta _ Hold _) = return f +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
+ Language/Eq/Algorithm/Simplify.hs view
@@ -0,0 +1,203 @@+module Language.Eq.Algorithm.Simplify( simplifyFormula ) where + +import Control.Applicative +import Data.Ratio +import Data.Maybe( mapMaybe ) + +import Language.Eq.Types +import Language.Eq.EvaluationContext +import Language.Eq.Algorithm.Eval.Utils +import Language.Eq.Algorithm.Eval.Types + +#ifdef _DEBUG +import Language.Eq.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 +#ifdef _DEBUG +addSimplification eval a second@(BinOp _ OpMul [b, c]) +#else +addSimplification eval a (BinOp _ OpMul [b, c]) +#endif + | hashOfFormula a == hashOfFormula c + && a == c = do +#ifdef _DEBUG + tracer "Triggered '+' simplification" OpAdd a second +#endif + subCoeff <- eval $ b + 1 + left $ subCoeff * c + +#ifdef _DEBUG +addSimplification eval first@(BinOp _ OpMul [a, c]) b +#else +addSimplification eval (BinOp _ OpMul [a, c]) b +#endif + | hashOfFormula c == hashOfFormula b + && b == c = do +#ifdef _DEBUG + tracer "Triggered '+' simplification" OpAdd first 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 (Variable v) (BinOp _ OpDiv [a, somethingWithV])-} + +{- if c == b then a * c - b = (a-1) * c -} +#ifdef _DEBUG +subSimplification eval first@(BinOp _ OpMul [a, c]) b +#else +subSimplification eval (BinOp _ OpMul [a, c]) b +#endif + | hashOfFormula c == hashOfFormula b + && b == c = do +#ifdef _DEBUG + tracer "Triggered '-' simplification" OpSub first 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) + +-------------------------------------------------- +---- '/' +-------------------------------------------------- +divSimplification :: EvalFun -> EvalOp +divSimplification _ (BinOp _ OpMul lst) (CInteger constant) + | any hasFraction lst = return . Left $ (binOp OpMul $ changeFraction lst) + where hasFraction (Fraction _) = True + hasFraction _ = False + + newCoeff frac = Fraction $ frac / toRational constant + + changeFraction [] = [] + changeFraction (Fraction f:xs) = newCoeff f : xs + changeFraction (x:xs) = x : changeFraction xs + +divSimplification _ a b = right (a,b) + +-------------------------------------------------- +---- cos +-------------------------------------------------- +mod2piMulSimplify :: [FormulaPrim] -> FormulaPrim +mod2piMulSimplify lst + | not $ any (NumEntity Pi ==) lst = binOp OpMul lst + | otherwise = packFormula $ mapMaybe coeffReducer lst + where packFormula [a] = a + packFormula l = binOp OpMul l + + two :: Ratio Integer + two = 2 % 1 + + coeffReducer (CInteger n) + | n `mod` 2 == 0 = Nothing + coeffReducer (Fraction f) + | f > two = coeffReducer . Fraction $ f - two + coeffReducer a = Just a + + +{-piSignSimplify :: [FormulaPrim] -> FormulaPrim-} +{-piSignSimplify [Fraction f, NumEntity Pi]-} + {-| f > 3 % 2 = KeepSign $ Fraction (2 % 1 - f) * NumEntity Pi-} + {-| f > 1 % 1 = ChangeSign $ Fraction () * NumEntity Pi-} + {-| f > 1 % 2 = ChangeSign $ Fraction (f - 1 % 2) * NumEntity Pi-} +{-piSignSimplify lst = KeepSign $ binOp OpMul lst-} + +simplifyCos :: EvalFun -> FormulaPrim -> EqContext FormulaPrim +simplifyCos _eval (BinOp _ OpMul lst) = pure . cos $ mod2piMulSimplify lst +simplifyCos _ formula = pure $ cos formula + +-------------------------------------------------- +---- Sqrt +-------------------------------------------------- +simplifySqrt :: EvalFun -> FormulaPrim -> EqContext FormulaPrim +simplifySqrt _eval (Fraction r) + | isIntegerRoot (numerator r) && isIntegerRoot (denominator r) = + return . Fraction $ integerRoot (numerator r) % integerRoot (denominator r) + | isIntegerRoot (numerator r) = + return $ (CInteger . integerRoot $ numerator r) + / (sqrt . CInteger $ denominator r) + | isIntegerRoot (denominator r) = return $ (sqrt . CInteger $ numerator r) + / (CInteger . integerRoot $ denominator r) + where integerRoot :: Integer -> Integer + integerRoot i = let doubleValue = fromInteger i :: Double + in truncate $ sqrt doubleValue + + isIntegerRoot i = i == (integerRoot i) ^ (2 :: Int) +simplifySqrt _ formula = pure $ sqrt formula + +-------------------------------------------------- +---- 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 f (BinOp _ OpDiv lst) = + binEval OpDiv (divSimplification f) (mulSimplification f) lst +simplifyFormula f (UnOp _ OpSqrt sub) = simplifySqrt f sub +simplifyFormula f (UnOp _ OpCos sub) = simplifyCos f sub +simplifyFormula _ formu = pure formu +
+ Language/Eq/Algorithm/StackVM/Stack.hs view
@@ -0,0 +1,207 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} +module Language.Eq.Algorithm.StackVM.Stack( compileExpression + , evalProgram + , ValueType + ) where + +import Control.Applicative +import Data.List( foldl' ) + +import Language.Eq.Types +import Language.Eq.Polynome +import Language.Eq.Algorithm.Cleanup( cleanupFormulaPrim ) + +type ValueType = Double + +data StackOperand = + Add | Sub | Mul | Div + | Pow | Negate | Abs | Sqrt + | Sin | Sinh | ASin | ASinh + | Cos | Cosh | ACos | ACosh + | Tan | Tanh | ATan | ATanh + | Ln | Log | Exp + | Ceil | Floor | Frac + | LoadX + | LoadY + | LoadConst ValueType + deriving Show + +type CompiledExpression = [StackOperand] + +type MachineWorld = [ValueType] + +-- | bla +evalProgram :: CompiledExpression -> ValueType -> ValueType + -> ValueType +evalProgram program x y = head $ foldl' (evalOperation x y) [] program + +-- | Main eval function. +evalOperation :: ValueType -> ValueType -> MachineWorld + -> StackOperand + -> MachineWorld +evalOperation _ _ rest (LoadConst v) = v : rest +evalOperation x _ rest LoadX = x : rest +evalOperation _ y rest LoadY = y : rest + +evalOperation _ _ (v1:v2:rest) Add = (v2 + v1) : rest +evalOperation _ _ (v1:v2:rest) Sub = (v2 - v1) : rest +evalOperation _ _ (v1:v2:rest) Mul = (v2 * v1) : rest +evalOperation _ _ (v1:v2:rest) Div = (v2 / v1) : rest +evalOperation _ _ (v1:v2:rest) Pow = (v2 ** v1) : rest + +evalOperation _ _ (v1:rest) Negate = (-v1) : rest +evalOperation _ _ (v1:rest) Abs = (-v1) : rest +evalOperation _ _ (v1:rest) Sqrt = sqrt v1 : rest +evalOperation _ _ (v1:rest) Sin = sin v1 : rest +evalOperation _ _ (v1:rest) Sinh = sinh v1 : rest +evalOperation _ _ (v1:rest) ASin = asin v1 : rest +evalOperation _ _ (v1:rest) ASinh = asinh v1 : rest +evalOperation _ _ (v1:rest) Cos = cos v1 : rest +evalOperation _ _ (v1:rest) Cosh = cosh v1 : rest +evalOperation _ _ (v1:rest) ACos = acos v1 : rest +evalOperation _ _ (v1:rest) ACosh = acosh v1 : rest +evalOperation _ _ (v1:rest) Tan = tan v1 : rest +evalOperation _ _ (v1:rest) Tanh = tanh v1 : rest +evalOperation _ _ (v1:rest) ATan = atan v1 : rest +evalOperation _ _ (v1:rest) ATanh = atanh v1 : rest +evalOperation _ _ (v1:rest) Ln = log v1 : rest +evalOperation _ _ (v1:rest) Log = (log v1 / log 10) : rest +evalOperation _ _ (v1:rest) Exp = exp v1 : rest + +evalOperation _ _ (v1:rest) Ceil = (fromInteger $ ceiling v1) : rest +evalOperation _ _ (v1:rest) Floor = (fromInteger $ floor v1) : rest +evalOperation _ _ (v1:rest) Frac = v' : rest + where (_, v') = properFraction v1 :: (Int,Double) + +evalOperation _ _ [] _ = error "Stack VM : empty stack." +evalOperation _ _ _ _ = error "Stack VM : stack underflow" + + +stackOpOfBinop :: BinOperator -> Maybe StackOperand +stackOpOfBinop OpAdd = Just Add +stackOpOfBinop OpSub = Just Sub +stackOpOfBinop OpMul = Just Mul +stackOpOfBinop OpDiv = Just Div +stackOpOfBinop OpPow = Just Pow +stackOpOfBinop _ = Nothing + +stackOpOfUnop :: UnOperator -> StackOperand +stackOpOfUnop OpNegate = Negate +stackOpOfUnop OpAbs = Abs +stackOpOfUnop OpSqrt = Sqrt +stackOpOfUnop OpSin = Sin +stackOpOfUnop OpSinh = Sinh +stackOpOfUnop OpASin = ASin +stackOpOfUnop OpASinh = ASinh +stackOpOfUnop OpCos = Cos +stackOpOfUnop OpCosh = Cosh +stackOpOfUnop OpACos = ACos +stackOpOfUnop OpACosh = ACosh +stackOpOfUnop OpTan = Tan +stackOpOfUnop OpTanh = Tanh +stackOpOfUnop OpATan = ATan +stackOpOfUnop OpATanh = ATanh +stackOpOfUnop OpLn = Ln +stackOpOfUnop OpLog = Log +stackOpOfUnop OpExp = Exp +stackOpOfUnop OpCeil = Ceil +stackOpOfUnop OpFloor = Floor +stackOpOfUnop OpFrac = Frac +stackOpOfUnop OpFactorial = + error "Cannot be compiled" +stackOpOfUnop OpMatrixWidth = + error "Cannot be compiled" +stackOpOfUnop OpMatrixHeight = + error "Cannot be compiled" + +-- | Convert a polynome into a formula to provide the minimal +-- formula in term of multiplication need. +convertPolynomeToEvalFormula :: Polynome -> Maybe FormulaPrim +convertPolynomeToEvalFormula (PolyRest c) = Just $ coefToFormula c +convertPolynomeToEvalFormula (Polynome [var] polyCoeffs) + | var == 'x' || var == 'y' = do + firstTransfo <- convertPolynomeToEvalFormula firstSub + let fullTFirstTransfo = if firstCoeff > 0 + then firstTransfo * fvar ** coefToFormula firstCoeff + else firstTransfo + (lastCoeff, lastFormu) <- + foldl' prefCoeff (Just (firstCoeff, fullTFirstTransfo)) restCoeff + pure . cleanupFormulaPrim $ lastFormu * fvar ** coefToFormula lastCoeff + where ((firstCoeff,firstSub):restCoeff) = reverse polyCoeffs + fvar = Variable [var] + + multCoeff :: FormulaPrim -> PolyCoeff -> PolyCoeff -> FormulaPrim + -> (PolyCoeff, FormulaPrim) + multCoeff rez _ 0 subFormu = (0 , rez + subFormu) + multCoeff rez 0 coeff subFormu = (coeff - 1, rez * fcoeff * fvar * subFormu) + where fcoeff = coefToFormula coeff + multCoeff rez prevCoeff coeff subFormu = + (coeff, (rez * fvar ** thisCoeff + 1) * subFormu) + where thisCoeff = coefToFormula $ prevCoeff - coeff + + prefCoeff :: Maybe (PolyCoeff, FormulaPrim) -> (PolyCoeff, Polynome) + -> Maybe (PolyCoeff, FormulaPrim) + prefCoeff Nothing _ = Nothing + prefCoeff (Just (prevCoeff, rez)) (coeff, sub) = do + multCoeff rez prevCoeff coeff <$> convertPolynomeToEvalFormula sub + + +convertPolynomeToEvalFormula (Polynome _ _) = Nothing + +compileExpression :: FormulaPrim -> Either String CompiledExpression +compileExpression (Poly _ p) = + maybe (Left "Wrong variable name in expression") compileExpression + $ convertPolynomeToEvalFormula p + +compileExpression (Variable "x") = Right [LoadX] +compileExpression (Variable "y") = Right [LoadY] +compileExpression (NumEntity Pi) = Right [LoadConst pi] +compileExpression (NumEntity _) = + Left "Can't compile numeric entity" +compileExpression (Variable v) = + Left $ "Can't compile expression with unbound variable (" + ++ v ++ ")" +compileExpression (CInteger i) = Right [LoadConst $ fromInteger i] +compileExpression (CFloat f) = Right [LoadConst f] +compileExpression (Fraction f) = Right [LoadConst $ fromRational f] +compileExpression (UnOp _ OpFactorial _) = + Left "Cannot compile factorial expression" +compileExpression (UnOp _ op sub) = + (++ [stackOpOfUnop op]) <$> compileExpression sub + +compileExpression (BinOp _ op formulas) = + case stackOpOfBinop op of + Just stackOp -> case mapM compileExpression formulas of + Left err -> Left err + Right [] -> Left "Stack VM : Empty binop" + Right [x] -> Right x + Right (x:xs) -> + Right $ x ++ foldr (\lst acc -> lst ++ (stackOp : acc)) [] xs + Nothing -> Left "Error non continuous operators used" +compileExpression (App _ _ _) = + Left "No function call allowed in compiled expression." +compileExpression (Sum _ _ _ _) = + Left "No sum allowed." +compileExpression (Product _ _ _ _) = + Left "No product allowed." +compileExpression (Indexes _ _ _) = + Left "No indexes allowed in compiled exprression." +compileExpression (List _ _) = + Left "No lists allowed in compiled exprression." +compileExpression (Complex _ _) = + Left "No complex arithmetic allowed in compiled expression." +compileExpression (Lambda _ _) = + Left "No lambda allowed in compiled expression." +compileExpression (Matrix _ _ _ _) = + Left "No matrix allowed in compiled expression." +compileExpression (Truth _) = + Left "No boolean expression allowed for compilation." +compileExpression (Derivate _ _ _) = + Left "No derivation allowed in compilation." +compileExpression (Integrate _ _ _ _ _) = + Left "No integration allowed in compilation." +compileExpression (Block _ _ _) = + Left "There is some errors in expressions." +compileExpression (Meta _ _ _) = + Left "No meta operations allowed in compilation." +
+ Language/Eq/Algorithm/Unification.hs view
@@ -0,0 +1,224 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +module Language.Eq.Algorithm.Unification( unify, getFirstUnifying ) where + +import Data.List( foldl' ) + +import Control.Applicative +import Control.Monad.Writer +import Control.Monad.State.Lazy + +import Language.Eq.Types +import Language.Eq.Polynome +import Language.Eq.Algorithm.Utils + +infix 4 =~= + +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 +
+ Language/Eq/Algorithm/Utils.hs view
@@ -0,0 +1,322 @@+-- | Utility function/types used in the project. +module Language.Eq.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 Language.Eq.Algorithm.EmptyMonad +import Language.Eq.Propreties +import Language.Eq.Types +import {-# SOURCE #-} Language.Eq.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 _ [] = id +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 +
+ Language/Eq/BaseLibrary.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE QuasiQuotes #-} +module Language.Eq.BaseLibrary( defaultSymbolTable ) where + +import Language.Eq.Quasiquote +import Language.Eq.Types +import Language.Eq.Renderer.Ascii() +import qualified Data.Map as M + +defaultSymbolTable :: M.Map String (Formula ListForm) +defaultSymbolTable = M.fromList [eqDefs| + +-- derivaten( function, var, order ) +derivaten( f, var, 0 ) :> f; +derivaten( f, var, 1 ) :> derivate( {f}, {var} ); +derivaten( f, var, n ) :> derivate( {derivaten( f, var, n-1 )} + , {var} ); + +-- if( condition (boolean), then, else ) +if( true, a, b ) :> a; +if( false, a, b ) :> b; +if( otherwise, a, b ) :> undefined; + +-- map( a -> b, [a] ) +map( f, [] ) :> []; +map( f, x :: xs ) :> {f}( x ) :: map( {f}, xs ); +map( f, otherwise ) :> undefined; + +-- foldl( function :: acc -> elem -> acc, accumulator, list ) +foldl( f, acc, [] ) :> acc; +foldl( f, acc, x :: xs ) :> foldl( f, f( acc, x ), xs ); +foldl( a, b, c ) :> undefined; + +-- foldr( function :: acc -> elem -> acc , accumulator, list ) +foldr( f, acc, [] ) :> acc; +foldr( f, acc, x :: xs ) :> f( foldr( f, acc, xs ), x ); +foldr( a, b, c ) :> undefined; + +-- zip :: ( [a], [b] ) -> [[a, b]] +zip( [], a ) :> []; +zip( b, []) :> []; +zip( x :: xs, y :: ys ) :> [x, y] :: zip( xs, ys ); + +-- replicate :: Int -> a -> [a] +replicate(0, a) :> []; +replicate(n, a) :> a :: replicate(n - 1, a); + +-- just to provide a function englobing list appending +-- operator +cons( a, b ) :> b :: a; + +-- list reversal. +reverse( lst ) :> foldl( cons, [], lst ); + +-- concatenate two lists. +concat( [], y ) :> y; +concat( x, [] ) :> x; +concat( x :: xs, y ) :> x :: concat( xs, y ); +concat( a, b ) :> undefined; + +-- Filtering function, remove un-needed stuff +filter( pred, [] ) :> []; +filter( pred, x :: xs ) :> concat( if( pred( x ), [x], []) + , filter( pred, xs ) ); +filter( a, b ) :> undefined; + +listFromTo( a, a ) :> [a]; +listFromTo( a, b ) :> a :: listFromTo( a + 1, b ); + +listFromToBy( a, by, a ) :> [a]; +listFromToBy( a, by, maxi ) :> a :: listFromToBy( a + by, by, maxi ); + +lengthIntern( acc, [] ) :> acc; +lengthIntern( acc, x :: xs ) :> lengthIntern( acc + 1, xs ); +lengthIntern( a, b ) :> undefined; + +-- length +length( lst ) :> lengthIntern( 0, lst ); + +-- well, a max function +max( a, b ) :> if( a > b, a, b ); + +-- well, a min function +min( a, b ) :> if( a < b, a, b ); + +-- provide equality when everything else is undefined :-P +eq( a, a ) :> true; +eq( a, b ) :> false; + +-- generateMatrix :: ((i, j) -> a, Int, Int) -> [[a]] +generateMatrix( f, width, height ) :> matrix( + map( Lambda( lineId + , map( Lambda( col, {f}({lineId}, {col})) + , {listFromTo(0, {width} - 1)})) + , listFromTo(0, height - 1) + ) + ); + +transpose(m) :> + generateMatrix( Lambda(line, col, {m} _ (col + 1) _ (line + 1)) + , matrixHeight(m), matrixWidth(m) ); + +-- modintern( n<p, rest, module ) +modintern( true, rest, num ) :> rest; +modintern( false, rest, num ) :> modintern( rest - num < num, rest - num, num ); + +-- give the value of n modulo p +modulo( n, p ) :> modintern( n < p, n, p ); + +-- taylor( function (as a lambda!!), derivation var, onVar, order ) +taylorin( f, var, a, 0 ) :> f(a); +taylorin( f, var, a, n ) :> taylorin( f, var, a, n - 1 ) + + (derivaten(f, var, {n}))( a ) / n! * (x - a) ^ n; + +-- taylor( formula, derivation var, onVar, order ) +taylor( f, var, a, n ) :> + Sort( Cleanup( taylorin( Lambda( {var}, {f} ) + , var, a, n ))) + +|] + +
+ Language/Eq/CharArray.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE FlexibleContexts #-} +module Language.Eq.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 + +charArrayToString :: (Enum i, Ix i, IArray a Char) + => a (i,i) Char -> String +charArrayToString = concat . reverse + . map (++ "\n") . linesOfArray +
+ Language/Eq/Conf.hs view
@@ -0,0 +1,5 @@+module Language.Eq.Conf where + +maxRecursiveDepth :: Int +maxRecursiveDepth = 256 +
+ Language/Eq/Domain.hs view
@@ -0,0 +1,60 @@+module Language.Eq.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 +
+ Language/Eq/ErrorMessages.hs view
@@ -0,0 +1,108 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +-- | This module should be imported as qualified +module Language.Eq.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"
+ Language/Eq/EvaluationContext.hs view
@@ -0,0 +1,256 @@+module Language.Eq.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 */ + , emptyContext + ) where + +import Data.Map (Map) +import Control.Applicative +import qualified Data.Map as Map + +import Language.Eq.Types +import Language.Eq.Algorithm.Utils + +#ifdef _DEBUG +import System.IO +import qualified Language.Eq.Renderer.RenderConf as RenderConf + +import {-# SOURCE #-} Language.Eq.Renderer.Ascii( formatFormula ) +import {-# SOURCE #-} Language.Eq.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 +
+ Language/Eq/FormulaIterator.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE ScopedTypeVariables #-} +module Language.Eq.FormulaIterator( depthFirstFormula + , depthFormulaTraversal + , depthFormulaPrimTraversal + , depthPrimTraversal + , topDownTraversal + , topDownScanning + ) where + +import Control.Applicative +import Control.Monad.Identity +import Language.Eq.Types + +import Language.Eq.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 +
+ Language/Eq/FormulaIterator.hs-boot view
@@ -0,0 +1,27 @@+module Language.Eq.FormulaIterator where + +import Control.Applicative +import Language.Eq.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
+ Language/Eq/InputParser/EqCode.hs view
@@ -0,0 +1,163 @@+module Language.Eq.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 Data.Functor.Identity( Identity )-} + +import Language.Eq.Types +import Language.Eq.Polynome +import Language.Eq.Linker +import Language.Eq.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 :: Parsec String u a -> Parsec String u a +parens = P.parens lexer + +braces :: Parsec String u a -> Parsec String u a +braces = P.braces lexer + +brackets :: Parsec String u a -> Parsec String u 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 = Parsec String st 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] + ] + where binary name fun = Infix (do{ reservedOp name; return fun }) + prefix name fun = Prefix (do{ reservedOp name; return fun }) + postfix name fun = Postfix (do{ reservedOp name; return fun }) + binop op left right = binOp op [left, right] + +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) +
+ Language/Eq/InputParser/MathML.hs view
@@ -0,0 +1,222 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} +module Language.Eq.InputParser.MathML ( mathMlToEqLang + , mathMlToEqLang' + ) where + +import Control.Applicative +import Language.Eq.Algorithm.Utils +import qualified Language.Eq.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 (N "m:math") c lst) l) = + simplifyXml (Document a b (Elem (N "math") c lst) l) +simplifyXml (Document a b (Elem (QN _ "math") c lst) l) = + simplifyXml (Document a b (Elem (N "math") c lst) l) +simplifyXml (Document _ _ (Elem (N "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 + +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 (QN _ x) att cont) = simplify (Elem (N x) att cont) +simplify (Elem (N ('m':':':x)) att cont) = simplify (Elem (N x) att cont) +simplify (Elem (N "mi") _ [c]) = Right . Xsymb $ strOfContent c +simplify (Elem (N "mn") _ [c]) = Right . Xnum $ strOfContent c +simplify (Elem (N "mo") _ [c]) = Right . Xop $ strOfContent c +simplify (Elem (N "mrow") _ lst) = Xrow <$> eitherMap (map simplifyContent lst) +simplify (Elem (N "msqrt") _ lst) = Xsqrt . Xrow <$> eitherMap (map simplifyContent lst) +simplify (Elem (N "mfrac") _ [a,b]) = Xfrac <$> simplifyContent a <*> simplifyContent b +simplify (Elem (N "msup") _ [a,b]) = Xsup <$> simplifyContent a <*> simplifyContent b +simplify (Elem (N "munderover") _ [a,b,c]) = + XunderOver <$> simplifyContent a <*> simplifyContent b <*> simplifyContent c + +simplify (Elem (N "mtable") _ lst) = Xtable <$> lineList + where lineList = eitherMap $ map (unrow . elemOfContent) lst + + unrow (Elem (QN _ n) a b) = unrow (Elem (N n) a b) + unrow (Elem (N ('m':':':n)) a b) = unrow (Elem (N n) a b) + unrow (Elem (N "mtr") _ cells) = + eitherMap $ map (uncell . elemOfContent) cells + unrow _ = Left "Ill formed MathML Matrix" + + uncell (Elem (QN _ n) a b) = uncell (Elem (N n) a b) + uncell (Elem (N ('m':':':n)) a b) = uncell (Elem (N n) a b) + uncell (Elem (N "mtd") _ cellList) = + Xrow <$> eitherMap (map simplifyContent cellList) + uncell _ = Left "Ill format MathML Matrix cell" + +simplify (Elem (N "mfenced") [ (N "open", AttValue [Left openChar]) + , (N "close", AttValue [Left closeChar]) ] lst) = + + Xfenced openChar closeChar . Xrow <$> eitherMap (map simplifyContent lst) + +simplify (Elem (N "mfenced") attrs _lst) = Left $ show attrs + +simplify (Elem (N 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 +
+ Language/Eq/Linker.hs view
@@ -0,0 +1,276 @@+-- | This module will link variable names to +-- symbols. +module Language.Eq.Linker( DocString, LongDescr + , entityList + , metaFunctionList + , unaryFunctions + , multiParamsFunctions + , linkFormula + ) where + +import Data.List +import Data.Maybe( fromMaybe ) +import qualified Data.Map as Map + +import Language.Eq.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 )) + + , ("matrixWidth", ("Retrieve the width of a matrix" + , "" + , [("m", "a matrix")], matrixWidth)) + , ("matrixHeight", ("Retrieve the height of a matrix" + , "" + , [("m", "a matrix")], matrixHeight)) + ] + +matrixWidth :: [FormulaPrim] -> FormulaPrim +matrixWidth [m] = unOp OpMatrixWidth m +matrixWidth a = app (Variable "matrixWidth") a + +matrixHeight :: [FormulaPrim] -> FormulaPrim +matrixHeight [m] = unOp OpMatrixHeight m +matrixHeight a = app (Variable "matrixHeight") a + +lambdaBuilder :: [FormulaPrim] -> FormulaPrim +lambdaBuilder [] = app (Variable "Lambda") [] +lambdaBuilder lst@[_] = app (Variable "Lambda") lst +lambdaBuilder lst = meta LambdaBuild $ lambda [(init lst, last 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 +
+ Language/Eq/Polynome.hs view
@@ -0,0 +1,594 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Rank2Types #-} +module Language.Eq.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 Language.Eq.Types +import Language.Eq.Algorithm.Utils +import Language.Eq.FormulaIterator +import qualified Language.Eq.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 headSum + . 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] + where headSum lst@((o,_):_) = (o, sum $ map snd lst) + headSum [] = error "Polynome.hs - headSum - error Empty list" + +-------------------------------------------------- +---- 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" +
+ Language/Eq/Polynome.hs-boot view
@@ -0,0 +1,8 @@+module Language.Eq.Polynome where + +import {-# SOURCE #-} Language.Eq.Types + +convertToPolynome :: Formula ListForm -> Maybe Polynome +convertToFormula :: Polynome -> Formula ListForm +polyMap :: ((PolyCoeff, Polynome) -> (PolyCoeff, Polynome)) -> Polynome -> Polynome +
+ Language/Eq/Preprocessor.hs view
@@ -0,0 +1,223 @@+module Language.Eq.Preprocessor ( processFile + , LangDef( .. ) + , kindAssociation + ) where + +import System.FilePath +import Data.List +import Control.Applicative +import Text.Parsec.Error( ParseError ) + +import Language.Eq.Algorithm.Eval +import Language.Eq.Algorithm.Utils +import Language.Eq.InputParser.EqCode +import Language.Eq.Renderer.Ascii +import Language.Eq.Renderer.Cpp +import Language.Eq.EvaluationContext +import Language.Eq.Types +import Language.Eq.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 + + +
+ Language/Eq/Propreties.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +module Language.Eq.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 +
+ Language/Eq/QuasiQuote.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Language.Eq.Quasiquote( eqDefs ) where + +import Language.Eq.Algorithm.Eval +import Language.Eq.Types +import Language.Eq.EvaluationContext +import Language.Eq.InputParser.EqCode + +import qualified Data.Map as M + +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Language.Haskell.TH.Syntax + +-- | Quasi quote transforming Eq code into a symbol list +-- of type :: (String, Formula ListForm) +-- Usefull to prepare a pre-feed symbol table. +-- To use it, yout must use the following : +-- +-- @ +-- -- at the top of the file. +-- {-# LANGUAGE QuasiQuotes #-} +-- ... +-- -- in any expression +-- [eqDefs| myFunc(a,b) :> a ^ 2 + if(b < 0, 2, 3) |] +-- +-- -- you can put several definitions +-- [eqDefs| myFunc(a,b) :> a ^ 2 + if(b < 0, 2, 3); +-- myOtherFunc(a) :> listFromTo(0, a) |] +-- @ +-- +-- Compilation will fail if an error is found in the eq +-- syntax, giving you a (rather succint) error message +-- with some position information in the quotation. +eqDefs :: QuasiQuoter +eqDefs = QuasiQuoter { quoteExp = symbolTableExtractor + , quotePat = undefined + , quoteType = undefined + , quoteDec = undefined + } + +symbolTableExtractor :: String -> Q Exp +symbolTableExtractor str = case parseProgramm str of + Left err -> fail $ "Cannot parse the quasi quoted 'Eq' expression" + ++ show err + Right flist -> [e| elemList |] + where elemList = M.assocs $ context info + info = performLastTransformationWithContext M.empty + $ mapM evalGlobalLosslessStatement flist + + +instance Lift Double where + lift d = return . LitE . DoublePrimL $ toRational d + +instance Lift BinOperator where + lift = return . ConE . mkName . show + +instance Lift UnOperator where + lift = return . ConE . mkName . show + +instance Lift MetaOperation where + lift = return . ConE . mkName . show + +instance Lift Entity where + lift = return . ConE . mkName . show + +instance Lift (Formula ListForm) where + lift (Formula f) = [| Formula f |] + +instance Lift (Formula TreeForm) where + lift (Formula f) = [| Formula f |] + +instance Lift Rational where + lift = return . LitE . RationalL + +instance Lift PolyCoeff where + lift (CoeffFloat f) = [| CoeffFloat f |] + lift (CoeffInt i) = [| CoeffInt i |] + lift (CoeffRatio r) = [| CoeffRatio r |] + +instance Lift Polynome where + lift (Polynome s lst) = [| Polynome s lst |] + lift (PolyRest c) = [| PolyRest c |] + +instance Lift FormulaPrim where + lift (Variable str) = [| Variable str |] + lift (NumEntity entity) = [| NumEntity entity |] + lift (Truth b) = [| Truth b |] + lift (CInteger i) = [| CInteger i |] + lift (CFloat f) = [| CFloat f |] + lift (Fraction r) = [| Fraction r |] + lift (Complex i (e1, e2)) = [| Complex i (e1, e2) |] + lift (Indexes i e el) = [| Indexes i e el |] + lift (List i el) = [| List i el |] + lift (App i e el) = [| App i e el |] + lift (Sum i e1 e2 e3) = [| Sum i e1 e2 e3 |] + lift (Product i e1 e2 e3) = [| Product i e1 e2 e3 |] + lift (Derivate i e1 e2) = [| Derivate i e1 e2 |] + lift (Integrate i e1 e2 e3 e4) = [| Integrate i e1 e2 e3 e4 |] + lift (UnOp i op e) = [| UnOp i op e |] + lift (Lambda i lst) = [| Lambda i lst |] + lift (BinOp i op el) = [| BinOp i op el |] + lift (Matrix i n m el) = [| Matrix i n m el |] + lift (Poly i p) = [| Poly i p |] + lift (Block i1 i2 i3) = [| Block i1 i2 i3 |] + lift (Meta i op sub) = [| Meta i op sub |] +
+ Language/Eq/Renderer/Ascii.hs view
@@ -0,0 +1,657 @@+{-# LANGUAGE ScopedTypeVariables #-} +-- | Module in charge of rendering an equation in ASCII +-- provide sizing information and rendering +module Language.Eq.Renderer.Ascii( renderFormula + , formulaTextTable + , formatFormula ) where + +import Data.List( foldl' ) +import Data.Array.Unboxed +import Data.Maybe( fromMaybe ) +import Data.Ratio +import Language.Eq.Types +import Language.Eq.Renderer.Placer +import Language.Eq.Algorithm.Utils +import Language.Eq.Propreties +import Language.Eq.Polynome +import Language.Eq.Renderer.RenderConf + +import qualified Language.Eq.UnicodeSymbols as Unicode + +import Language.Eq.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 + 1 + sumW = maximum [iniw, endw, whath, 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 + 1 + 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] + 1 + 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 + max 2 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 + (w,h) = sizeOfTree sizeTree + size = ((0,0), (w - 1, h - 1)) + 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) (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" +
+ Language/Eq/Renderer/Ascii.hs-boot view
@@ -0,0 +1,8 @@+module Language.Eq.Renderer.Ascii where + +import Language.Eq.Types +import Language.Eq.Renderer.RenderConf + +formulaTextTable :: Conf -> Formula TreeForm -> [String] +formatFormula :: Conf -> Formula TreeForm -> String +
+ Language/Eq/Renderer/Ascii2DGrapher.hs view
@@ -0,0 +1,573 @@+-- | This module implement an ASCII Art graph plotter, +-- using subdivision to provide good looking ascii graph. +module Language.Eq.Renderer.Ascii2DGrapher( + -- * Plotting configuration + PlotConf( .. ) + , PlotingMode( .. ) + , ScalingType( .. ) + , Dimension( .. ) + , defaultPlotConf + + -- * Real ploting functions + , plotFunction + , plot2DExpression + , contourTrace2DExpression + ) where + +import Data.Bits +import Data.Array.Unboxed +import Text.Printf +import Numeric + +import Language.Eq.Algorithm.Eval +import Language.Eq.BaseLibrary +import Language.Eq.EvaluationContext +import Language.Eq.Types + +import qualified Language.Eq.Algorithm.StackVM.Stack as VM + +-- | Alias in case I want to change in the future. +type ValueType = Double + +-- | (Begin, End), all inclusive +type PlotRange = (ValueType, ValueType) + +data PlotingMode = + RegularPlot + | CountourPlot + deriving Show + +data ScalingType = + Linear + | Logarithmic + deriving Show + +data Dimension = Dimension + { minVal :: ValueType + , maxVal :: ValueType + , projectionSize :: Int + , scaling :: ScalingType + , drawAxis :: Bool + , labelPrecision :: Int + , labelEvery :: Maybe Int + } + deriving Show + +data PlotConf = PlotConf + { xDim :: Dimension + , yDim :: Dimension + , draw0Axis :: Bool + , mode :: PlotingMode + , graphTitle :: Maybe String + } + deriving Show + +defaultPlotConf :: PlotConf +defaultPlotConf = PlotConf + { xDim = Dimension + { minVal = 0.0 + , maxVal = 10.0 + , projectionSize = 50 + , scaling = Linear + , drawAxis = False + , labelPrecision = 4 + , labelEvery = Just 7 + } + + , yDim = Dimension + { minVal = -5.0 + , maxVal = 5.0 + , projectionSize = 30 + , scaling = Linear + , drawAxis = False + , labelPrecision = 4 + , labelEvery = Just 4 + } + + , mode = RegularPlot + , draw0Axis = False + , graphTitle = Nothing + } + +wrappedEvaluation :: Formula ListForm -> Double -> Double -> Double +wrappedEvaluation formula x y = valuaize . unTagFormula $ result rez + where def = [ Formula $ binOp OpAttrib [Variable "y", CFloat y] + , Formula $ binOp OpAttrib [Variable "x", CFloat x] + , formula ] + rez = performLastTransformationWithContext defaultSymbolTable + $ mapM evalGlobalLossyStatement def + + valuaize (CInteger i) = fromInteger i + valuaize (CFloat f) = f + valuaize (Fraction f) = fromRat f + valuaize _ = 1.0 / 0.0 + +doubleShow :: Dimension -> ValueType -> String +doubleShow dim = printf "%.*f" (labelPrecision dim) + +dimensionRange :: Dimension -> PlotRange +dimensionRange dim = (minVal dim, maxVal dim) + +canvasSize :: PlotConf -> (Int, Int) +canvasSize conf = ( projectionSize $ xDim conf + , projectionSize $ yDim conf) + +-- | Translate a list of write on the x (width) axis with +-- a given amount. Perform no operation if translation amount +-- is 0. +translateX :: Int -> [((Int, Int), Char)] -> [((Int, Int), Char)] +translateX 0 lst = lst +translateX i lst = [ ((x + i, y), c) | ((x,y), c) <- lst ] + +-- | Same thing as 'translateX' but with the y (height) axis. +translateY :: Int -> [((Int, Int), Char)] -> [((Int, Int), Char)] +translateY 0 lst = lst +translateY i lst = [ ((x, y + i), c) | ((x,y), c) <- lst ] + +-- | Add some vertical labels +addYAxisLabel :: Dimension -> ValSuccessor -> CharCanvas -> CharCanvas +addYAxisLabel dim successor rez@(((xPos, shiftHeight), adds), vals) = + case (drawAxis dim, labelEvery dim) of + (_, Nothing) -> rez + (False, _) -> rez + (True, Just size) -> + (((xShift, shiftHeight), adds), vals' ++ draw shiftHeight (minVal dim)) + where maxHeight = projectionSize dim + shiftHeight + + xShift = max 8 xPos + vals' = translateX (xShift - xPos) vals + + apply val 0 = val + apply val times = apply (successor val) $ times - 1 + + draw y yVal + | y >= maxHeight = [] + | otherwise = + let indicator = ((xShift - 1, y), '+') + future = draw (y + size) (apply yVal size) + in indicator : + [((xP, y), c) | (xP, c) <- zip [0.. xShift - 2] + $ doubleShow dim yVal] ++ + future + +-- | Represent a tuple of canvas extension and a list +-- of characters. It's ((leftAdd, bottomAdd), (rightAdd, topAdd)) +type CharCanvas = + (((Int,Int),(Int,Int)), [((Int,Int), Char)]) + +addXAxisLabel :: Dimension -> ValSuccessor -> CharCanvas -> CharCanvas +addXAxisLabel dim successor rez@(((shiftWidth, yPos), (addX, addY)), vals) = + case (drawAxis dim, labelEvery dim) of + (_, Nothing) -> rez + (False, _) -> rez + (True, Just size) -> + (((shiftWidth, yPos) + ,(rightShift, addY) ), vals ++ draw shiftWidth (minVal dim)) + where maxWidth = projectionSize dim + shiftWidth + + apply val 0 = val + apply val times = apply (successor val) $ times - 1 + + rightShift = max addX + $ size - (projectionSize dim `rem` size) + + draw x xVal + | x >= maxWidth = [] + | otherwise = + let indicator = ((x - 1,1), '|') + future = draw (x + size) (apply xVal size) + in indicator : [((xPos, 0), c) + | (xPos, c) <- zip [x - 1.. x + size - 3] + $ doubleShow dim xVal] ++ future + +addTitle :: PlotConf -> Maybe String -> CharCanvas -> CharCanvas +addTitle _ Nothing a = a +addTitle conf (Just t) (((shiftWidth, shiftHeight), adds), vals) = + (((shiftWidth, shiftHeight + 2), adds), toAdd ++ translateY 2 vals) + where begin = (projectionSize (xDim conf) - length t) `div` 2 + toAdd = [((x,0), c) | (x,c) <- zip [begin ..] t] + +add0Axis :: PlotConf -> Scaler -> CharCanvas -> CharCanvas +add0Axis conf scaler original@(((shiftWidth, shiftHeight), adds), vals) = + if y < 0 then original else + ( ((wShift, shiftHeight), adds) + , ((wShift - nominalShift + 1, y), '0') : + line ++ translateX valShift vals) + where w = projectionSize $ xDim conf + h = projectionSize $ yDim conf + y = scaler 0 + line = if y >= 0 && y < h + then [((x, y), '-') | + x <- [wShift .. wShift + (w - 1)]] + else [] + nominalShift = 4 + wShift = max nominalShift shiftWidth + valShift = if shiftWidth >= nominalShift + then shiftWidth - wShift + else wShift - shiftWidth + +addYAxis :: PlotConf -> Scaler -> CharCanvas -> CharCanvas +addYAxis conf _scaler (((shiftWidth, shiftHeight), adds), vals) = + ( ((wShift, shiftHeight), adds) + , line ++ translateX valShift vals) + where h = projectionSize $ yDim conf + x = nominalShift - 1 + line = [((x, y), '|') | + y <- [shiftHeight .. shiftHeight + (h - 1)]] + nominalShift = 4 + wShift = max nominalShift shiftWidth + valShift = if shiftWidth >= nominalShift + then shiftWidth - wShift + else wShift - shiftWidth + + +addXaxis :: PlotConf -> Scaler -> CharCanvas -> CharCanvas +addXaxis conf _ (((shiftWidth, shiftHeight), adds), vals) = + ( ((shiftWidth, hShift), adds) + , line ++ translateY valShift vals) + where line = [((x, hShift - 1), '_') + | x <- [shiftWidth ..(w - 1) + shiftWidth]] + w = projectionSize $ xDim conf + nominalShift = 2 + hShift = max nominalShift shiftHeight + valShift = hShift - shiftHeight + +-- | Equivalent of 'when' but non-monadic. +doWhen :: Bool -> (a -> a) -> a -> a +doWhen False _ a = a +doWhen True f a = f a + +-- | Function in charge of adding all the plot axis +-- to the generated character stream +addAxis :: PlotConf + -> (Scaler, Scaler) + -> (ValSuccessor, ValSuccessor) + -> [((Int, Int), Char)] + -> CharCanvas +addAxis conf (widthScaler, heightScaler) (xSucc, ySucc) a = + doWhen (graphTitle conf /= Nothing) + (addTitle conf $ graphTitle conf) + . doWhen (labelEvery (yDim conf) /= Nothing) + (addYAxisLabel (yDim conf) ySucc) + . doWhen (drawAxis $ yDim conf) + (addYAxis conf heightScaler) + . doWhen (labelEvery (xDim conf) /= Nothing) + (addXAxisLabel (xDim conf) xSucc) + . doWhen (drawAxis $ xDim conf) + (addXaxis conf widthScaler) + . doWhen (draw0Axis conf) + (add0Axis conf heightScaler) $ (((0,0), (0,0)), a) + +plotFunction :: PlotConf -> FormulaPrim + -> Either String (UArray (Int, Int) Char) +plotFunction conf@(PlotConf { mode = RegularPlot }) = + plot2DExpression conf +plotFunction conf@(PlotConf { mode = CountourPlot}) = + contourTrace2DExpression conf + +preparePlotFunction :: FormulaPrim -> (ValueType -> ValueType -> ValueType) +preparePlotFunction formula = + case VM.compileExpression formula of + Left _ -> wrappedEvaluation $ Formula formula + Right prog -> VM.evalProgram prog + +-- | User function to start a plot. Handle all the scary +-- configuration before starting the plot. +plot2DExpression :: PlotConf -> FormulaPrim + -> Either String (UArray (Int, Int) Char) +plot2DExpression conf formula = + let successor = widthSuccessor $ xDim conf + (_,ySuccessor) = widthSuccessor $ yDim conf + yScaler = sizeMapper $ yDim conf + xScaler = sizeMapper $ xDim conf + (xBegin, xEnd) = dimensionRange $ xDim conf + size@(w, h) = canvasSize conf + graph = plot2D size xEnd + (flip (preparePlotFunction formula) 0) + successor xScaler yScaler + xBegin + (((shiftX, shiftY), (addX, addY)), graph') = + addAxis conf (xScaler, yScaler) (snd successor, ySuccessor) graph + in Right $ accumArray (\_ e -> e) ' ' + ((0, 0) ,(w + shiftX + addX - 1, h + shiftY + addY - 1)) $ + [v | v@((x,_),_) <- graph', + x < w + shiftX + addX, + x >= 0] + + +-- | This type is a transformation from function +-- result to screen space. +type Scaler = ValueType -> Int + +-- | Function used to find the next \'x\' element +-- to be plotted. +type ValSuccessor = + ValueType -> ValueType + +-- | Equivalent of the 'succ' function of the +-- 'Enum' class, with a linear scale. +widthSuccessor :: Dimension -> (ValSuccessor, ValSuccessor) +widthSuccessor dim = case (scaling dim, minVal dim > 0) of + (Linear, _) -> (\v -> v - addVal, \v -> v + addVal) + where addVal = (vMax - vMin) / toEnum (projectionSize dim - 2) + (vMin, vMax) = dimensionRange dim + (Logarithmic, True) -> (\v -> v / mulVal,\v -> v * mulVal) + where mulVal = (vMax / vMin) ** (1.0 / toEnum (projectionSize dim - 1)) + (vMin, vMax) = dimensionRange dim + (Logarithmic, False) -> (\v -> vPrev (v + vAdd) - vAdd + ,\v -> vNext (v + vAdd) - vAdd) + where (vMin, vMax) = dimensionRange dim + bigpsilon = 0.1 + vAdd = 0.1 + negate vMin + (vPrev, vNext) = widthSuccessor $ + dim { minVal = bigpsilon + , maxVal = vMax - vMin + bigpsilon} + + +-- | How to map the height value onto the screen, +-- by taking tinto action the 'canvas' size +sizeMapper :: Dimension -> (ValueType -> Int) +sizeMapper dim = + let (vMin, vMax) = dimensionRange dim + fullSize = projectionSize dim + in case (scaling dim, vMin > 0) of + (Linear, _) -> \val -> truncate $ (val - vMin) * scaler + where scaler = toEnum fullSize / (vMax - vMin + 1) + + (Logarithmic, True) -> \val -> truncate $ (log val - vMin') * scaler + where (vMin', vMax') = (log vMin, log vMax) + scaler = toEnum fullSize / (abs (vMax' - vMin') + 1) + + (Logarithmic, False) -> \val -> truncate $ (log $ val - vMin') * scaler + where (vMin', vMax') = (log 0.1, log $ vMax - vMin) + scaler = toEnum fullSize / (abs (vMax' - vMin') + 1) + + +-- | Describe the action that the plotter must +-- accomplish in order to draw a function +data DrawAction = + ActionStop -- ^ Stop the ploting/subdivision for this value + | SubdivideBoth Char -- ^ Halve the x interval and continue plotting, on both ends + | SubdivideUpper Char -- ^ Halve and continue only on the upper part. + | SubdivideLower Char -- ^ Halve and continue only on the lower part. + | SubdivideIgnore -- ^ Halve and continue both ends but don't write any char. + | Continue Char -- ^ Continue with the current interval, adn write a char. + +neighbour :: ValueType -> ValueType -> Bool +neighbour y1 y2 = abs (y1 - y2) < 0.05 + +-- | Given a successor function given as parameter, +-- it will return a successor function going half +-- as far as the previous one. Work with backward +-- functions to. +rangeSplitter :: ValSuccessor -> ValSuccessor +rangeSplitter f x = x + (f x - x) / 2 + +-- | As side is inversed when drawing backward, +-- this function help to choose a representation +-- given the current direction and a 'Forward' +-- assention or 'Backward' descent. +sideChar :: Direction -- ^ Current drawing direction + -> Direction -- ^ Assention or descent + -> Char +sideChar Forward Forward = '/' +sideChar Forward Backward = '\\' +sideChar Backward a = sideChar Forward $ inverseDirection a + +-- | Given two samples, give an Ascii representation +-- and information to the plotter on how to continue +-- the drawing. +charOf :: Direction -- ^ Current plotting direction + -> Int -- ^ Canvas height + -> Int -- ^ Absciss in canvas space of the previous value. + -> (ValueType, Int) -- ^ Value and canvas position of the current value. + -> (ValueType, Int) -- ^ Value and canvas position of the current value. + -> DrawAction -- ^ What to do next +charOf direction height screenPrev (y1, screenY1) (y2, screenY2) + | isNaN y1 = ActionStop + | isInfinite y1 && screenY1 >= 0 && screenY1 < height = + SubdivideBoth '|' + | isInfinite y1 = SubdivideIgnore + -- We are out of the drawing box, stop + -- the drawing for the current value of x + | screenY1 >= height || screenY1 < 0 = ActionStop + + + -- The two values are in a different cell, + -- we need to refine the values. + | abs (screenY1 - screenY2) > 1 && abs (screenY1 - screenPrev) > 1 + = SubdivideBoth '|' + + | abs (screenY1 - screenY2) > 1 = SubdivideUpper '|' + + | abs (screenY1 - screenPrev) > 1 = SubdivideLower '|' + + -- If values are sufisently near, draw a flat + -- line and continue + | neighbour y1 y2 = Continue '-' + + -- We are ascending, but not enough to subdivide, + -- continue to the next x + | y1 < y2 = Continue $ sideChar direction Forward + + -- Descending... + | y1 > y2 = Continue $ sideChar direction Backward + + -- y1 more or less equal y2 + | otherwise = Continue '-' + + +-- | Happy float +epsilon :: ValueType +epsilon = 0.00000000000001 + +-- | Type used when plotting, to inform +-- the subdivision direction. +data Direction = Forward | Backward + deriving Eq + +-- | Inverse the direction, equivalent of +-- 'not', but for 'Direction' +inverseDirection :: Direction -> Direction +inverseDirection Forward = Backward +inverseDirection Backward = Forward + +-- | The real plotting function, calling it is rather complex, +-- due to the number of thing to take into account, favor the use +-- of a more high level function like 'plot2DExpression' +plot2D :: (Int, Int) -- ^ Size of the canvas in number of cells + -> ValueType -- ^ End value for x + -> (ValueType -> ValueType) -- ^ The function to be evaluated + -> (ValSuccessor, ValSuccessor) -- ^ x Successor function, backward, forward, + -> Scaler -- ^ Function to translate xVal to canvas position + -> Scaler -- ^ Function to translate (f xVal) to canvas position + -> ValueType -- ^ The \'current\' ploted value, xBegin for first call + -> [((Int, Int),Char)] -- ^ Woohoo, the result, to be stored in an array +plot2D (_width, height) xStop f widthSucc xPlot yPlot xInit = + subPlot widthSucc (xInit - epsilon, xStop) Forward 0 xInit + where subPlot successors@(xPrev, xSucc) + interval@(xBegin, xEnd) + direction prevScreen x + | direction == Forward && (x <= xBegin || x >= xEnd) = [] + | direction == Backward && (x <= xEnd || x >= xBegin) = [] + | otherwise = + let val = f x + xNext = if direction == Forward then xSucc x + else xPrev x + screenY = yPlot val + midPoint = (x + xNext) / 2 + halfSuccessors@(halfPrev, halfSucc) = + (rangeSplitter $ rangeSplitter xPrev + ,rangeSplitter $ rangeSplitter xSucc) + + (subPrev, subSucc) = if direction == Forward + then (halfPrev, halfSucc) + else (halfSucc, halfPrev) + midInfo = yPlot $ f midPoint + + lowerRange = subPlot halfSuccessors + (midPoint, xBegin) + (inverseDirection direction) + midInfo + $ subPrev midPoint + + upperRange = subPlot halfSuccessors + (midPoint, xNext) + direction + midInfo + $ subSucc midPoint + + midChar = if midInfo > 0 && midInfo < height + then [((xPlot midPoint, midInfo), '|')] + else [] + future = subPlot successors interval direction + screenY xNext + + + in case charOf direction height prevScreen + (val, screenY) (f xNext, yPlot $ f xNext) of + ActionStop -> future + Continue c -> ((xPlot x, screenY), c) : future + + SubdivideLower c -> + lowerRange ++ midChar ++ ((xPlot x, screenY),c) : future + SubdivideUpper c -> + upperRange ++ midChar ++ ((xPlot x, screenY),c) : future + SubdivideBoth c -> + lowerRange ++ upperRange ++ + midChar ++ ((xPlot x, screenY),c) : future + SubdivideIgnore -> + lowerRange ++ upperRange ++ midChar ++ future + +-- 3|0 => 8|1 +-- 2|1 4|2 +metaBallChars :: Array Int Char +metaBallChars = array (0, 16 - 1) + [ (0x0, ' ') + , (0x1, '\'') + , (0x2, '.') + , (0x3, '|') + , (0x4, ',') + , (0x5, '/') + , (0x6, '-') + , (0x7, '\'') + , (0x8, '"') + , (0x9, '-') + , (0xA, '\\') + , (0xB, ',') + , (0xC, '|') + , (0xD, '.') + , (0xE, '\'') + , (0xF, ' ') + ] + +-- | User function to make a "contour plot" of a formula. +contourTrace2DExpression :: PlotConf -> FormulaPrim + -> Either String (UArray (Int, Int) Char) +contourTrace2DExpression conf formula = + let size@(w, h) = canvasSize conf + graph = metaBall2D size (preparePlotFunction formula) (< 0.001) + (dimensionRange linearXdim) (dimensionRange linearYdim) + + linearXdim = (xDim conf) { scaling = Linear } + linearYdim = (yDim conf) { scaling = Linear } + + successor = widthSuccessor linearXdim + (_,ySuccessor) = widthSuccessor linearYdim + yScaler = sizeMapper linearYdim + xScaler = sizeMapper linearXdim + + (((shiftX, shiftY), (addX, addY)), graph') = + addAxis conf (xScaler, yScaler) (snd successor, ySuccessor) graph + in Right $ accumArray (\_ e -> e) ' ' + ((0, 0) ,(w + shiftX + addX - 1, h + shiftY + addY - 1)) $ + [v | v@((x,_),_) <- graph', + x < w + shiftX + addX, + x >= 0] + +metaBall2D :: (Int, Int) + -> (ValueType -> ValueType -> ValueType) + -> (ValueType -> Bool) + -> (ValueType, ValueType) + -> (ValueType, ValueType) + -> [((Int,Int), Char)] +metaBall2D (width, height) f thresholdFunction (xMin, xMax) (yMin, yMax) = + [((x,y), calcChar (toEnum x * xStep + xMin) + $ toEnum y * yStep + yMin)| x <- [0..width - 1] + , y <- [0..height - 1]] + where xStep = (xMax - xMin) / toEnum width + yStep = (yMax - yMin) / toEnum height + + halfX = xStep / 2 + halfY = yStep / 2 + deltas = [ (halfX, halfY), (halfX, -halfY) + , (-halfX,-halfY), (-halfX, halfY)] + + fBit x y = fromEnum . thresholdFunction $ f x y + + calcChar x y = + let idx = foldl1 (.|.) + [fBit (x + dx) (y + dy) `shiftL` bitIdx + | ((dx, dy), bitIdx) <- zip deltas [0..]] + in metaBallChars ! idx +
+ Language/Eq/Renderer/CharRender.hs view
@@ -0,0 +1,219 @@+module Language.Eq.Renderer.CharRender( CharacterSoup, CharacterSoupS + , renderFormula, renderFormulaS + ) where + +{-import Data.List( foldl' )-} +import Language.Eq.Types +import Language.Eq.Renderer.Placer +{-import Language.Eq.Algorithm.Utils-} +import Language.Eq.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" +
+ Language/Eq/Renderer/Cpp.hs view
@@ -0,0 +1,161 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} +module Language.Eq.Renderer.Cpp( convertToCpp, convertToCppS ) where + +import Control.Monad.State.Lazy +import Control.Applicative +import Data.Ratio + +import Language.Eq.Types +import Language.Eq.Polynome +import Language.Eq.Algorithm.Utils +import qualified Language.Eq.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 + +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 = "" +unOpEr OpMatrixWidth = "" +unOpEr OpMatrixHeight = "" + +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 +
+ Language/Eq/Renderer/EqCode.hs view
@@ -0,0 +1,130 @@+module Language.Eq.Renderer.EqCode( unparse, unparseS ) where + +import Data.List( foldl' ) +import Data.Ratio + +import Language.Eq.Types +import Language.Eq.Propreties +import Language.Eq.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) . (')':) +
+ Language/Eq/Renderer/Latex.hs view
@@ -0,0 +1,152 @@+module Language.Eq.Renderer.Latex ( latexRender, latexRenderS ) where + +import Data.Ratio + +import Language.Eq.Types +import Language.Eq.Polynome +import Language.Eq.Algorithm.Utils +import Language.Eq.Propreties + +import Language.Eq.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 + +
+ Language/Eq/Renderer/Mathml.hs view
@@ -0,0 +1,307 @@+module Language.Eq.Renderer.Mathml( mathmlRender ) where + +import Data.Ratio + +import Language.Eq.Types hiding ( matrix ) +import Language.Eq.Algorithm.Utils +import Language.Eq.Propreties +import Language.Eq.Polynome + +import Language.Eq.Renderer.Latex +import Language.Eq.Renderer.EqCode +import Language.Eq.Renderer.RenderConf + +mathmlRender :: Conf -> Formula TreeForm -> String +mathmlRender conf (Formula f) = + str "<?xml version=\"1.0\" encoding=\"utf-16\" ?>" + . str "<math xmlns=\"http://www.w3.org/1998/Math/MathML\">\n" + . presMarkup + . semantics (semanticML . inlineEq . inlineLatex) + . str "</math>\n" $ "" + where contentMarkup = content f + + semanticML = if includeSemanticMathML conf + then annotation "MathML-Content" contentMarkup + else id + + inlineEq = if includeEqInMathML conf + then annotation "Eq-language" (str . cleanify $ unparse f) + else id + + inlineLatex = if includeLaTeXInMathML conf + then annotation "LaTeX" (str . cleanify . latexRender conf $ Formula f) + else id + + 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, msub :: 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" +msub = tagger "msub" +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" + +-- Don't want special cases for them, so we just rewrite them (yes, fucking lazy) +presentation conf sup (Fraction f) = + presentation conf sup $ CInteger (denominator f) / CInteger (numerator f) +presentation c sup (Poly _ p) = + presentation c sup . unTagFormula . treeIfyFormula $ convertToFormula p +presentation conf sup (Complex _ (re, im)) = + presentation conf sup $ re + Variable "i" * im + +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 + +presentation _ _ (BinOp _ _ _) = str "wrong_binary_form" + +-- 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 conf _ (Indexes _ src im) = + msub ( prez conf src + . (interspereseS (mo $ char ',') $ map (prez conf) im) + ) + +presentation conf _ (List _ lst) = + enclose '[' ']' . interspereseS (mo $ char ',') $ map (prez conf) lst + +----------------------------------------------- +---- 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>" +stringOfUnOp OpMatrixWidth = "matrixWidth" +stringOfUnOp OpMatrixHeight = "matrixHeight" + +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 +
+ Language/Eq/Renderer/Placer.hs view
@@ -0,0 +1,295 @@+module Language.Eq.Renderer.Placer( SizeTree( .. ) + , Dimensioner( .. ) + , Dimension, BaseLine, RelativePlacement + , sizeExtract + , baseLineOfTree + , sizeTreeOfFormula + , sizeOfTree + , maxPrio + ) where + +import Data.List( foldl', transpose ) +import Data.Ratio + +import Language.Eq.Types +import Language.Eq.Polynome +import Language.Eq.Algorithm.Utils +import Language.Eq.Propreties +import Language.Eq.Renderer.RenderConf +import qualified Language.Eq.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 +
+ Language/Eq/Renderer/RenderConf.hs view
@@ -0,0 +1,58 @@+module Language.Eq.Renderer.RenderConf( confLoad + , Conf( .. ) + , defaultRenderConf + ) where + +import Data.Char( isSpace ) + +data Conf = Conf + { mulAsDot :: Bool + , packNumVarMul :: Bool + , noBigOpOverSize :: Bool + , useUnicode :: Bool + + , includeLaTeXInMathML :: Bool + , includeEqInMathML :: Bool + , includeSemanticMathML :: Bool + } + +defaultRenderConf :: Conf +defaultRenderConf = Conf + { mulAsDot = True + , packNumVarMul = False + , noBigOpOverSize = False + , useUnicode = False + , includeLaTeXInMathML = False + , includeEqInMathML = False + , includeSemanticMathML = 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 +
+ Language/Eq/Renderer/Sexpr.hs view
@@ -0,0 +1,94 @@+module Language.Eq.Renderer.Sexpr( sexprRender, sexprRenderS ) where + +import Data.Ratio +import Language.Eq.Types +import Language.Eq.Polynome +import Language.Eq.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) = str"(% " . shows (numerator f) + . str " " + . shows (denominator f) + . str ") " +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 ')' +
+ Language/Eq/Renderer/Sexpr.hs-boot view
@@ -0,0 +1,7 @@+module Language.Eq.Renderer.Sexpr where + +import {-# SOURCE #-} Language.Eq.Types + +sexprRender :: Formula anyForm -> String +sexprRenderS :: Formula anyForm -> ShowS +
+ Language/Eq/Repl.hs view
@@ -0,0 +1,84 @@+module Language.Eq.Repl( repl ) where + +import qualified Data.Map as Map + +import Language.Eq.Algorithm.Utils +import Language.Eq.Types +import Language.Eq.Renderer.Ascii +import Language.Eq.Renderer.RenderConf +import Language.Eq.BaseLibrary +import Language.Eq.InputParser.EqCode +import Language.Eq.EvaluationContext + +import System.IO + +type Context = Map.Map String (Formula ListForm) +type Evaluator = Formula ListForm -> EqContext (Formula ListForm) + + +data ReplInfo = + ValidContext !Int !Context + | EndOfRepl + +repl :: Evaluator -> IO () +repl evaluator = do + putStrLn "Eq - interactive mode" + putStrLn "exit to quit the program\n" + doer (ValidContext 1 $ defaultSymbolTable `Map.union` initialReplContextInfo) + + where doer c@(ValidContext _ _) = evalExpr evaluator c >>= doer + doer EndOfRepl = 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 + +queryVarName, answerVarName :: String +queryVarName = "query" +answerVarName = "answers" + +initialReplContextInfo :: Context +initialReplContextInfo = Map.fromList + [ (answerVarName, Formula $ list []), (queryVarName, Formula $ list [])] + +addToList :: Formula ListForm -> Formula ListForm -> Formula ListForm +addToList (Formula toAdd) (Formula (List _ lst)) = Formula . list $ lst ++ [toAdd] +addToList _ f = f + +evalExpr :: Evaluator -> ReplInfo -> IO ReplInfo +evalExpr operation ctxt@(ValidContext askId prevContext) = do + putStr $ '[' : show askId ++ "] > " + hFlush stdout + exprText <- getLine + case exprText of + [] -> evalExpr operation ctxt + "exit" -> return EndOfRepl + _ -> do + let formulaList = parseProgramm exprText + either (parseErrorPrint ctxt) + (\formulal -> do + let rez = performLastTransformationWithContext prevContext + $ mapM operation formulal + + printErrors $ errorList rez + putStr . formatFormula defaultRenderConf + . treeIfyFormula $ result rez + let transformedContext = context rez + answers = transformedContext Map.! answerVarName + queries = transformedContext Map.! queryVarName + newInfo = Map.fromList + [(answerVarName, result rez `addToList` answers) + ,(queryVarName, last formulal `addToList` queries)] + return . ValidContext (askId + 1) + $ newInfo `Map.union` transformedContext + ) + formulaList +evalExpr _ EndOfRepl = return EndOfRepl +
+ Language/Eq/Types.hs view
@@ -0,0 +1,761 @@+{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleInstances #-} +module Language.Eq.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.Data +import Data.Ord( comparing ) +import Data.Monoid( Monoid( .. ), getSum ) +import qualified Data.Monoid as Monoid +import qualified Language.Eq.ErrorMessages as Err + +import Data.Bits +import Data.Ratio +import Data.List( foldl', foldl1' ) +import Data.Maybe( fromJust ) + +import Language.Eq.Propreties +import {-# SOURCE #-} Language.Eq.Polynome() +import {-# SOURCE #-} Language.Eq.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 + + | OpMatrixWidth | OpMatrixHeight + 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, Typeable) + +-- | 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 _) = LT + + -- 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") + + , (OpMatrixWidth, "matrixWidth") + , (OpMatrixHeight, "matrixHeight") + ] + +------------------------------------------- +---- 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 +
+ Language/Eq/Types.hs-boot view
@@ -0,0 +1,7 @@+module Language.Eq.Types where + +data Formula a +data ListForm +data PolyCoeff +data Polynome +
+ Language/Eq/UnicodeSymbols.hs view
@@ -0,0 +1,645 @@+module Language.Eq.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", Language.Eq.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
@@ -1,59 +0,0 @@-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-
formulaMain.hs view
@@ -1,457 +1,447 @@-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--import EqManips.Renderer.Ascii2DGrapher--import CharArray--#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, foldl' )-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-- -- for plotting- | PlotWidth- | PlotHeight- | XBeg- | XEnd- | YBeg- | YEnd- | XLogScale- | YLogScale- | DrawXaxis- | DrawYaxis- | Draw0axis-- | NoDrawXLabel- | NoDrawYLabel-- | XLabelPrecision- | YLabelPrecision-- | XLabelSpacing- | YLabelSpacing-- | PlotTitle- deriving (Eq, Show)--version :: String-version = "1.1"--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"- ]--plotOption :: [OptDescr (Flag, String)]-plotOption =- [ Option "x" ["xBegin"] (ReqArg ((,) XBeg) "XBEG") "Beginning of plot (x), float"- , Option "" ["xe", "xEnd"] (ReqArg ((,) XEnd) "XEND") "End of plot (x), float"- , Option "y" ["yBegin"] (ReqArg ((,) YBeg) "YBEG") "Beginning of plot (y), float"- , Option "" ["ye", "yEnd"] (ReqArg ((,) YEnd) "YEnd") "End of plot (y), float"- , Option "w" ["width"] (ReqArg ((,) PlotWidth) "Width") "Plotting width, int"- , Option "h" ["height"] (ReqArg ((,) PlotHeight) "height") "Plotting height, int"- , Option "" ["lx", "logwidth"] (NoArg (XLogScale,""))- "Plot with a logrithmic scale in x"- , Option "" ["ly", "logheight"] (NoArg (YLogScale,""))- "Plot with a logrithmic scale in y"- , Option "" ["ax", "xaxis"] (NoArg (DrawXaxis,""))- "Draw the X axis on the graph"- , Option "" ["ay", "yaxis"] (NoArg (DrawYaxis,""))- "Draw the Y axis on the graph"- , Option "" ["a0", "zeroaxis"] (NoArg (Draw0axis,""))- "Draw the 0 axis on the graph"- , Option "" ["nlx", "nolabelx"] (NoArg (NoDrawXLabel,""))- "Don't draw label on x Axis"- , Option "" ["nly", "nolabely"] (NoArg (NoDrawYLabel,""))- "Don't draw label on Y Axis"- , Option "" ["lpx", "xlabelprecision"] - (ReqArg ((,) XLabelPrecision) "p") - "Display label on x axis with 'p' decimals"- , Option "" ["lpy", "ylabelprecision"] - (ReqArg ((,) YLabelPrecision) "p") - "Display label on y axis with 'p' decimals"- , Option "" ["spx", "labelspacingx"]- (ReqArg ((,) XLabelSpacing) "s")- "Put a label evry 's' chars on x axis"- , Option "" ["spy", "labelspacingy"]- (ReqArg ((,) YLabelSpacing) "s")- "Put a label evry 's' chars on y axis"- , Option "t" ["title"]- (ReqArg ((,) PlotTitle) "t")- "Add a title t under the graph"- ]--preparePlotConf :: PlotConf -> (Flag, String) -> PlotConf-preparePlotConf conf (PlotWidth, val) = - conf { xDim = (xDim conf){ projectionSize = read val } }-preparePlotConf conf (PlotHeight, val) =- conf { yDim = (yDim conf){ projectionSize = read val }}-preparePlotConf conf (XBeg, val) =- conf { xDim = (xDim conf){ minVal = read val }}-preparePlotConf conf (XEnd, val) =- conf { xDim = (xDim conf){ maxVal = read val }}-preparePlotConf conf (YBeg, val) =- conf { yDim = (yDim conf){ minVal = read val }}-preparePlotConf conf (YEnd, val) =- conf { yDim = (yDim conf){ maxVal = read val }}-preparePlotConf conf (XLogScale, _) =- conf { xDim = (xDim conf){ scaling = Logarithmic } }-preparePlotConf conf (YLogScale, _) =- conf { yDim = (yDim conf){ scaling = Logarithmic } }-preparePlotConf conf (DrawXaxis, _) =- conf { xDim = (xDim conf){ drawAxis = True } }-preparePlotConf conf (DrawYaxis, _) =- conf { yDim = (yDim conf){ drawAxis = True } }-preparePlotConf conf (Draw0axis, _) =- conf { draw0Axis = True }-preparePlotConf conf (NoDrawXLabel, _) =- conf { xDim = (xDim conf){ labelEvery = Nothing } }-preparePlotConf conf (NoDrawYLabel, _) =- conf { yDim = (yDim conf){ labelEvery = Nothing } }-preparePlotConf conf (XLabelSpacing, val) =- conf { xDim = (xDim conf){ labelEvery = Just $ read val} }-preparePlotConf conf (YLabelSpacing, val) =- conf { yDim = (yDim conf){ labelEvery = Just $ read val} }-preparePlotConf conf (XLabelPrecision, val) =- conf { xDim = (xDim conf){ labelPrecision = read val} }-preparePlotConf conf (YLabelPrecision, val) =- conf { yDim = (yDim conf){ labelPrecision = read val} }-preparePlotConf conf (PlotTitle, val) =- conf { graphTitle = Just val }-preparePlotConf conf _ = conf--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, rest, _) = getOpt Permute formatOption args- (input, outputFile) = getInputOutput opt rest---- | 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, rest, _) = getOpt Permute formatOption args- (input, outputFile) = getInputOutput opt rest- 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, rest, _) = getOpt Permute formatOption args- (input, outputFile) = getInputOutput opt rest- conf = defaultRenderConf{ useUnicode = Unicode `lookup` opt /= Nothing }--plotCommand :: [String] -> IO Bool-plotCommand args = do- formulaText <- input- finalFile <- outputFile-- let formulaList = parseProgramm formulaText- either (parseErrorPrint finalFile)- (\formulal -> do- case plot2DExpression plotConf . unTagFormula $ head formulal of- Left err -> do- Io.hPutStr finalFile err- hClose finalFile- return False-- Right v -> do- Io.hPutStr finalFile $ charArrayToString v- return True)- formulaList- where (opt, rest, _) = getOpt Permute (commonOption ++ plotOption) args- plotConf = foldl' preparePlotConf defaultPlotConf - opt- (input, outputFile) = getInputOutput opt rest--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)- , ("plot", "Print an ASCII-art plot of the given function"- , plotCommand, commonOption ++ plotOption)- ]--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- +--import CharArray + +#ifdef _DEBUG +import Language.Eq.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, foldl' ) +import Data.Maybe( fromMaybe ) + +import qualified Data.Map as Map + +import Language.Eq +import Language.Eq.CharArray +import Language.Eq.Repl + +-- Debugging +{-import EqManips.Renderer.CharRender-} + +data Flag = + Output + | Input + | Unicode + | SupportedFunction + | SupportedOperators + | SupportedPreprocLanguages + + -- for plotting + | ContourPlotting + | PlotWidth + | PlotHeight + | XBeg + | XEnd + | YBeg + | YEnd + | XLogScale + | YLogScale + | DrawXaxis + | DrawYaxis + | Draw0axis + + | NoDrawXLabel + | NoDrawYLabel + + | XLabelPrecision + | YLabelPrecision + + | XLabelSpacing + | YLabelSpacing + + | PlotTitle + deriving (Eq, Show) + +version :: String +version = "1.1" + +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" + ] + +plotOption :: [OptDescr (Flag, String)] +plotOption = + [ Option "c" ["contour"] (NoArg (ContourPlotting,"")) "Do a contour plot instead of a regular plot" + , Option "x" ["xBegin"] (ReqArg ((,) XBeg) "XBEG") "Beginning of plot (x), float" + , Option "" ["xe", "xEnd"] (ReqArg ((,) XEnd) "XEND") "End of plot (x), float" + , Option "y" ["yBegin"] (ReqArg ((,) YBeg) "YBEG") "Beginning of plot (y), float" + , Option "" ["ye", "yEnd"] (ReqArg ((,) YEnd) "YEnd") "End of plot (y), float" + , Option "w" ["width"] (ReqArg ((,) PlotWidth) "Width") "Plotting width, int" + , Option "h" ["height"] (ReqArg ((,) PlotHeight) "height") "Plotting height, int" + , Option "" ["lx", "logwidth"] (NoArg (XLogScale,"")) + "Plot with a logrithmic scale in x" + , Option "" ["ly", "logheight"] (NoArg (YLogScale,"")) + "Plot with a logrithmic scale in y" + , Option "" ["ax", "xaxis"] (NoArg (DrawXaxis,"")) + "Draw the X axis on the graph" + , Option "" ["ay", "yaxis"] (NoArg (DrawYaxis,"")) + "Draw the Y axis on the graph" + , Option "" ["a0", "zeroaxis"] (NoArg (Draw0axis,"")) + "Draw the 0 axis on the graph" + , Option "" ["nlx", "nolabelx"] (NoArg (NoDrawXLabel,"")) + "Don't draw label on x Axis" + , Option "" ["nly", "nolabely"] (NoArg (NoDrawYLabel,"")) + "Don't draw label on Y Axis" + , Option "" ["lpx", "xlabelprecision"] + (ReqArg ((,) XLabelPrecision) "p") + "Display label on x axis with 'p' decimals" + , Option "" ["lpy", "ylabelprecision"] + (ReqArg ((,) YLabelPrecision) "p") + "Display label on y axis with 'p' decimals" + , Option "" ["spx", "labelspacingx"] + (ReqArg ((,) XLabelSpacing) "s") + "Put a label evry 's' chars on x axis" + , Option "" ["spy", "labelspacingy"] + (ReqArg ((,) YLabelSpacing) "s") + "Put a label evry 's' chars on y axis" + , Option "t" ["title"] + (ReqArg ((,) PlotTitle) "t") + "Add a title t under the graph" + ] + +preparePlotConf :: PlotConf -> (Flag, String) -> PlotConf +preparePlotConf conf (ContourPlotting, _) = + conf { mode = CountourPlot } +preparePlotConf conf (PlotWidth, val) = + conf { xDim = (xDim conf){ projectionSize = read val } } +preparePlotConf conf (PlotHeight, val) = + conf { yDim = (yDim conf){ projectionSize = read val }} +preparePlotConf conf (XBeg, val) = + conf { xDim = (xDim conf){ minVal = read val }} +preparePlotConf conf (XEnd, val) = + conf { xDim = (xDim conf){ maxVal = read val }} +preparePlotConf conf (YBeg, val) = + conf { yDim = (yDim conf){ minVal = read val }} +preparePlotConf conf (YEnd, val) = + conf { yDim = (yDim conf){ maxVal = read val }} +preparePlotConf conf (XLogScale, _) = + conf { xDim = (xDim conf){ scaling = Logarithmic } } +preparePlotConf conf (YLogScale, _) = + conf { yDim = (yDim conf){ scaling = Logarithmic } } +preparePlotConf conf (DrawXaxis, _) = + conf { xDim = (xDim conf){ drawAxis = True } } +preparePlotConf conf (DrawYaxis, _) = + conf { yDim = (yDim conf){ drawAxis = True } } +preparePlotConf conf (Draw0axis, _) = + conf { draw0Axis = True } +preparePlotConf conf (NoDrawXLabel, _) = + conf { xDim = (xDim conf){ labelEvery = Nothing } } +preparePlotConf conf (NoDrawYLabel, _) = + conf { yDim = (yDim conf){ labelEvery = Nothing } } +preparePlotConf conf (XLabelSpacing, val) = + conf { xDim = (xDim conf){ labelEvery = Just $ read val} } +preparePlotConf conf (YLabelSpacing, val) = + conf { yDim = (yDim conf){ labelEvery = Just $ read val} } +preparePlotConf conf (XLabelPrecision, val) = + conf { xDim = (xDim conf){ labelPrecision = read val} } +preparePlotConf conf (YLabelPrecision, val) = + conf { yDim = (yDim conf){ labelPrecision = read val} } +preparePlotConf conf (PlotTitle, val) = + conf { graphTitle = Just val } +preparePlotConf conf _ = conf + +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, rest, _) = getOpt Permute formatOption args + (input, outputFile) = getInputOutput opt rest + +-- | 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, rest, _) = getOpt Permute formatOption args + (input, outputFile) = getInputOutput opt rest + 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, rest, _) = getOpt Permute formatOption args + (input, outputFile) = getInputOutput opt rest + conf = defaultRenderConf{ useUnicode = Unicode `lookup` opt /= Nothing } + +plotCommand :: [String] -> IO Bool +plotCommand args = do + formulaText <- input + finalFile <- outputFile + + let formulaList = parseProgramm formulaText + either (parseErrorPrint finalFile) + (\formulal -> do + case plotFunction plotConf . unTagFormula $ head formulal of + Left err -> do + Io.hPutStr finalFile err + hClose finalFile + return False + + Right v -> do + Io.hPutStr finalFile $ charArrayToString v + return True) + formulaList + where (opt, rest, _) = getOpt Permute (commonOption ++ plotOption) args + plotConf = foldl' preparePlotConf defaultPlotConf + opt + (input, outputFile) = getInputOutput opt rest + +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) + , ("plot", "Print an ASCII-art plot of the given function" + , plotCommand, commonOption ++ plotOption) + ] + +reducedCommand :: [(String, [String] -> IO Bool)] +reducedCommand = map (\(n,_,a,_) -> (n,a)) commandList + +main :: IO () +main = do +#ifdef _DEBUG + putStrLn "Debug build" +#endif + 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 +