Changeset 4423 for branches

Timestamp:

2016-06-08T11:04:20-07:00 (9 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

• branches/f4grobner/infix-printer.lisp (modified) (5 diffs)

branches/f4grobner/infix-printer.lisp

@@ -28 +28 @@
 (in-package "INFIX-PRINTER")
 
-(proclaim '(optimize (speed 0) (space 0) (safety 3) (debug 3)))
+;;(proclaim '(optimize (speed 0) (space 0) (safety 3) (debug 3)))
+
+(defun find-alt-op (op)
+  "Find ALT-OP, used for arguments above 1. Example: 
+We should have
+      (+ X (- Y) Z) --> X - Y + Z
+so when an argument of an expression with operator '+ has an operator '-, we
+should use '- as a separator, before we render Y. Thus ALT-OP for '+ is '-"
+  (ecase op 
+    (+ '-)
+    (- '-)
+    (* '/)
+    (/ '/)))
+
+(defun inverse-op (op)
+  (ecase op
+    (- '+)
+    (/ '*)))
 
 (defun infix-print-separated-list (lst sep stream op print-level
                                    &optional 
                                      (alt-op nil) 
-                                     (alt-sep alt-op)
                                    &aux
                                      (beg t)
@@ -44 +60 @@
 indicates whether this is the start of a sequence of arguments with
 the main operator OP.  The argument ALT-OP, if not NIL, replaces
-operator OP for list elements beyond the first one. Similarly, ALT-SEP
-replaces SEP for list elements beyond the first one."
+operator OP for list elements beyond the first one."
 
   (cond
@@ -57 +72 @@
    (t
     (dolist (arg lst)
-
-      ;;(format t "Processing arg: ~S~%" arg)
       (setf true-sep sep)
-
       (incf count)
           
+      ;; Treat negative number X as '(- (- X))
+      (when (and (realp arg) (minusp arg))
+        (setf arg (list '- (- arg))))
+
       ;; The following code handles unary minus
       ;; Thus:
       ;; (+ x (- y z)) --> X + Y - Z
       ;; (+ x (- y)) --> X - Y
+      ;; (- x (- y)) --> X + Y
       (when (and alt-op
                  (> count 1)
@@ -72 +89 @@
                  (endp (cddr arg))
                  (eq alt-op (car arg)))
-        (psetf arg     (cadr arg) 
-               alt-sep nil)
-        ;;(format t "Arg changed: ~S, true-sep: ~S~%" arg true-sep)
-        )
-
-
+        (psetf arg (cadr arg)
+               true-sep (if (eq op alt-op) (inverse-op op) alt-op)))
+        
+      ;; Unless at the beginning, print the separator
       (cond
         (beg 
@@ -137 +152 @@
        ;; Arithmetic operators
        ((+ - * /)
-        (infix-print-separated-list
-         (cdr expr)                     
-         (car expr)                     
-         stream
-         (car expr)                     
-         (1+ print-level)               
-         (cond ((eq (car expr) '+) '-)
-               ((eq (car expr) '-) '-)
-               ((eq (car expr) '*) '/)
-               ((eq (car expr) '/) '/)
-               (t nil))))
+        
+        (let ((op (car expr))
+              (args (cdr expr)))
+          (infix-print-separated-list 
+           args op stream op 
+           (1+ print-level) 
+           (find-alt-op op))
+          )
+        )
 
        ;; Exponentials