Screenshot instructions:
Windows
Mac
Red Hat Linux
Ubuntu
Click URL instructions:
Rightclick on ad, choose "Copy Link", then paste here →
(This may not be possible with some types of ads)
From: Dan Stanger <dstang@us...>  20021129 01:43:17

Update of /cvsroot/maxima/maxima/src In directory sc8prcvs1:/tmp/cvsserv11671/maxima/src Added Files: flatten.lisp powers.lisp set.lisp Log Message: Initial checkin of Dr. Willis's code.  NEW FILE: flatten.lisp  ;; Flatten ;; Barton Willis ;; University of Nebraska at Kearney (aka UNK) ;; 1 Nov 2002 ;; License: GPL ;; The user of this code assumes all risk for its use. It has no warranty. ;; If you don't know the meaning of "no warranty," don't use this code. :) ;; Installation and usage: Put flatten.lisp in a directory that ;; Maxima can find. (Maxima can find files in directories described ;; in the list file_search_lisp.) To use flatten, begin by loading it. ;; (C1) load("flatten.lisp")$ ;; (C2) flatten([x=7,[y+x=0,z+1=0], [[xy=2]]]); ;; (D2) [x = 7, y + x = 0, z + 1 = 0, x  y = 2] ;; (C3) m : matrix([a,b],[c,d])$ ;; (C4) flatten(args(m)); ;; (D4) [a, b, c, d] ;; Flatten is somewhat difficult to define  essentially it evaluates an ;; expression as if its main operator had been declared nary; however, there ;; is a difference. We have ;; (C1) load("flatten.lisp"); ;; (D1) flatten.lisp ;; (C2) flatten(f(g(f(f(x))))); ;; (D2) f(g(f(f(x)))) ;; (C3) declare(f,nary); ;; (D3) DONE ;; (C4) ev(d2); ;; (D4) f(g(f(x))) ;; (C5) ;; Unlike declaring the main operator of an expression to be nary, flatten ;; doesn't recurse into other function arguments. ;; This is supposed to be a clone of Macsyma's flatten function. ;; Unlike the Macyma version, this version ;; (a) handles CRE expressions, ;; (b) doesn't try to flatten expressions of the form a^(b^c)  Macsyma's ;; flatten gives an error about a "wrong number of arguments to "^"." ;; (c) doesn't try to flatten expressions of the form a=(b=c). ;; There are other functions other than ^ and = that we shouldn't try ;; to flatten  Bessel functions, etc. (inpackage "MAXIMA") ($put '$flatten 1 '$version) ;; Return the operator and argument of the expression e. (defun getopandarg (e) (let ((op) (arg)) (cond ((or ($atom e) ($subvarp e)) (setq op nil) (setq arg nil)) ((and (consp (nth 0 e)) ($subvarp (nth 1 e))) (setq op `(,(nth 0 e) ,(nth 1 e))) (setq arg (cddr e))) (t (setq op (nth 0 e)) (setq arg (cdr e)))) (values op arg))) (defun $flatten (e) (setq e (ratdisrep e)) (cond ((or ($atom e) ($subvarp e)(or (member ($inpart e 0) (list '&^ '&=)))) e) (t (let ((op (multiplevaluelist (getopandarg e)))) (setq e (cadr op)) (setq op (car op)) (setq e (mapcar #'(lambda (x) (flattenop x op)) e)) (setq e (reduce #'append e)) (cond ((and (consp (car op)) (eq (caar op) 'mqapply)) (append op e)) (t `(,op ,@e))))))) (defun flattenop (e op) (let ((eop) (earg)) (setq eop (multiplevaluelist (getopandarg e))) (setq earg (cadr eop)) (setq eop (car eop)) (cond ((equal eop op) (mapcan #'(lambda (x) (flattenop x op)) earg)) (t (list e)))))  NEW FILE: powers.lisp  ;; Maxima code for extracting all powers ;; Author: Barton Willis ;; Send bug reports to willisb@... ;; This code is in the public domain. It has no warranty. Use this ;; code at your own risk. (inpackage "MAXIMA") ;; Return true iff the main operator of e is '+'. (defun addp (e) (declare (inline addp)) (like ($inpart e 0) '&+)) ;; Return true iff the main operator of e is '*'. (defun multp (e) (declare (inline multp)) (like ($inpart e 0) '&*)) ;; Return true iff the main operator of e is '^'. (defun expp (e) (declare (inline expp)) (like ($inpart e 0) '&^)) (defun powers (e x) (cond (($atom e) (if (like e x) (list 1) (list 0))) (($freeof x e) (list 0)) ((and (expp e) (like (cadr e) x)) (list (caddr e))) ((multp e) (powersmul (margs e) x)) ((addp e) (let ((acc nil)) (powersadd (margs e) x acc))) (t nil))) ;; If e is a list, map $powers over the list. If e is a sum of powers of ;; powers of x, return a list of the exponents; otherwise, return false. ;; $powers works on the internal form of e; call it a bug or a feature, power ;; doesn't expand e. (defun $powers (e x) (cond (($symbolp x) (cond (($listp e) (cons '(mlist) (mapcar #'(lambda (s) ($powers s x)) (margs e)))) (t (let ((p (powers e x))) (cond ((like p nil) nil) (t (cons '(mlist) p))))))) (t (merror "Second argument to POWERS must be a symbol")))) ;; Insert x into a sorted list a. For many expressions, this function ;; isn't as inefficient as it looks; the Maxima simpilifer often sorts ;; the powers from highest to lowest. When this is the case, ;; insertpower only has to make one comparision. This function is ;; very much faster than using merge. (defun insertpower (x a) (cond ((null a) x) ((eql (car x) (car a)) a) (($ordergreatp (car x) (car a)) (cons (car x) a)) (t (cons (car a) (insertpower x (cdr a)))))) ;; Map powers over a Lisp list x using acc as an accumulator. (defun powersadd (e x acc) (cond ((null e) acc) (t (let (p) (setq p (powers (car e) x)) (cond (p (setf acc (insertpower p acc)) (powersadd (cdr e) x acc)) (t nil)))))) ;; If only one element of the list e is a power of x, return the power ;; otherwise, return nil. (defun powersmul (e x) (cond ((null e) nil) (($freeof x (car e)) (powersmul (cdr e) x)) ((freeofl x (cdr e)) (powers (car e) x)) (t nil)))  NEW FILE: set.lisp  ;; Support for Maxima sets. ;; Author: Barton Willis ;; Send bug reports to willisb@... ;; This code is in the public domain. It has no warranty. Use this ;; code at your own risk. (inpackage "MAXIMA") ;; Use the predicate canonlt to order the elements of a set. The ;; default is $unorderedp. The predicate $unorderedp always ;; returns true; when canonlt is its default value, sets are ;; never sorted. Other choices for $canonlt include $ordergreatp ;; and $orderlessp. (defun $unorderedp (a b) t) (defmvar $canonlt '$unorderedp) ;; The set package doesn't distinguish between sets and lists. We're ;; in trouble if we need to work simultaneously with a set of ;; lists and a set of sets. The commerical Macsyma seems to treat ;; all set elements as lists; thus setify([[1,2],[2,1]) returns ;; [[1,2],[2,1]] because [1,2] and [2,1] are treated as lists ;; (and consequently they are not equal). In this package, the ;; user may decide if set elements that are lists are treated as ;; lists or as sets. When $set_elements_can_be_sets is true ;; (the default), set elements that are lists are treated ;; as sets; otherwise, when $set_elements_can_be_sets is ;; false, set elements that are lists are treated as lists. (defmvar $set_elements_can_be_sets t) ;; For nonlists x and y, equalp(x,y) returns is(ratsimp(xy)=0). ;; Signal an error if either x or y is a list. Since equalp uses ;; ratsimp, equalp(x/x,1) is true and equalp(x^(a*b),(x^a)^b) ;; is false. (defun $equalp (x y) (cond ((or ($listp x) ($listp y)) (merror "Both arguments to EQUALP must be nonlists.")) (t ($xequalp x y)))) ;; If you are certain that x and y are not lists, you might call ;; (at Maxima level) ?xequalp instead of equalp. (defun $xequalp (x y) (like 0 ($ratsimp (add* x (*mminus y))))) ;; If x and y are not lists, $elem_equalp(x,y) returns ;; equalp(x,y). If x and y are both lists, return ;; setequality(x,y) if set_elements_can_be_sets; otherwise ;; return equalp(x[1],y[1]) and equalp(x[2],y[2]) and .... ;; Finally, if exactly one of x or y is a list, return false. (defun $elem_equalp (x y) (cond ((and ($listp x) ($listp y)) (cond ($set_elements_can_be_sets ($setequality x y)) ((and ($emptyp x) ($emptyp y)) t) (t (and (= ($length x) ($length y)) ($elem_equalp ($first x) ($first y)) ($elem_equalp ($rest x) ($rest y)))))) ((or ($listp x) ($listp y)) nil) (t ($xequalp x y)))) ;; Adjoin x to the Maxima list a; use equalp for the equality test. ;; When a isn't a list, signal an error. (defun $adjoin (x a) (cond (($listp a) (cons '(mlist) (adjoin x (margs a) :test #'$elem_equalp))) (t (merror "The second argument to ADJOIN must be a list")))) ;; Setify removes duplicates from a Maxima list and sorts the ;; list using the partial ordering function canonlt. To remove the ;; duplicates from the list, we use element_equalp to test for equality. ;; When the argument isn't a list, signal an error. (defun $setify (a) (cond (($listp a) (mysort (cons '(mlist) (removeduplicates (margs a) :test #'$elem_equalp)))) (t (merror "The argument to SETIFY must be a list.")))) ;; When $canonlt is $unorderedp, don't sort; when $canonlt isn't ;; $unorderedp, sort the list using the predicate $canonlt. (defun mysort (a) (cond ((eq $canonlt '$unorderedp) a) (t ($sort a $canonlt)))) ;; The maxima function call union(a1,a2,...an) forms the union of the ;; sets a1,a2,...an. (defmspec $union (a) (setq a (margs a)) (cond ((member nil (mapcar #'$listp a)) (merror "Each argument to UNION must be a list.")) (t (cons '(mlist) (removeduplicates (apply 'append (map 'list 'rest a)) :test #'$elem_equalp))))) ;; Remove elements of b from a. Signal an error if a or b aren't lists. ;; Use element_equalp for the equality test. (defun $setdifference (a b) (cond ((and ($listp a) ($listp b)) (cons '(mlist) (setdifference (margs a) (margs b) :test #'$elem_equalp))) (t (merror "Both arguments to SETDIFFERENCE must be lists.")))) ;; Return the intersection of lists a and b. Use element_equalp for the ;; equality test. Signal an error if a or b aren't lists. (defmspec $intersection (a) (setq a (margs a)) (cond ((member nil (mapcar #'$listp a)) (merror "Each argument to INTERSECTION must be a list.")) (t (setq a (mapcar #'margs a)) (cons '(mlist) (reduce #'(lambda (x y) (intersection x y :test #'$elem_equalp)) a :fromend nil))))) ;; Return true iff a is a subset of b. Signal an error if ;; a or b aren't Maxima lists. (defun $subsetp (a b) (cond ((and ($listp a) ($listp b)) (xsubsetp (margs a) b)) (t (merror "Both arguments to SUBSETP must be lists.")))) ;; xsubsetp returns true if and only if each element of the Lisp ;; list a is a member of the Maxima list b. This function isn't ;; inteneded to be a user function; it doesn't check whether b is a ;; Maxima list. Notice that the empty set is a subset of every ;; set. (defun xsubsetp (a b) (cond ((null a) t) (t (and ($elementp (car a) b) (xsubsetp (cdr a) b))))) ;; Return true iff a is a subset of b and b is a subset of a; return ;; false if a or b are not lists. (defun $setequality (a b) (cond ((and ($listp a) ($listp b)) (if (and ($subsetp a b) ($subsetp b a)) t nil)) (t nil))) ;; Return true iff x as an element of the list a; use $elem_equalp ;; to test for equality if x isn't a list and use $setequality to ;; test for equality if x is a list. Return false if a isn't a list. (defun $elementp (x a) (cond (($listp a) (cond (($listp x) (cond ($set_elements_can_be_sets (if (member x (margs a) :test #'$setequality) t nil)) (t (if (member x (margs a) :test #'$elem_equalp) t nil)))) (t (if (member x (margs a) :test #'$elem_equalp) t nil)))) (t nil))) ;; Return true if e is an empty Maxima list; otherwise, signal an ;; error. (defun $emptyp(e) (cond (($listp e) (like e '((mlist)))) (t (merror "Argument to EMPTYP must be a list.")))) ;; Return an n element Maxima list [e,e,e,...e]. When n < 0 or ;; n isn't an integer, signal an error. (defun $dupe (e n) (cond ((and (integerp n) (> n 1)) (cons '(mlist) (makelist n :initialelement e))) (t (merror "Second argument to DUPE must be a nonnegative integer.")))) ;; Return true if and only if the lists a and b are disjoint; ;; signal an error if a or b aren't lists. (defun $disjointp (a b) (cond ((and ($listp a) ($listp b)) (like nil (intersection (margs a) (margs b) :test #'$elem_equalp))) (t (merror "Both arguments to DISJOINTP must be lists.")))) ;; Return those elements of a for which the predicate f evaluates ;; to true; signal an error if a isn't a list. (defun $subset (a f) (cond (($listp a) (setq a (margs a)) (let ((acc nil)) (dolist (x a (cons '(mlist) acc)) (if (mfuncall f x) (setq acc (cons x acc)))))) (t (merror "First argument to SUBSET must be a list.")))) ;; Return the union of a  b and b  a; signal an error if a or b ;; aren't lists. (defun $symmdifference (a b) (cond ((and ($listp a) ($listp b)) (mfuncall '$union ($setdifference a b) ($setdifference b a))) (t (merror "Both arguments to SYMMDIFFERENCE must be lists.")))) ;; Return a list of the elements in b that are not in a. (defun $complement (a b) (cond ((and ($listp a) ($listp b)) ($setdifference b a)) (t (merror "Both arguments to COMPLEMENT must be lists.")))) ;; Return true if and only if the argument is a Maxima list and the ;; list does not have duplicate elements. setp doesn't check that ;; the list is ordered according to canonlt. (defun $setp (a) (and ($listp a) (setp (margs a)))) (defun setp (a) (cond ((null a) t) (t (and (setp (cdr a)) (not (member (car a) (cdr a) :test #'$elem_equalp)))))) ;; Return the set of all subsets of a. If a has n elements, powerset(a) has ;; 2^n elements. Signal an error if the argument isn't a Maxima list. (defun $powerset (a) (cond (($listp a) (setq a ($setify a)) (cons '(mlist) (mapcar #'(lambda (x) (cons '(mlist) x)) (powerset (margs a))))) (t (merror "Argument to POWERSET must be a list.")))) (defun powerset (a) (cond ((null a) (list nil)) (t (let ((x (car a)) (b (powerset (cdr a)))) (append b (mapcar #'(lambda (u) (cons x u)) b)))))) ;; Return the set of all subsets of a that have exactly n elements. ;; Signal an error if the first argument isn't a Maxima list or if ;; the second argument isn't a nonnegative integer. (defun $subpowerset (a n) (cond (($listp a) (setq a ($setify a)) (cond ((and (integerp n) (> n 1)) (cons '(mlist) (mapcar #'(lambda (x) (cons '(mlist) x)) (subpowerset (margs a) n)))) (t (merror "Second argument to SUBPOWERSET must be a nonnegative integer.")))) (t (merror "First argument to SUBPOWERSET must be a list.")))) (defun subpowerset (a n) (cond ((or (< n 1) (null a)) nil) ((= n 1) (mapcar #'list a)) (t (let ((x (car a)) (b (subpowerset (cdr a) ( n 1)))) (append (subpowerset (cdr a) n) (mapcar #'(lambda (u) (cons x u)) b)))))) 
Sign up for the SourceForge newsletter:
No, thanks