-
Notifications
You must be signed in to change notification settings - Fork 0
/
interexpr.l
214 lines (204 loc) · 7.21 KB
/
interexpr.l
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
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
(setq a "a" A "A" b "b" B "B" c "c" C "C" d "d" D "D" e "e" E "E")
(setq f "f" F "F" g "g" G "G" h "h" H "H" i "i" I "I" j "j" J "J")
(setq k "k" K "K" l "l" L "L" m "m" M "M" n "n" N "N" o "o" O "O")
(setq p "p" P "P" q "q" Q "Q" r "r" R "R" s "s" S "S" t "t") # T protected
(setq u "u" U "U" v "v" V "V" w "w" W "W" x "x" X "X" y "y" Y "Y" z "z" Z "Z")
(setq pi "\\pi" Pi "\\Pi")
# Avoid 'redefined' message
(setq ? NIL diff NIL)
(de ma-def arg-list
(let (
nom (car arg-list)
args (cadr arg-list)
body (caddr arg-list)
)
(println nom)
(println args)
(println body)
(println " ")
(push 'liste-cmds nom)
(def nom args body)
)
(def (car arg-list) (eval (cadr arg-list)) (eval (caddr arg-list)))
)
(setq cmds_list '(Somme Diff Opposé Produit Quotient Inverse Carre Racine Cube Puissance Terme_indice Image_par cos sin ln exp))
(put 'precedence 'Oppose 10)
(put 'precedence 'Opposé 10)
(put 'precedence 'Somme 12)
(put 'precedence 'Diff 13)
(put 'precedence 'Produit 20)
(put 'precedence 'Exp 25)
(put 'precedence 'Ln 25)
(put 'precedence 'Carre 30)
(put 'precedence 'Carré 30)
(put 'precedence 'Puissance 30)
(put 'precedence 'Cube 30)
(put 'precedence 'Racine NIL)
(put 'precedence 'Inverse NIL)
(put 'precedence 'Quotient NIL)
(put 'precedence 'Image_par NIL)
(put 'precedence 'Cos NIL)
(put 'precedence 'Sin NIL)
(put 'precedence 'Terme_indice NIL)
(put 'precedence 'oppose 10)
(put 'precedence 'opposé 10)
(put 'precedence 'somme 12)
(put 'precedence 'diff 13)
(put 'precedence 'produit 20)
(put 'precedence 'exp 25)
(put 'precedence 'ln 25)
(put 'precedence 'carre 30)
(put 'precedence 'carré 30)
(put 'precedence 'puissance 30)
(put 'precedence 'cube 30)
(put 'precedence 'racine NIL)
(put 'precedence 'inverse NIL)
(put 'precedence 'quotient NIL)
(put 'precedence 'image_par NIL)
(put 'precedence 'cos NIL)
(put 'precedence 'sin NIL)
(put 'precedence 'terme_indice NIL)
(de add_p prg
(glue "\\text{ ? }" (mapcar 'add_p_rec prg)))
(de add_p_rec (prg parent_op parent_precedence rank)
(if (atom prg)
(eval prg)
(let (op (car prg)
terms (cdr prg)
current_precedence (get 'precedence op))
(let (children_with_p
(mapcar '((term rank) (add_p_rec term op current_precedence rank))
terms
(range 1 (length terms))))
(cond
# Suppress parens of sums within sums
((= 'somme parent_op op)
(apply op children_with_p))
# Suppress parens around first arg of a diff
((and (= 'diff parent_op)
(= rank 1))
(apply op children_with_p))
((and current_precedence
parent_precedence
(>= parent_precedence current_precedence))
(par (apply op children_with_p)))
(T
(apply op children_with_p))
)
)
)
)
)
(de opglue @
(let (args (rest)
op (car args)
termes (cadr args)
nbre_termes (length termes))
(cond
((= nbre_termes 0) (pack "?" op "?"))
((= nbre_termes 1) (pack (car termes) op "?"))
(T (glue op termes))
)
)
)
(de ? (x) (if x @ "?"))
(de startsw (container fragment)
(= fragment (pack (head (length fragment) (chop container))))
)
(de endsw (container fragment)
(= fragment (pack (tail (length fragment) (chop container))))
)
(de par (x) (pack "\\left( " (? x) " \\right)"))
(de somme @ (opglue " + " (rest)))
(de diff (x y) (pack (? x) " - " (? y)))
(de oppose (x) (pack "-" (? x)))
(de produit @
(let (first (car (rest))
second (cadr (rest))
operator (if (num? second)
" \\times "
" "))
(opglue operator (rest))
)
)
(de produit. @ (opglue " \\cdot " (rest)))
(de quotient (n d) (pack "\\frac{" (? n) "}{" (? d) "}"))
(de inverse (x) (pack "\\frac{" 1 "}{" (? x) "}"))
(de carre (x) (pack "{" (? x) "}\^2"))
(de racine (x) (pack "\\sqrt{" (? x) "}"))
(de cube (x) (pack "{" (? x) "}\^3"))
(de puissance (x y) (pack "{" (? x) "}\^{" (? y) "}"))
(de terme_indice (x y) (pack "{" (? y) "}_{" (? x) "}"))
(de image_par (f x) (pack (? f) " \\left( " (? x) " \\right)")) # spaces for distinction with produit
(de cos (x) (pack "\\cos" (par (? x))))
(de sin (x) (pack "\\sin" (par (? x))))
(de exp (x) (pack "\\exp" (? x)))
(de ln (x) (pack "\\ln" (? x)))
(setq Somme somme)
(setq Diff diff)
(setq opposé oppose)
(setq Oppose oppose)
(setq Opposé oppose)
(setq Produit produit)
(setq Quotient quotient)
(setq Inverse inverse)
(setq carré carre)
(setq Carre carre)
(setq Carré carre)
(setq Racine racine)
(setq Cube cube)
(setq Puissance puissance)
(setq Terme_indice terme_indice)
(setq Image_par image_par)
(setq Cos cos)
(setq Sin sin)
(setq Exp exp)
(setq Ln ln)
(setq tests '(
(a "a")
(x "x")
((somme a b) "a + b")
((diff a b) "a - b")
((produit 2 (somme x 1)) "2 \\left( x + 1 \\right)")
((somme a b c) "a + b + c")
((somme (diff a b) c) "a - b + c")
((somme (somme a b) c) "a + b + c")
((somme a (somme b c)) "a + b + c")
((diff (somme a b) c) "a + b - c")
((diff a (somme b c)) "a - \\left( b + c \\right)")
((diff (diff a b) c) "a - b - c")
((diff a (diff b c)) "a - \\left( b - c \\right)")
((somme (produit 10 a) (diff (diff b a) b)) "10 a + b - a - b")
((somme (produit 10 a) (diff b a)) "10 a + b - a")
((diff (somme (produit 10 a) b)a) "10 a + b - a")
((quotient (produit (produit 2 x) 2) x) "\\frac{\\left( 2 x \\right) \\times 2}{x}")
#((quotient (produit (produit 5 x) (produit 15 x)) 5) "\\frac{\\left( 5 x \\right) \\times \\left( 15 x \\right)}{5}")
#((quotient (produit (produit 10 (carre x)) (produit 5 x)) (produit 5 (produit 5 x))) "\\frac{\\left( 10 {x}\^2 \\right) \\times \\left( 5 x \\right)}{5 \\times \\left( 5 x \\right)}")
#((quotient x (produit (produit 5 x) (carre x))) "\\frac{x}{\\left( 5 x \\right) \\times {x}\^2}")
((somme (produit 2 x) 1) "2 x + 1")
((produit (somme x 1) 3) "\\left( x + 1 \\right) \\times 3")
((diff (produit (somme x 3) 9) (produit 2 x)) "\\left( x + 3 \\right) \\times 9 - 2 x")
((produit 3 (somme x y)) "3 \\left( x + y \\right)")
((produit 1 2) "1 \\times 2")
((somme (produit x 6) 8) "x \\times 6 + 8")
((produit (somme (produit x 3) 4) 2) "\\left( x \\times 3 + 4 \\right) \\times 2")
((produit (diff (produit 2 x) 4) 8) "\\left( 2 x - 4 \\right) \\times 8")
((oppose (quotient (diff (produit a (racine b)) (image_par f (inverse c))) (carre (somme x y z)))) "-\\frac{a \\sqrt{b} - f \\left( \\frac{1}{c} \\right)}{{\\left( x + y + z \\right)}\^2}")
# Majuscules
((Somme a b) "a + b")
((Somme a b c) "a + b + c")
((Diff a b) "a - b")
((Produit a b) "a b")
((Quotient a b) "\\frac{a}{b}")
((Racine a) "\\sqrt{a}")
) )
(de test_a_pair (pair)
(let (expr (car pair)
attempt (add_p_rec expr)
expected (cadr pair))
(ifn (= attempt expected)
(println expr (pack attempt "!=" expected))
)
)
)
(mapcar test_a_pair tests)