Note: This website is archived. For up-to-date information about D projects and development, please visit wiki.dlang.org.

root/trunk/backmath/do.lisp

Revision 176, 10.2 kB (checked in by BCS, 17 years ago)

added a bunch more rules
did a compile time performance tweak in backmath.d
improved automation in do.lisp

Line 
1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;;;;
4 ;;;;; This is a program for atomating parts of
5 ;;;;; the rule generation process for BackMath
6 ;;;;;
7 ;;;;; For instruction on how to use it, look at
8 ;;;;; the end of the file.
9 ;;;;;
10 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
12
13 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
14 ;; convert in place a op> exp to a normal exp
15 ;;
16 (defun Convert_to_exp (exp)
17     (if (atom exp)
18         exp
19         (cond
20             ((equal (car exp) '+>)   `(- ,(Convert_to_exp (caddr exp)) ,(Convert_to_exp (cadr exp))))
21             ((equal (car exp) '->)   `(+ ,(Convert_to_exp (caddr exp)) ,(Convert_to_exp (cadr exp))))
22             ((equal (car exp) '*>)   `(/ ,(Convert_to_exp (caddr exp)) ,(Convert_to_exp (cadr exp))))
23             ((equal (car exp) '/>)   `(* ,(Convert_to_exp (caddr exp)) ,(Convert_to_exp (cadr exp))))
24             ((equal (car exp) '-r>)  `(- ,(Convert_to_exp (cadr exp)) ,(Convert_to_exp (caddr exp))))
25             ((equal (car exp) '/r>)  `(/ ,(Convert_to_exp (cadr exp)) ,(Convert_to_exp (caddr exp))))
26             ((equal (car exp) '+)    `(+ ,(Convert_to_exp (cadr exp)) ,(Convert_to_exp (caddr exp))))
27             ((equal (car exp) '-)    `(- ,(Convert_to_exp (cadr exp)) ,(Convert_to_exp (caddr exp))))
28             ((equal (car exp) '*)    `(* ,(Convert_to_exp (cadr exp)) ,(Convert_to_exp (caddr exp))))
29             ((equal (car exp) '/)    `(/ ,(Convert_to_exp (cadr exp)) ,(Convert_to_exp (caddr exp))))
30         )
31     )
32 )
33
34
35 (defun has (a e)
36     (if (atom e)
37         (equal a e)
38         (or
39             (has a (cadr e))
40             (has a (caddr e))
41         )
42     )
43 )
44
45 (defun SetPush (un exp)
46     (if (atom exp)
47         exp
48         (let
49             (
50                 (op  (car   exp))
51                 (LHS (cadr  exp))
52                 (RHS (caddr exp))
53             )
54             (cond
55                 (
56                     (and
57                         (has un LHS)
58                         (not (has un RHS))
59                     )
60                     (cond
61                         ((equal op '+)    `(-> ,RHS ,(SetPush un LHS)))
62                         ((equal op '-)    `(+> ,RHS ,(SetPush un LHS)))
63                         ((equal op '*)    `(/> ,RHS ,(SetPush un LHS)))
64                         ((equal op '/)    `(*> ,RHS ,(SetPush un LHS)))
65                     )
66                 )
67                 (
68                     (and
69                         (not (has un LHS))
70                         (has un RHS)
71                     )
72                     (cond
73                         ((equal op '+)    `(->  ,LHS ,(SetPush un RHS)))
74                         ((equal op '-)    `(-r> ,LHS ,(SetPush un RHS)))
75                         ((equal op '*)    `(/>  ,LHS ,(SetPush un RHS)))
76                         ((equal op '/)    `(/r> ,LHS ,(SetPush un RHS)))
77                     )
78                 )
79                 (
80                     (and
81                         (not (has un LHS))
82                         (not (has un RHS))
83                     )
84                     exp
85                 )
86                 (t  'ERROR)
87             )
88         )
89     )
90 )
91
92
93 (defun prefer_neg_inv (exp)
94     (cond
95         ((atom exp) exp)
96         ((endp exp) exp)
97         (
98             (or (equal (car exp) '+) (equal (car exp) '*))
99             `(
100                 ,(car exp)
101                 ,(prefer_neg_inv (cadr exp))
102                 ,(prefer_neg_inv (caddr exp))
103             )
104         )
105         (
106             (equal (car exp) '-)
107             `(
108                 +
109                 ,(prefer_neg_inv (cadr exp))
110                 (- ,(prefer_neg_inv (caddr exp)))
111             )
112         )
113         (
114             (equal (car exp) '/)
115             `(
116                 *
117                 ,(prefer_neg_inv (cadr exp))
118                 (/ ,(prefer_neg_inv (caddr exp)))
119             )
120         )
121         (t exp)
122     )
123 )
124
125 #|(defun has_struct (temp act)
126     (cond
127         ((endp tmp) t)
128         ((atom tmp) (not (endp act)))
129         (
130             t
131             (and
132                 (not (endp act))
133                 (has_struct (car temp) (car act))
134                 (has_struct (cdr temp) (cdr act))
135             )
136         )
137     )
138 )|#
139
140
141 (defun my_normalize (exp)
142     (prefer_neg_inv exp)
143 )
144
145 ;(my_normalize (Convert_to_exp in))
146
147 (defun partof (exp)    (and (not (atom exp)) (not (endp exp))))
148 (defun something (exp) (or  (atom exp) (not (endp exp))))
149
150
151 (defun post_ (exp)
152 ;   (print exp)
153     (cond
154         ((atom exp) exp)
155         ((endp exp) exp)
156         (
157             (equal '+ (car exp))
158             (cond
159                 (
160                     (not (endp (cdddr exp)))
161                     `(+
162                         ,(cadr exp)
163                         ,(cons '+ (cddr exp))
164                     )
165                 )
166
167                 (
168                     (and    ; (+ (- A) B)
169                         (not (atom exp))
170                         (not (endp exp))
171                         (equal '+ (car exp))
172
173                         (not (atom (cadr exp)))
174                         (not (endp (cadr exp)))
175                         (equal '- (caadr exp))
176
177                         (not (endp (cdadr exp)))
178                         (endp (cddadr exp))
179
180                         (not (endp (cddr exp)))
181
182                         (not (and
183                             (not (atom (caddr exp)))
184                             (not (endp (caddr exp)))
185                             (equal '- (caaddr exp))
186                         ))
187
188                     )
189                     `(-
190                         ,(caddr exp)
191                         ,(cadadr exp)
192                     )
193                 )
194
195                 (
196                     (and    ; (+ (- A) B)
197                         (not (atom exp))
198                         (not (endp exp))
199                         (equal '+ (car exp))
200
201                         (not (atom (cadr exp)))
202                         (not (endp (cadr exp)))
203                         (equal '- (caadr exp))
204
205                         (not (endp (cdadr exp)))
206                         (endp (cddadr exp))
207
208                         (not (endp (cddr exp)))
209
210                         (not (atom (caddr exp)))
211                         (not (endp (caddr exp)))
212                         (equal '- (caaddr exp))
213
214                     )
215                     `(-
216                         (+
217                             ,(cadadr exp)
218                             ,(car (cdaddr exp))
219                         )
220                     )
221                 )
222
223                 (
224                     (and    ; (+ a (- 0 b))
225                         (partof    (        cdr exp) )
226                         (something (       cadr exp) )
227                             ; a               (cadr exp)
228                         (partof    (       cddr exp) )
229                         (partof    (      caddr exp) )
230                         (something (     caaddr exp) )
231                             ; -             (caaddr exp)
232                         (equal '-  (     caaddr exp) )
233                         (partof    (     cdaddr exp) )
234                         (something  (car(cdaddr exp)))
235                             ; 0         (car(cdaddr exp))
236                         (equal 0    (car(cdaddr exp)))
237                         (something  (cdr(cdaddr exp)))
238                         (something (cadr(cdaddr exp)))
239                             ; b        (cadr(cdaddr exp))
240                     )
241                     `(- ; (- a b)
242                         ,(cadr exp)
243                         ,(cadr(cdaddr exp))
244                     )
245                 )
246
247                 (
248                     t
249                     `(+
250                         ,(post_ (cadr exp))
251                         ,(post_ (caddr exp))
252                     )
253                 )
254             )
255         )
256         (
257             (equal '- (car exp))
258             (cond
259
260                 (
261                     (not (endp (cdddr exp)))
262                     (append
263                         `(-
264                             ,(cadr exp)
265                             (+ ,(caddr exp) ,(cadddr exp))
266                         )
267                         (cddddr exp)
268                     )
269                 )
270
271                 (   ; (- (- a) b)
272                     (and
273                         (not (atom (cadr exp)))
274                         (not (endp (cadr exp)))
275                         (equal '- (caadr exp))
276                         (endp (cddadr exp))
277                     )
278                     ; (- (+ a b))
279                     `(- (+ ,(cadadr exp) ,(caddr exp)))
280                 )
281 #|
282                 (   ; (- (- a b))
283                     (and
284                         (not (atom (cadr exp)))
285                         (not (endp (cadr exp)))
286                         (equal '- (caadr exp))
287                         (not (endp (cddadr exp)))
288                         (endp (cdr (cddadr exp)))
289                         (endp (cddr exp))
290                     )
291                     ; (- b a))
292                     `(- ,(caddr exp) ,(cadadr exp))
293                 )
294
295                 (   ; (- (- a b) c)
296                     (and
297                         (not (atom (cadr exp)))
298                         (not (endp (cadr exp)))
299                         (equal '- (caadr exp))
300                         (not (endp (cddadr exp)))
301                         (endp (cdr (cddadr exp)))
302                         (not (endp (cddr exp)))
303                         (endp (cdddr exp))
304                     )
305                     ; (- a (+ b c))
306                     `(- ,(cadadr exp) (+ ,(caddr exp) ,(caddr exp)))
307                 )
308 |#
309                 (
310                     (endp (cddr exp))
311                     `(- 0 ,(cadr exp))
312                 )
313
314                 (
315                     t
316                     `(-
317                         ,(post_ (cadr exp))
318                         ,(post_ (caddr exp))
319                     )
320                 )
321             )
322         )
323         (
324             (equal '* (car exp))
325             (cond
326                 (; (* x )
327                     (and
328                         (something (cdr exp))
329                         (endp (cddr exp))
330                     )
331                     (cadr exp)
332                 )
333
334                 (
335                     (not (endp (cdddr exp)))
336                     `(*
337                         ,(cadr exp)
338                         ,(cons '* (cddr exp))
339                     )
340                 )
341
342                 (
343                     (and    ; (* (/ A) B)
344                         (not (atom exp))
345                         (not (endp exp))
346                         (equal '* (car exp))
347
348                         (not (atom (cadr exp)))
349                         (not (endp (cadr exp)))
350                         (equal '/ (caadr exp))
351
352                         (not (endp (cdadr exp)))
353                         (endp (cddadr exp))
354
355                         (not (endp (cddr exp)))
356
357                         (not (and
358                             (not (atom (caddr exp)))
359                             (not (endp (caddr exp)))
360                             (equal '/ (caaddr exp))
361                         ))
362
363                     )
364                     `(/
365                         ,(caddr exp)
366                         ,(cadadr exp)
367                     )
368                 )
369
370                 (
371                     (and    ; (* (/ A) B)
372                         (not (atom exp))
373                         (not (endp exp))
374                         (equal '* (car exp))
375
376                         (not (atom (cadr exp)))
377                         (not (endp (cadr exp)))
378                         (equal '/ (caadr exp))
379
380                         (not (endp (cdadr exp)))
381                         (endp (cddadr exp))
382
383                         (not (endp (cddr exp)))
384
385                         (not (atom (caddr exp)))
386                         (not (endp (caddr exp)))
387                         (equal '/ (caaddr exp))
388
389                     )
390                     `(/
391                         (*
392                             ,(cadadr exp)
393                             ,(car (cdaddr exp))
394                         )
395                     )
396                 )
397                 (
398                     (and    ; (* a (/ 1 b))
399                         (partof    (        cdr exp) )
400                         (something (       cadr exp) )
401                             ; a               (cadr exp)
402                         (partof    (       cddr exp) )
403                         (partof    (      caddr exp) )
404                         (something (     caaddr exp) )
405                             ; /             (caaddr exp)
406                         (equal '/  (     caaddr exp) )
407                         (partof    (     cdaddr exp) )
408                         (something  (car(cdaddr exp)))
409                             ; 1         (car(cdaddr exp))
410                         (equal 1    (car(cdaddr exp)))
411                         (something  (cdr(cdaddr exp)))
412                         (something (cadr(cdaddr exp)))
413                             ; b        (cadr(cdaddr exp))
414                     )
415                     `(/ ; (/ a b)
416                         ,(cadr exp)
417                         ,(cadr(cdaddr exp))
418                     )
419                 )
420
421                 (
422                     t
423                     `(*
424                         ,(post_ (cadr exp))
425                         ,(post_ (caddr exp))
426                     )
427                 )
428             )
429         )
430         (
431             (equal '/ (car exp))
432             (cond
433
434                 (
435                     (not (endp (cdddr exp)))
436                     (append
437                         `(/
438                             ,(cadr exp)
439                             (* ,(caddr exp) ,(cadddr exp))
440                         )
441                         (cddddr exp)
442                     )
443                 )
444
445                 (   ; (/ (/ a) b)
446                     (and
447                         (not (atom (cadr exp)))
448                         (not (endp (cadr exp)))
449                         (equal '/ (caadr exp))
450                         (endp (cddadr exp))
451                     )
452                     ; (/ (* a b))
453                     `(/ (* ,(cadadr exp) ,(caddr exp)))
454                 )
455
456                 (
457                     (endp (cddr exp))
458                     `(/ 1 ,(cadr exp))
459                 )
460
461                 (
462                     t
463                     `(/
464                         ,(post_ (cadr exp))
465                         ,(post_ (caddr exp))
466                     )
467                 )
468             )
469         )
470         (t exp)
471     )
472 )
473
474 (defun post (exp)
475     (let
476         ((
477             ret
478             (post_ exp)
479         ))
480         (if (equal exp ret)
481             ret
482             (post ret )
483         )
484     )
485 )
486 #|
487 ;(defconstant tc '(* 1 2 (/ 3) (/ 4) (/ 5)))
488 (defconstant tc '(+ 1 2 (- 3) (- 4) (- 5)))
489 (post tc)
490 |#
491
492
493
494 (defconstant in '
495 ;(- (*> k (-> h x)) (*> f (-> e x)))
496 ;(- (/> K (-> H x)) (*> e x))
497 ;(- (*> h x) (*> f (-> e x)))
498 ;(- (*> h x) (/> e x))
499
500 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
501 ;;;; #1) Copy and pastes the required form here  ;;;;;;;;;;
502 ;;;; #2) Run the program                         ;;;;;;;;;;
503 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
504
505 (+ (*> h x) (*> f (-> e x)))
506
507 )
508
509
510 "#3) copy this expression for step 4"
511 (Convert_to_exp in)
512
513
514 (defconstant mid '
515
516 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
517 ;;;; #4) pastes expression from step 3 here   ;;;;;;;;;
518 ;;;; #5) rearrange so that is is of the form: ;;;;;;;;;
519 ;;;;       (*/ A (+- X B))                    ;;;;;;;;;
520 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
521
522 (* (+ (/ H) (/ F)) (+ (* x ) (/ (/ E F)(+ (/ H) (/ F)))))
523
524 )
525
526 #|
527 (- (* (+ X H) K) (* X E))
528 (- (+ (* X K) (* H K)) (* X E))
529 (+ (- (* X K) (* X E)) (* H K))
530 (+ (* X (- K E)) (* (* H K) (- K E) (/ - K E)))
531
532 (* (- K E) (+ X (* (* H K) (/ (- K E)))))
533 (* (- K E) (+ X (/ (* H K) (- K E))))
534 (* (+ X (/ (* H K) (- K E))) (- K E))
535 |#
536
537 (defconstant out (setpush 'x (post mid)))
538
539 ;in
540 ;mid
541 ;(post mid)
542 ;out
543
544 "#6) copy this expression into meta.lisp in the correct place"
545 `(,in ,out)
Note: See TracBrowser for help on using the browser.