1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
{-# LANGUAGE OverloadedStrings #-}
module Graphics.Layout.Arithmetic(Opcode(..), parseCalc, verifyCalc,
evalCalc, mapCalc) where
import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
import Data.Scientific (toRealFloat)
import GHC.Real (infinity)
import Data.Text (unpack, Text)
import qualified Data.Text as Txt
data Opcode n = Seq | Add | Subtract | Multiply | Divide | Func Text | Num n deriving Show
parseCalc :: [Token] -> [Opcode (Float, String)] -> [Opcode (Float, String)]
parseCalc (Number _ n:toks) stack = Num (val2float n, ""):parseCalc toks stack
parseCalc (Percentage _ n:toks) stack = Num (val2float n, "%"):parseCalc toks stack
parseCalc (Dimension _ n unit:toks) stack =
Num (val2float n, unpack unit):parseCalc toks stack
parseCalc (Ident "e":toks) stack = Num (exp 1, ""):parseCalc toks stack
parseCalc (Ident "pi":toks) stack = Num (pi, ""):parseCalc toks stack
parseCalc (Ident "infinity":toks) stack = Num (f infinity, ""):parseCalc toks stack
parseCalc (Ident "-infinity":toks) stack =
Num (negate $ f infinity, ""):parseCalc toks stack
parseCalc (Ident "NaN":toks) stack = Num (0/0, ""):parseCalc toks stack
parseCalc (Function x:toks) stack = parseCalc toks (Func x:stack)
parseCalc (LeftParen:toks) stack = parseCalc toks (Func "calc":stack)
parseCalc toks'@(Delim c:toks) (stack:stacks)
| prec stack >= prec (op c) = stack:parseCalc toks' stacks
| otherwise = parseCalc toks (op c:stack:stacks)
where
prec :: Opcode n -> Int
prec Seq = 1
prec Add = 2
prec Subtract = 2
prec Multiply = 3
prec Divide = 3
prec (Func _) = 0
prec (Num _) = error "Unexpected number on operand stack!"
parseCalc (Delim c:toks) [] = parseCalc toks [op c]
parseCalc (Comma:toks) stack = parseCalc (Delim ',':toks) stack
parseCalc (RightParen:toks) (Func "calc":stack) = parseCalc toks stack
parseCalc (RightParen:toks) (op'@(Func _):stack) = op':parseCalc toks stack
parseCalc toks@(RightParen:_) (op':stack) = op':parseCalc toks stack
parseCalc (RightParen:toks) [] = parseCalc toks []
parseCalc [] [] = []
parseCalc [] stack = parseCalc [RightParen] stack
parseCalc _ _ = [Func "invalid"]
op :: Char -> Opcode n
op '+' = Add
op '-' = Subtract
op '*' = Multiply
op '/' = Divide
op ',' = Seq -- For function-calls.
op _ = Func "invalid"
-- Do operands counts line up? Are we dividing by 0?
-- Also I see concerns about whether units line up. Not bothering verifying that.
verifyCalc :: [Opcode (Float, String)] -> [Bool] -> Bool
verifyCalc (Seq:expr) stack = verifyCalc expr stack
verifyCalc (Add:expr) (_:_:stack) = verifyCalc expr (True:stack)
verifyCalc (Subtract:expr) (_:_:stack) = verifyCalc expr (True:stack)
verifyCalc (Multiply:expr) (_:_:stack) = verifyCalc expr (True:stack)
verifyCalc (Divide:_) (False:_) = False
verifyCalc (Divide:expr) (_:_:stack) = verifyCalc expr (True:stack)
verifyCalc (Num (n, _):expr) stack = verifyCalc expr ((n == 0):stack)
verifyCalc (Func x:expr) (_:stack)
| x `elem` Txt.words "abs acos asin atan cos exp log sign sin sqrt tan" =
verifyCalc expr (True:stack)
verifyCalc (Func x:expr) (_:_:stack)
| x `elem` Txt.words "atan2 max min mod pow rem" = verifyCalc expr (True:stack)
verifyCalc (Func "clamp":expr) (_:_:_:stack) = verifyCalc expr (True:stack)
verifyCalc [] [_] = True
verifyCalc _ _ = False
evalCalc :: [Opcode Float] -> [Float] -> Float
evalCalc (Seq:expr) stack = evalCalc expr stack -- The function args off
evalCalc (Add:expr) (y:x:stack) = evalCalc expr ((x + y):stack)
evalCalc (Subtract:expr) (y:x:stack) = evalCalc expr ((x - y):stack)
evalCalc (Multiply:expr) (y:x:stack) = evalCalc expr ((x*y):stack)
evalCalc (Divide:expr) (y:x:stack) = evalCalc expr ((x/y):stack)
evalCalc (Num n:expr) stack = evalCalc expr (n:stack)
evalCalc (Func "abs":expr) (x:stack) = evalCalc expr (abs x:stack)
evalCalc (Func "acos":expr) (x:stack) = evalCalc expr (acos x:stack)
evalCalc (Func "asin":expr) (x:stack) = evalCalc expr (asin x:stack)
evalCalc (Func "atan":expr) (x:stack) = evalCalc expr (atan x:stack)
evalCalc (Func "atan2":expr) (y:x:stack) = evalCalc expr (atan2 x y:stack)
evalCalc (Func "clamp":expr) (high:x:low:stack) =
evalCalc expr (min high (max low x):stack)
evalCalc (Func "cos":expr) (x:stack) = evalCalc expr (cos x:stack)
evalCalc (Func "exp":expr) (x:stack) = evalCalc expr (exp x:stack)
evalCalc (Func "log":expr) (x:stack) = evalCalc expr (log x:stack)
evalCalc (Func "max":expr) (y:x:stack) = evalCalc expr (max x y:stack)
evalCalc (Func "min":expr) (y:x:stack) = evalCalc expr (min x y:stack)
evalCalc (Func "mod":expr) (y:x:stack) =
evalCalc expr (toEnum (round x `mod` round y):stack)
evalCalc (Func "pow":expr) (y:x:stack) = evalCalc expr (x ** y:stack)
evalCalc (Func "rem":expr) (y:x:stack) =
evalCalc expr (toEnum (round x `rem` round y):stack)
evalCalc (Func "sign":expr) (x:stack) = evalCalc expr (signum x:stack)
evalCalc (Func "sin":expr) (x:stack) = evalCalc expr (sin x:stack)
evalCalc (Func "sqrt":expr) (x:stack) = evalCalc expr (sqrt x:stack)
evalCalc (Func "tan":expr) (x:stack) = evalCalc expr (tan x:stack)
evalCalc [] [ret] = ret
evalCalc _ _ = error "Verification should have caught this error!"
mapCalc :: (a -> b) -> [Opcode a] -> [Opcode b]
mapCalc cb (Num x:toks) = Num (cb x):mapCalc cb toks
-- GHC demanded more verbosity...
mapCalc cb (Seq:toks) = mapCalc cb toks -- we can drop these while we're at it...
mapCalc cb (Add:toks) = Add:mapCalc cb toks
mapCalc cb (Subtract:toks) = Subtract:mapCalc cb toks
mapCalc cb (Multiply:toks) = Multiply:mapCalc cb toks
mapCalc cb (Divide:toks) = Divide:mapCalc cb toks
mapCalc cb (Func f':toks) = Func f':mapCalc cb toks
mapCalc _ [] = []
val2float :: NumericValue -> Float
val2float (NVInteger n) = fromIntegral n
val2float (NVNumber n) = toRealFloat n
f :: Rational -> Float
f = fromRational