diff --git a/CharArray.hs b/CharArray.hs --- a/CharArray.hs +++ b/CharArray.hs @@ -12,3 +12,9 @@ => 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 + diff --git a/Eq.cabal b/Eq.cabal --- a/Eq.cabal +++ b/Eq.cabal @@ -1,5 +1,5 @@ Name: Eq -Version: 1.0.2 +Version: 1.1 Synopsis: Render math formula in ASCII, and perform some simplifications Build-Type: Simple Category: Language, Math @@ -60,6 +60,7 @@ , EqManips.Algorithm.Simplify , EqManips.Algorithm.Unification , EqManips.Algorithm.Utils + , EqManips.Algorithm.StackVM.Stack , EqManips.BaseLibrary , EqManips.Conf , EqManips.Domain @@ -73,6 +74,7 @@ , EqManips.Preprocessor , EqManips.Propreties , EqManips.Renderer.Ascii + , EqManips.Renderer.Ascii2DGrapher , EqManips.Renderer.CharRender , EqManips.Renderer.Cpp , EqManips.Renderer.EqCode diff --git a/EqManips/Algorithm/Cleanup.hs b/EqManips/Algorithm/Cleanup.hs --- a/EqManips/Algorithm/Cleanup.hs +++ b/EqManips/Algorithm/Cleanup.hs @@ -74,6 +74,8 @@ 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 @@ -95,6 +97,7 @@ 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 @@ -124,6 +127,10 @@ 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) diff --git a/EqManips/Algorithm/EmptyMonad.hs b/EqManips/Algorithm/EmptyMonad.hs --- a/EqManips/Algorithm/EmptyMonad.hs +++ b/EqManips/Algorithm/EmptyMonad.hs @@ -5,13 +5,6 @@ import Control.Applicative import Control.Monad.Identity -instance Applicative Identity where - pure = return - f <*> a = do - f' <- f - a' <- a - return $ f' a' - -- | a function to unwrap empty monad, just -- to be able to compose easily. fromEmptyMonad :: Identity a -> a diff --git a/EqManips/Algorithm/Eval/GenericEval.hs b/EqManips/Algorithm/Eval/GenericEval.hs --- a/EqManips/Algorithm/Eval/GenericEval.hs +++ b/EqManips/Algorithm/Eval/GenericEval.hs @@ -350,7 +350,6 @@ -- | General evaluation/reduction function eval :: EvalFun -> EvalFun eval evaluator (Meta _ m f) = metaEvaluation evaluator m f -eval _ (NumEntity Pi) = return $ CFloat pi eval evaluator (Matrix _ n m mlines) = do cells <- sequence [mapM evaluator line | line <- mlines] return $ matrix n m cells diff --git a/EqManips/Algorithm/Simplify.hs b/EqManips/Algorithm/Simplify.hs --- a/EqManips/Algorithm/Simplify.hs +++ b/EqManips/Algorithm/Simplify.hs @@ -53,7 +53,10 @@ -- | '-' operator simplification subSimplification :: EvalFun -> EvalOp -subSimplification eval (BinOp _ OpMul [a, c]) b +{-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 diff --git a/EqManips/Algorithm/StackVM/Stack.hs b/EqManips/Algorithm/StackVM/Stack.hs new file mode 100644 --- /dev/null +++ b/EqManips/Algorithm/StackVM/Stack.hs @@ -0,0 +1,200 @@ +{-# 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." + diff --git a/EqManips/Algorithm/Unification.hs b/EqManips/Algorithm/Unification.hs --- a/EqManips/Algorithm/Unification.hs +++ b/EqManips/Algorithm/Unification.hs @@ -15,11 +15,6 @@ infix 4 =~= -instance Applicative (State s) where - pure = return - a <*> b = - do { a' <- a; b' <- b; return $ a' b' } - type UnificationContext a = State [(String, FormulaPrim)] a -- | Just a little shortcut to be able to write more diff --git a/EqManips/EvaluationContext.hs b/EqManips/EvaluationContext.hs --- a/EqManips/EvaluationContext.hs +++ b/EqManips/EvaluationContext.hs @@ -17,6 +17,7 @@ , printTrace , traceContext #endif /* _DEBUG */ + , emptyContext ) where import Data.Map (Map) diff --git a/EqManips/InputParser/MathML.hs b/EqManips/InputParser/MathML.hs --- a/EqManips/InputParser/MathML.hs +++ b/EqManips/InputParser/MathML.hs @@ -57,17 +57,6 @@ simplifyContent :: Content a -> Either String ReducedXmlTree simplifyContent = simplify . elemOfContent -instance Applicative (Either a) where - pure = Right - (<*>) (Left a) _ = Left a - (<*>) (Right _) (Left b) = Left b - (<*>) (Right f) (Right v) = Right (f v) - -instance Monad (Either a) where - return = Right - (>>=) (Left a) _ = Left a - (>>=) (Right v) f = f v - eitherMap :: [Either a b] -> Either a [b] eitherMap [] = Right [] eitherMap lst = foldr mapper (Right []) lst diff --git a/EqManips/Polynome.hs b/EqManips/Polynome.hs --- a/EqManips/Polynome.hs +++ b/EqManips/Polynome.hs @@ -473,10 +473,12 @@ | otherwise {- v1 == v2 -} = Polynome v1 {-. map (\lst@((o,_):_) -> (o, foldr1 (+) $ map snd lst))-} - . map (\lst@((o,_):_) -> (o, sum $ 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 diff --git a/EqManips/Renderer/Ascii2DGrapher.hs b/EqManips/Renderer/Ascii2DGrapher.hs new file mode 100644 --- /dev/null +++ b/EqManips/Renderer/Ascii2DGrapher.hs @@ -0,0 +1,463 @@ +-- | 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 + diff --git a/EqManips/Renderer/Cpp.hs b/EqManips/Renderer/Cpp.hs --- a/EqManips/Renderer/Cpp.hs +++ b/EqManips/Renderer/Cpp.hs @@ -23,10 +23,6 @@ convertToCppS :: Formula TreeForm -> ShowS convertToCppS (Formula f) = fst $ runState (cNo f) defaultConf -instance Applicative (State s) where - pure = return - (<*>) = ap - defaultConf :: CppConf defaultConf = CppConf { failures = [] diff --git a/EqManips/Renderer/Mathml.hs b/EqManips/Renderer/Mathml.hs --- a/EqManips/Renderer/Mathml.hs +++ b/EqManips/Renderer/Mathml.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NewQualifiedOperators #-} module EqManips.Renderer.Mathml( mathmlRender ) where import EqManips.Types hiding ( matrix ) diff --git a/formulaMain.hs b/formulaMain.hs --- a/formulaMain.hs +++ b/formulaMain.hs @@ -6,6 +6,10 @@ import EqManips.Renderer.Mathml import EqManips.Renderer.RenderConf +import EqManips.Renderer.Ascii2DGrapher + +import CharArray + #ifdef _DEBUG import EqManips.Renderer.Sexpr #endif @@ -19,7 +23,7 @@ import System.Console.GetOpt -import Data.List( find, intersperse ) +import Data.List( find, intersperse, foldl' ) import Data.Maybe( fromMaybe ) import qualified Data.Map as Map @@ -45,10 +49,34 @@ | SupportedFunction | SupportedOperators | SupportedPreprocLanguages - deriving Eq + -- 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.0" +version = "1.1" commonOption :: [OptDescr (Flag, String)] commonOption = @@ -67,6 +95,84 @@ "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 @@ -98,8 +204,8 @@ Io.putStr "==========================================\n\n" hClose output return True - where (opt, left, _) = getOpt Permute formatOption args - (input, outputFile) = getInputOutput opt left + where (opt, rest, _) = getOpt Permute formatOption args + (input, outputFile) = getInputOutput opt rest -- | Command which just format an equation -- without affecting it's form. @@ -114,8 +220,8 @@ hClose output return True) formula - where (opt, left, _) = getOpt Permute formatOption args - (input, outputFile) = getInputOutput opt left + where (opt, rest, _) = getOpt Permute formatOption args + (input, outputFile) = getInputOutput opt rest conf = defaultRenderConf{ useUnicode = Unicode `lookup` opt /= Nothing } printErrors :: [(Formula TreeForm, String)] -> IO () @@ -224,10 +330,33 @@ return . null $ errorList rez) formulaList - where (opt, left, _) = getOpt Permute formatOption args - (input, outputFile) = getInputOutput opt left + 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" @@ -308,7 +437,8 @@ , 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)]