待完成
(defun replace-symbolA-with-symbolB-in-term (term0 test-lambda replace-lambda nil-lambda)
(declare (optimize (safety 0) (speed 3)))
(multiple-value-bind (rest-term find-term) (cut-term test-lambda term0)
(if find-term
(c** (c-number term0) rest-term (funcall replace-lambda find-term))
(c** (c-number term0) rest-term (funcall nil-lambda)) )))
(defun replace-termA-with-termB-in-terms (terms0 test-lambda replace-lambda nil-lambda)
(declare (optimize (safety 0) (speed 3)))
(let ((new-terms (make-instance 'c-terms)))
(dolist (b-term (term-list terms0))
(setf new-terms (c+$ new-terms (replace-symbolA-with-symbolB-in-term b-term test-lambda replace-lambda nil-lambda))))
(s new-terms)))
(defun cut-term-with-number (test-lambda term0)
(declare (optimize (safety 0) (speed 3)))
(let ((find-term nil) (rest-term nil))
(dolist (symbol-a (symbol-list (dup-term term0)))
(if find-term (setf rest-term (append rest-term (list symbol-a)))
(if (funcall test-lambda symbol-a)
(setf find-term symbol-a)
(setf rest-term (append rest-term (list symbol-a)))
) ) )
(values (c* (cc-number term0) (make-instance 'c-term :symbol-list rest-term )) find-term)
))
(defmacro define-operator (name1 &optional (other-name1 'non-use-othername))
(let ((test-lambda-name (funcall (intern (string-upcase (concatenate 'string (symbol-name name1) "-test-lambda")))))
(replace-lambda-name (funcall (intern (string-upcase (concatenate 'string (symbol-name name1) "-replace-lambda")))))
(nil-lambda-name (funcall (intern (string-upcase (concatenate 'string (symbol-name name1) "-nil-lambda"))))))
`(progn
(defmethod ,name1 ((vector-a c-vector))
(declare (optimize (safety 0) (speed 3)))
(c* 1 (funcall ,replace-lambda-name vector-a)) )
(defmethod ,name1 ((term-a c-term))
(declare (optimize (safety 0) (speed 3)))
(let ((test-lambda ,test-lambda-name)
(replace-lambda ,replace-lambda-name)
(nil-lambda ,nil-lambda-name))
(replace-symbolA-with-symbolB-in-term term-a test-lambda replace-lambda nil-lambda)
))
(defmethod ,name1 ((terms-a c-terms))
(declare (optimize (safety 0) (speed 3)))
(let ((test-lambda ,test-lambda-name)
(replace-lambda ,replace-lambda-name)
(nil-lambda ,nil-lambda-name))
(replace-termA-with-termB-in-terms terms-a test-lambda replace-lambda nil-lambda)
))
(defmethod ,name1 ((terms-a (eql nil)))
nil)
(defun ,other-name1 (parameter1)
(,name1 parameter1)))
))
(defmacro define-operator-func (name1 &optional (other-name1 'non-use-othername))
(let ((test-lambda-name (funcall (intern (string-upcase (concatenate 'string (symbol-name name1) "-test-lambda")))))
(replace-lambda-name (funcall (intern (string-upcase (concatenate 'string (symbol-name name1) "-replace-lambda")))))
(nil-lambda-name (funcall (intern (string-upcase (concatenate 'string (symbol-name name1) "-nil-lambda"))))))
`(progn
(defmethod ,name1 ((func-a c-func))
(declare (optimize (safety 0) (speed 3)))
(c* 1 (funcall ,replace-lambda-name func-a)) )
(defmethod ,name1 ((term-a c-term))
(declare (optimize (safety 0) (speed 3)))
(let ((test-lambda ,test-lambda-name)
(replace-lambda ,replace-lambda-name)
(nil-lambda ,nil-lambda-name))
(replace-symbolA-with-symbolB-in-term term-a test-lambda replace-lambda nil-lambda)
))
(defmethod ,name1 ((terms-a c-terms))
(declare (optimize (safety 0) (speed 3)))
(let ((test-lambda ,test-lambda-name)
(replace-lambda ,replace-lambda-name)
(nil-lambda ,nil-lambda-name))
(replace-termA-with-termB-in-terms terms-a test-lambda replace-lambda nil-lambda)
))
(defmethod ,name1 ((terms-a (eql nil)))
nil)
(defun ,other-name1 (parameter1)
(,name1 parameter1)))
))
;--------
(defmacro define-use-saved (name1)
(let ((real-func-name (intern (string-upcase (concatenate 'string (symbol-name name1) "-real"))))
(init-zero-name (intern (string-upcase (concatenate 'string (symbol-name name1) "-init-zero"))))
(show-name (intern (string-upcase (concatenate 'string (symbol-name name1) "-show"))))
) ;ref!!!! from onlisp
`(let ((saved-result-list nil))
(defmethod ,name1 ((c1 c-vector) (c2 c-vector))
(declare (optimize (safety 0) (speed 3)))
(let ((result nil))
(block stop1
(dolist (result-tuple saved-result-list)
(if (and (symbol=? c1 (first result-tuple)) (symbol=? c2 (second result-tuple)))
(progn (setf result (third result-tuple))
(return-from stop1))))
(setf result (s (,real-func-name c1 c2)))
(setf saved-result-list (append saved-result-list (list (list c1 c2 (dup-terms result)))))
)
result))
(defun ,init-zero-name ()
(setf saved-result-list nil))
(defun ,show-name ()
(dolist (c3 saved-result-list)
(print-c (first c3)) (print-c (second c3)) (print-c (third c3)) (princ " -- "))
)
)))
(defmacro define-use-saved-with-r (name1)
(let ((real-func-name (intern (string-upcase (concatenate 'string (symbol-name name1) "-real"))))
(init-zero-name (intern (string-upcase (concatenate 'string (symbol-name name1) "-init-zero"))))
(show-name (intern (string-upcase (concatenate 'string (symbol-name name1) "-show"))))
)
`(let ((saved-result-list nil))
(defmethod ,name1 ((c1 c-term) (c2 c-term))
(declare (optimize (safety 0) (speed 3)))
(let ((result nil))
(multiple-value-bind (c1-rest c1-r c1-vec) (Pick-Ynm-and-R c1)
(multiple-value-bind (c2-rest c2-r c2-vec) (Pick-Ynm-and-R c2)
(block stop1
(dolist (result-tuple saved-result-list)
(if (and (symbol=? c1-vec (first result-tuple)) (symbol=? c2-vec (second result-tuple))
(symbol=? c1-r (third result-tuple)) (symbol=? c2-r (fourth result-tuple)))
(progn (setf result (fifth result-tuple))
(return-from stop1))))
(setf result (s (,real-func-name (c* c1-r c1-vec) (c* c2-r c2-vec))))
(setf saved-result-list (append saved-result-list
(list (list c1-vec c2-vec c1-r c2-r (dup-terms result))))))
(c*. c1-rest c2-rest result)))))
(defun ,init-zero-name ()
(setf saved-result-list nil))
(defun ,show-name ()
(dolist (c3 saved-result-list)
(print-c (first c3)) (print-c (second c3)) (print-c (third c3)) (princ " -- "))))))
;---
(defun look-up-pos-in-beans (vector-list vector1 l1)
(block here1
(dotimes (i l1)
(if (symbol=? (aref vector-list i) vector1) (return-from here1 i) )
)
-1
))
(defun vector-or-r (v1)
(if (null v1) (make-num 1)
v1))
(defmacro rip-beans-vector-poly (c1 vector-list poly-list l1)
`(dolist (c1a (term-list ,c1))
(let ((pos1 -1))
(multiple-value-bind (poly1 vector1) (cut-term-with-number #'(lambda (s1) (eq (type-of s1) 'c-vector)) c1a)
(setf pos1 (look-up-pos-in-beans ,vector-list (vector-or-r vector1) ,l1))
(if (= pos1 -1) (setf pos1 ,l1 ,l1 (+ 1 ,l1) (aref ,vector-list pos1) (dup-symbol (vector-or-r vector1))) )
(setf (aref ,poly-list pos1) (c+ (aref ,poly-list pos1) poly1))
) ) ) )
(defmacro insert-to-beans (v1 t1 vector-list poly-list l1)
`(dolist (c1a (term-list ,v1))
(let ((pos1 -1))
(multiple-value-bind (poly1 vector1) (cut-term-with-number #'(lambda (s1) (eq (type-of s1) 'c-vector)) c1a)
(setf pos1 (look-up-pos-in-beans ,vector-list (vector-or-r vector1) ,l1))
(if (= pos1 -1) (setf pos1 ,l1 ,l1 (+ 1 ,l1) (aref ,vector-list pos1) (dup-symbol (vector-or-r vector1)) ))
(setf (aref ,poly-list pos1) (c+ (aref ,poly-list pos1) (c* poly1 ,t1 )) )
) ) ) )
;;--------
;(defmacro Div (&body parameter1)
; `(Div-U ,@parameter1))
;;-----Conjugate-vec
(defmacro conj-v (&body parameter1)
`(Conjugate-vec ,@parameter1))
(defmacro Walk-terms (&body parameter1)
`(Walk-Through-terms-in-*-r2->beans-BC ,@parameter1))
(defmacro c-base-l (&body parameter1)
`(construct-layer-base-list ,@parameter1))
(defmacro c-trial-l (&body parameter1)
`(construct-layer-trial-list ,@parameter1))
;;---
(defun replace-old-new (tree1 var-old var-new)
(let ((word1 tree1))
(dotimes (i (length var-old))
(if (eq word1 (nth i var-old)) (setf word1 (aref var-new i))) )
word1
))
(defun tree-var-substitue (tree1 var-old var-new)
(cond ((null tree1) nil)
((atom tree1) (replace-old-new tree1 var-old var-new))
(t (append (list (tree-var-substitue (first tree1) var-old var-new))
(tree-var-substitue (rest tree1) var-old var-new)))) )
(defmacro Operators[A]->[Ai] (var-list1 &body body1)
(let* ((len1 (length var-list1))
(var-array (make-array (list len1)))
(new-body nil) )
(dotimes (i len1)
(setf (aref var-array i) (gensym)) )
(setf new-body (tree-var-substitue body1 var-list1 var-array))
(dotimes (i len1)
(if (= 0 i) (setf new-body `(dolist (,(aref var-array i) (term-list ,(nth i var-list1)) )
,@new-body))
(setf new-body `(dolist (,(aref var-array i) (term-list ,(nth i var-list1)) )
,new-body
) ) ))
new-body
))
;---
(defmacro Terms[op]Terms->Term[op]Term (name1)
(let ((op-name (intern (string-upcase (symbol-name name1) ))))
;; c+ or c+$ ?
`(defmethod ,op-name ((c1 c-terms) (c2 c-terms))
(declare (optimize (safety 0) (speed 3)))
(let ((new-terms (make-instance 'c-terms)))
(dolist (b-term (term-list c1))
(dolist (a-term (term-list c2))
(setf new-terms (c+ new-terms (,op-name (dup-term b-term) (dup-term a-term))))))
(s new-terms)))
))
(defmacro Term[op]Term->Vec[op]Vec (name1)
(let ((op-name (intern (string-upcase (symbol-name name1) ))))
`(defmethod ,op-name ((term-a c-term) (term-b c-term))
(declare (optimize (safety 0) (speed 3)))
(multiple-value-bind (rest-term-a find-term-a) (cut-term-with-number (dot-test-lambda) (dup-term term-a))
(multiple-value-bind (rest-term-b find-term-b) (cut-term-with-number (dot-test-lambda) (dup-term term-b))
(c** rest-term-a rest-term-b (,op-name find-term-a find-term-b)))) ) ))
;--
(defmacro clean-coeff-list-in-bean (c1)
(let ((i (gensym)) (j (gensym)) (k (gensym)))
`(dotimes (.i 4)
(dotimes (,j 100)
(dotimes (,k 40)
(setf (coeff-list (aref ,c1 ,i ,j ,k)) nil))))))
;-
(defmacro aref-beanpod-r (bean1 r-order1)
`(aref (r-beanpod ,bean1) ,r-order1) )
(defmacro add-coeff->Bean (left-right-pod Ynm2 rest-term3 r2)
`(let ((pos1 -1))
(dolist (bean1 ,left-right-pod)
(if (and (= (i bean1) (Y-R-S-T->0123 ,Ynm2)) (= (j bean1) (vect->ind ,Ynm2)))
(setf (coeff-list (aref-beanpod-r bean1 ,r2))
(c+ (coeff-list (aref-beanpod-r bean1 ,r2))
,rest-term3) pos1 1)) )
(if (= -1 pos1)
(let ((beanpod1 (make-instance 'c-Xnm-bean :i (Y-R-S-T->0123 ,Ynm2) :j (vect->ind ,Ynm2))))
(dotimes (illl *bean-r-max*)
(setf (aref-beanpod-r beanpod1 illl) (make-instance 'c-r-bean )))
(setf (coeff-list (aref-beanpod-r beanpod1 ,r2)) (*->terms ,rest-term3))
(setf ,left-right-pod (append ,left-right-pod (list (copy-instance beanpod1))))))))
扫一扫
7786
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
