Re: Re: [Maxima] Newbie questions

hi

I wrote sample program about outerproduct (calculate not rather than grade 3).
when we may define new operator in maxima,we feel rather difficulty to describe general destribuitive property.  
The apply1 applies the rule to subexpressions until faling to effect change.(The manual may miss to drop "to effect change")
On the contraly,function style or letsimp or tellsimp or tellsimpafter all this apply the rule as far as it match,
so $B0l(Bat a grance a program is correct,but stack overflow.
Only defrule - apply1 style is suitable
for defining a user operator with destribuitive property .

example
(C1) load("outertest3.mac")$
(C2) display2d:false$
(C3)(a*s[0]+b*s[1]+c*s[2])@^(aa*s[0]+bb*s[1]+cc*s[2])@^(aa1*s[0]+bb1*s[1]+cc1*s[2]);
(D3) (a*s[0]+b*s[1]+c*s[2]) @^ (aa*s[0]+bb*s[1]+cc*s[2])
       @^ (aa1*s[0]+bb1*s[1]+cc1*s[2])
(C4) outersimp(%);
(D4) s[0] @^ s[1] @^ s[2]*a*bb*cc1-s[0] @^ s[1] @^ s[2]*aa*b*cc1
				  -s[0] @^ s[1] @^ s[2]*a*bb1*cc
				  +s[0] @^ s[1] @^ s[2]*aa1*b*cc
				  +s[0] @^ s[1] @^ s[2]*aa*bb1*c
				  -s[0] @^ s[1] @^ s[2]*aa1*bb*c
(C5) factor(%);
(D5)s[0]@^s[1]@^s[2]*(a*bb*cc1-aa*b*cc1-a*bb1*cc+aa1*b*cc+aa*bb1*c
				    -aa1*bb*c)
(C14) (s[0]+s[1]+s[2])@^(s[2]@^s[3]+s[0]@^s[1]);
(D14) (s[2]+s[1]+s[0]) @^ (s[2] @^ s[3]+s[0] @^ s[1])
(C15) outersimp(%);
(D15) s[1]@^s[2]@^s[3]+s[0]@^s[2]@^s[3]+s[0]@^s[1]@^s[2]

outertest3.mac
-------------------------------------------------------------------------
load("ho1.lisp")$
infix("@^");
matchdeclare([i,j,k],integerp)$
matchdeclare([_a,_b,_c],freeof(s[i],s[j],s[k]))$
matchdeclare([x,y,z],true)$ 

tellsimpafter(i@^s[j],i*s[j])$
tellsimpafter(s[i] @^ s[i],0)$
tellsimpafter(s[i] @^ s[j],if (i>j) then -s[j] @^ s[i] )$
tellsimpafter(s[i]@^(s[j]+s[k]),s[i]@^s[j] + s[i]@^s[k]) $
tellsimpafter((s[i]+s[j])@^s[k],s[i]@^s[k] + s[j]@^s[k]) $
tellsimpafter((_a*s[j])@^s[k],_a*(s[j]@^s[k]))$
tellsimpafter(s[j]@^(_a*s[k]),_a*(s[j]@^s[k]))$
tellsimpafter((_b*s[j])@^(_a*s[k]),_b*_a*(s[j]@^s[k]))$
tellsimpafter((_a*(s[i]@^s[j]))@^(_c*s[k]),_a*_c*(s[i]@^s[j]@^s[k]))$
tellsimpafter((_a*s[i])@^(_b*s[j])@^(_c*s[k]),_a*_b*_c*(s[i]@^s[j]@^s[k]))$
tellsimpafter(s[i]@^(s[j]@^s[k]),s[i]@^s[j]@^s[k])$

defrule(outersimp1,x@^y ,block([tama,tama2,_s],_s:0,
if tonton(x)= 0 then (tama:x)else( tama:maplist(part,x)),
if tonton(y)=0 then tama2:y else tama2:maplist(part,y),
if not listp(x) then tama:[tama],
if not listp(y) then tama2:[tama2],
for pu in tama do (
	for pupu in tama2 do (
		_s:_s+ pu @^ pupu
)),_s));		

defrule(outersimp2,x@^y@^z,block([_u],_u:outersimp(x@^y),_u@^z));
defrule(outersimp3,s[i]@^s[j]@^s[k],block( [_q,_q2],if (i=j or j=k or k=i) then 0
else (_q:pmcount([i,j,k]), q2:sort([i,j,k]),(-1)^_q *(s[q2[1]]@^s[q2[2]]@^s[q2[3]]))));
outersimp(_expr):= apply1(_expr,outersimp2,outersimp1,outersimp3);
-----------------------------------------------------------------------------
this is ho1.lisp

;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;

(in-package "MAXIMA")

(defun $tonton (form)
;;  (print   form)
  (ismplus (flatten1 form)) 
)

;; by Paul Graham's book (ON LISP)
(defun flatten1 (x)
  (labels ((rec (x acc)
		(cond ((null x) acc)
		      ((atom x) (cons x acc))
		      (t (rec (car x) (rec (cdr x) acc))))))
    (rec x nil)))

(defun ismplus (flattenlist)
;;;;(print flattenlist)
  (if (null flattenlist)
      0
   (cond ((equal 'MPLUS (car flattenlist)) (return-from ismplus  1))
         (t (ismplus (cdr flattenlist ))))))

;;signature of permutation
(defun $pmcount (form)
  (let ((tform (sort (copy-list (cdr form)) #'<))
	(rtform nil))
    (dolist ( element (cdr form))
      (setf rtform (cons (position element tform) rtform))
) 
    (apply #'+ (mapcar #'(lambda (x) (- (length x) 1))(kankan (reverse rtform))))))

(defun kankan (form)
    (labels ((onecyc  (fform klist)
		       ( if (equal klist 'nil) (setf klist (cons (apply #'max fform) klist)))
		       (let  ((fform2 (coerce (copy-list fform) 'vector)))
			 (cond ((equal 'NIL (find (aref fform2 (car klist)) klist))
				(onecyc fform (cons (aref fform2 (car klist)) klist)))
			       (t (reverse klist)))))
	     ;;replace all element  by 0 at list1 if corresponding to element of list2
	     (ctest2 (list1 list2)
		    (dolist (element list2)
		      (setf list1 (mapcar #'(lambda (xx) (if (equal element xx) '0 xx)) list1)))
		   list1 )
	     ;;main procedure
	     (prodcyc (fform klist2)
		      (let ((klist3 nil))
			(cond ((equal nil (remove-if #'(lambda (xx) (if (equal 0 xx) t)) (copy-list fform)))
			  klist2)
			      (t  
			       (setf klist3 (onecyc fform nil))
			       (setf fform (ctest2 fform klist3))
			       (setf klist2 (cons klist3 klist2))
			      ;;(print form)
			       (prodcyc fform klist2))))))
	     (prodcyc form nil)))
---------------------------------------------------------------
Gosei Furuya (go_furuya@infoseek.jp)


------------------------------------------------------------------------
$B!z$"$J$?$N%[!<%`%Z!<%8$K!H:G?7%K%e!<%9!I$r$*FO$1(B!! by infoseek $B!!!!!!!!!!(B
 http://ap.infoseek.co.jp/ticker5.html $B!!!!(B