Paste number 42179: transforming a list like this

Index of paste annotations: 5 | 4 | 3 | 2 | 1

Paste number 42179: transforming a list like this
Pasted by: trebor_home
When:3 years, 1 month ago
Share:Tweet this! | http://paste.lisp.org/+WJN
Channel:#emacs
Paste contents:
Raw Source | XML | Display As 
;;; -*- Mode: Lisp; package:maxima; syntax:common-lisp ;Base: 10 -*- ;;;

(in-package "MAXIMA")
;;** Variable settings were **

;;transcompile:true;
;;tr_semicompile:false;
;;translate_fast_arrays:true;
;;tr_warn_undeclared:compile;
;;tr_warn_meval:compfile;
;;tr_warn_fexpr:compfile;
;;tr_warn_mode:all;
;;tr_warn_undefined_variable:all;
;;tr_function_call_default:general;
;;tr_array_as_ref:true;
;;tr_numer:false;
;;define_variable:false;

(SIMPLIFY
    (LIST '(MEQUAL) (TRD-MSYMEVAL $A1 '$A1)
          (ADD* (MUL* (ADD* (TRD-MSYMEVAL |$a| '|$a|)
                            (*MMINUS (TRD-MSYMEVAL |$c| '|$c|)))
                      (SIMPLIFY
                          (LIST '(%SQRT)
                                (ADD* (TRD-MSYMEVAL |$r2| '|$r2|)
                                      (*MMINUS
                                       (TRD-MSYMEVAL |$r1| '|$r1|))
                                      (*MMINUS
                                       (TRD-MSYMEVAL $DYY '$DYY)))))

Annotations for this paste:

Annotation number 5: Simple hack
Pasted by: pkhuong
When:3 years, 1 month ago
Share:Tweet this! | http://paste.lisp.org/+WJN/5
Paste contents:
Raw Source | Display As 
Really, you're evaluating an expression, but, instead of computing a value, you're building a lisp expression up. You're in luck: your input seems pretty close to CL source, so we can just abuse eval.

(defun maxima->lisp (expr &optional (fn-lookup '((%sqrt . sqrt))))
  (eval `(let ((fn-lookup ',fn-lookup))
	   (flet ((simplify (list)
		    (destructuring-bind ((fn) . args)
			list
		      `(,(or (cdr (assoc fn fn-lookup))
			     fn)
			 ,@args)))
		  (add* (&rest args)
		    `(+ ,@args))
		  (mul* (&rest args)
		    `(+ ,@args))
		  (*mminus (arg)
		    `(- ,arg)))
	     (macrolet ((trd-msymeval (var var-form)
			  (declare (ignore var))
			  var-form)) ; I don't see the point in mangling the var names
	       ,expr)))))

CL-USER> (maxima->lisp '(simplify
			 (list '(mequal) (trd-msymeval $a1 '$a1)
			  (add* (mul* (add* (trd-msymeval $a '$a)
					    (*mminus (trd-msymeval $c '$c)))
				      (simplify
				       (list '(%sqrt)
					     (add* (trd-msymeval $r2 '$r2)
						   (*mminus (trd-msymeval $r1 '$r1))
						   (*mminus (trd-msymeval $dyy '$dyy)))))
				      (simplify
				       (list '(%sqrt)
					     (add* (trd-msymeval $r2 '$r2)
						   (trd-msymeval $r1 '$r1)
						   (trd-msymeval $dyy '$dyy)))))
			   (*mminus (trd-msymeval $d '$d))
			   (trd-msymeval $b '$b)
			   (*mminus (trd-msymeval $dzz '$dzz))
			   (trd-msymeval $dxx '$dxx)))))

(MEQUAL $A1
 (+ (+ (+ $A (- $C)) (SQRT (+ $R2 (- $R1) (- $DYY))) (SQRT (+ $R2 $R1 $DYY)))
    (- $D) $B (- $DZZ) $DXX))

Annotation number 4: blah
Pasted by: fax
When:3 years, 1 month ago
Share:Tweet this! | http://paste.lisp.org/+WJN/4
Paste contents:
Raw Source | Display As 
(defun preliminary-substitutions (expression)
  (dolist (substitution '((+ add*) (- *mminus) (* mul*)))
    (setq expression
	  (deep-substitute (first substitution) (second substitution) expression)))
  expression)

(defun secondary-substitutions (expression)
  (dolist (substitution '(((SIMPLIFY (? x)) (simple x))
			  ((LIST '(MEQUAL) (? x) (? y)) (= x y))
			  ((LIST '(%SQRT) (? x)) (sqrt x))))
    (format t "~S~%" substitution)
    (setq expression
	  (pattern-deep-substitute expression (first substitution) (second substitution))))
  expression)


(defun deep-substitute (new old sequence)
  (mapcar (lambda (elt)
	    (cond ((equal elt old) new)
		  ((listp elt) (deep-substitute new old elt))
		  (t elt)))
	  sequence))

(defun pattern-variable-p (exp)
  (and (consp exp)
       (or (eq '? (car exp)) (eq '?^ (car exp)))
       (cadr exp)))

(defun assoc-conflict (variable-value alist)
  (let ((value (assoc (car variable-value) alist)))
    (if value (not (equal (cdr variable-value) (cdr value))))))

(defun pattern-deep-substitute (sequence old new)
  (if (atom sequence) sequence
    (mapcar (lambda (elt)
	      (multiple-value-bind (matched bindings) (match old elt)
		(cond (matched (setq elt new)
			       (dolist (binding bindings)
				 (setq elt
				      (substitute (second binding)
						  (first binding)
						  elt)))
			       elt)
		      ((listp elt) (mapcar (lambda (elt) (pattern-deep-substitute elt old new)) elt))
		      (t elt))))
	    sequence)))

(defun match (pattern expression &optional bindings)
  (cond ((pattern-variable-p pattern) ;; we have a pattern variable, so check if the thing isnt null
         ;; and if so make a new binding, check it doesnt conflict then cons
         ;; it onto the bindings alist

         (when (or (not (null expression))
                   (eq '?^ (car pattern)))
           (let ((new-binding (cons (pattern-variable-p pattern) expression)))
             (unless (assoc-conflict new-binding bindings)
               (values t (cons new-binding bindings))))))
        ((atom pattern) ;; just check the equality and return the bindings if they are equal
         (when (equal pattern expression)
           (values t bindings)))
        (t ;; we know the pattern is a cons so check the car and cdr
         (unless (and (atom expression) (not (null expression)))
           (if (pattern-variable-p (car pattern))
               ;; if we have a pattern variable, we can matching a bit more
               ;; e.g. ((? x) z) matches (x y z) to bind x to (y z)
               ;; so try every sublist (except we dont need to try the one with length 1,
               ;; it was tested already)
               (loop for sublist-length from 0 to (length expression)
                  do (let ((before (subseq expression 0 sublist-length))
                           (after (subseq expression sublist-length)))
                       (multiple-value-bind (success bindings) (match (car pattern) before bindings)
                         (when success
                           (multiple-value-bind (success bindings) (match (cdr pattern) after bindings)
                             (when success (return-from match (values success bindings)))))))))
           ;; check the car and cdr are match and bindings dont conflict etc
           (multiple-value-bind (success bindings) (match (car pattern) (car expression) bindings)
             (when success
               (multiple-value-bind (success bindings) (match (cdr pattern) (cdr expression) bindings)
                 (when success
                   (return-from match (values success bindings))))))))))

(defmacro pattern-cond (expression &rest clauses)
  (let ((bindings (gensym "bindings")))
    (labels ((make-cond-clauses (clauses)
               (when clauses
                 (if (eq 'else (caar clauses))
                     `((t ,@(cdar clauses)))
                     (cons `((multiple-value-bind (matched values)
                                 (match ',(caar clauses) ,expression)
                               (setq ,bindings values)
                               matched)
                             (progv (mapcar #'car ,bindings) (mapcar #'cdr ,bindings)
                               ,@(cdar clauses)))
                           (make-cond-clauses (cdr clauses)))))))
      `(let* (,bindings)
         (cond ,@(make-cond-clauses clauses))))))

(defparameter *blah* '(SIMPLIFY
    (LIST '(MEQUAL) (TRD-MSYMEVAL $A1 '$A1)
          (ADD* (MUL* (ADD* (TRD-MSYMEVAL |$a| '|$a|)
                            (*MMINUS (TRD-MSYMEVAL |$c| '|$c|)))
                      (SIMPLIFY
                          (LIST '(%SQRT)
                                (ADD* (TRD-MSYMEVAL |$r2| '|$r2|)
                                      (*MMINUS
                                       (TRD-MSYMEVAL |$r1| '|$r1|))
                                      (*MMINUS
                                       (TRD-MSYMEVAL $DYY '$DYY)))))
                      (SIMPLIFY
                          (LIST '(%SQRT)
                                (ADD* (TRD-MSYMEVAL |$r2| '|$r2|)
                                      (TRD-MSYMEVAL |$r1| '|$r1|)
                                      (TRD-MSYMEVAL $DYY '$DYY)))))
                (*MMINUS (TRD-MSYMEVAL |$d| '|$d|))
                (TRD-MSYMEVAL |$b| '|$b|)
                (*MMINUS (TRD-MSYMEVAL $DZZ '$DZZ))
                (TRD-MSYMEVAL $DXX '$DXX)))))

Annotation number 3: possible useful tool
Pasted by: fax
When:3 years, 1 month ago
Share:Tweet this! | http://paste.lisp.org/+WJN/3
Paste contents:
Raw Source | Display As 
(defun preliminary-substitutions (expression)
  (dolist (substitution '((+ add*) (- *mminus) (* mul*)))
    (setq expression
	  (deep-substitute (first substitution) (second substitution) expression)))
  expression)

(defun deep-substitute (new old sequence)
  (mapcar (lambda (elt)
	    (cond ((equal elt old) new)
		  ((listp elt) (deep-substitute new old elt))
		  (t elt)))
	  sequence))

Annotation number 2: maybe something was missing in the original list
Pasted by: trebor_home
When:3 years, 1 month ago
Share:Tweet this! | http://paste.lisp.org/+WJN/2
Paste contents:
Raw Source | Display As 
(SIMPLIFY
    (LIST '(MEQUAL) (TRD-MSYMEVAL $A1 '$A1)
          (ADD* (MUL* (ADD* (TRD-MSYMEVAL |$a| '|$a|)
                            (*MMINUS (TRD-MSYMEVAL |$c| '|$c|)))
                      (SIMPLIFY
                          (LIST '(%SQRT)
                                (ADD* (TRD-MSYMEVAL |$r2| '|$r2|)
                                      (*MMINUS
                                       (TRD-MSYMEVAL |$r1| '|$r1|))
                                      (*MMINUS
                                       (TRD-MSYMEVAL $DYY '$DYY)))))
                      (SIMPLIFY
                          (LIST '(%SQRT)
                                (ADD* (TRD-MSYMEVAL |$r2| '|$r2|)
                                      (TRD-MSYMEVAL |$r1| '|$r1|)
                                      (TRD-MSYMEVAL $DYY '$DYY)))))
                (*MMINUS (TRD-MSYMEVAL |$d| '|$d|))
                (TRD-MSYMEVAL |$b| '|$b|)
                (*MMINUS (TRD-MSYMEVAL $DZZ '$DZZ))
                (TRD-MSYMEVAL $DXX '$DXX))))

Annotation number 1: into this
Pasted by: trebor_home
When:3 years, 1 month ago
Share:Tweet this! | http://paste.lisp.org/+WJN/1
Paste contents:
Raw Source | Display As 

 (LIST '(MEQUAL) A1
       (+ (* (+ a (- c)) (sqrt (+ r2 (- r1) (- dyy))) (sqrt (+ r2 r1 dyy)))
	  (- d)  b  (- dzz)  dxx))

Colorize as:
Show Line Numbers
Index of paste annotations: 5 | 4 | 3 | 2 | 1

Lisppaste pastes can be made by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively.