Menu
▾
▴
[Maxima-commits] CVS: maxima/share/contrib/amatrix amatrix.dem, 1.1, 1.2 amatrix.lisp, 1.3, 1.4 amatrix.mac, 1.4, 1.5
|
From: Robert D. <rob...@us...> - 2008-07-14 01:21:17
|
Update of /cvsroot/maxima/maxima/share/contrib/amatrix In directory sc8-pr-cvs16.sourceforge.net:/tmp/cvs-serv20549/share/contrib/amatrix Modified Files: amatrix.dem amatrix.lisp amatrix.mac Log Message: Some extensions and revisions of the amatrix stuff. * amatrix.dem: expand and revise demo * amatrix.lisp: (1) handle assignment to 1-subscript amatrix expression (2) handle list subscript (by itself or with integer, all, or another list) * amatrix.mac: (1) handle one subscript of various types (2) cut out some unused declarations Index: amatrix.dem =================================================================== RCS file: /cvsroot/maxima/maxima/share/contrib/amatrix/amatrix.dem,v retrieving revision 1.1 retrieving revision 1.2 diff -u -d -r1.1 -r1.2 --- amatrix.dem 5 Jul 2008 00:04:00 -0000 1.1 +++ amatrix.dem 14 Jul 2008 01:21:13 -0000 1.2 @@ -1,76 +1,134 @@ -foo : random_matrix (10, 5); -bar : foo [all, 1]; -baz : amatrixmap (lambda ([x], is (x > 1/8)), bar); -quux : amatrixmap (lambda ([x], is (x > 3/4)), bar); -mumble : foo [1, all]; -blurf : amatrixmap (lambda ([x], is (x < 1/2)), mumble); -snort : amatrixmap (lambda ([x], is (x < 5/8)), mumble); +if get ('amatrix, 'version) = false then load (amatrix) else 'already_loaded; -/* integer */ +"... Hilbert matrix ..."$ + +foo : make_matrix (7, 5)$ +for i thru foo@nr do for j thru foo@nc do foo [i, j] : 1/(i + j - 1); +foo; + +"... Integer subscripts ..."$ foo [1, 1]; -/* 'all */ +foo [1, 1] : 42; + +foo; + +"... 'all subscripts ..."$ foo [all, 1]; foo [1, all]; foo [all, all]; -/* list of integers */ +bar : foo [all, 1]; + +mumble : foo [1, all]; + +"... Collective assignment ..."$ + +foo [all, 2] : %pi; + +foo; + +foo [all, 5] : foo [all, 1]; + +foo; + +"... Implicit subscript=1 when #rows=1 or #columns=1 ..."$ + +bar; + +bar [1]; + +bar [all]; + +"... Copy-on-write policy ..."$ + +bar [1]; + +bar [1] : 1729; + +bar; + +mumble; + +"... List of integers subscripts ..."$ foo [[1, 5, 3], 1]; -foo [1, [2, 1, 4]]; -foo [[2, 3, 7], all]; foo [all, [5, 4, 3]]; -foo [[5, 7, 10], [2, 5]]; +foo [[5, 6, 7], [2, 5]]; -/* amatrix of booleans */ +"... amatrix of Boolean values subscripts ..."$ + +baz : amatrixmap (lambda ([x], is (x > 3/10)), bar); + +quux : amatrixmap (lambda ([x], is (x < 1/4)), bar); + +blurf : amatrixmap (lambda ([x], is (x < 1/2)), mumble); + +snort : amatrixmap (lambda ([x], is (x >= 1/3)), mumble); foo [baz, 4]; -foo [8, blurf]; + +foo [6, blurf]; foo [baz, all]; + foo [all, blurf]; foo [baz, [1, 5]]; -foo [[2, 7, 9], blurf]; + +foo [[2, 3, 6], blurf]; foo [baz, blurf]; -/* relational expression */ +"... Relational expressions subscripts ..."$ + +bar; + +bar [bar > 2/3]; foo [bar >= 1/4, 4]; + foo [6, 3/4 >= mumble]; foo [bar > 1/2, all]; + foo [all, mumble < 1/2]; foo [bar # 1/2, [5, 2]]; + foo [[4, 3, 2], mumble < 3/7]; foo [bar <= 7/8, blurf]; + foo [baz, mumble > 1/8]; foo [bar > 2/7, 8/9 >= mumble]; -/* boolean expression */ +"... Boolean expressions subscripts ..."$ foo [not baz, 3]; + foo [7, blurf and snort]; foo [baz and not quux, all]; + foo [all, not blurf or snort]; foo [baz or quux, [1, 2, 4]]; + foo [[3, 2, 5], not blurf and snort]; foo [quux and baz, snort]; + foo [quux, not blurf]; foo [not quux and not baz, mumble < 0.95]; + foo [bar > 0.15, not blurf or not snort]; foo [quux or baz, blurf or not snort]; Index: amatrix.lisp =================================================================== RCS file: /cvsroot/maxima/maxima/share/contrib/amatrix/amatrix.lisp,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- amatrix.lisp 5 Jul 2008 19:02:04 -0000 1.3 +++ amatrix.lisp 14 Jul 2008 01:21:13 -0000 1.4 @@ -26,7 +26,22 @@ (putprop '$amatrix 'amatrix-assign 'mset_extension_operator) (defun amatrix-assign (e x) - (amatrix-assign1 (caar e) (symbol-value (caar e)) (meval (cadr e)) (meval (caddr e)) x)) + (let + ((my-amatrix-name (caar e)) + (my-amatrix (symbol-value (caar e)))) + (cond + ((= (length e) 2) + (cond + ((= ($nrows my-amatrix) 1) + (amatrix-assign1 my-amatrix-name my-amatrix 1 (meval (cadr e)) x)) + ((= ($ncols my-amatrix) 1) + (amatrix-assign1 my-amatrix-name my-amatrix (meval (cadr e)) 1 x)) + (t + (merror "amatrix assignment: given one subscript, but expected two")))) + ((= (length e) 3) + (amatrix-assign1 (caar e) (symbol-value (caar e)) (meval (cadr e)) (meval (caddr e)) x)) + (t + (merror "amatrix assignment: expected one or two subscripts"))))) (defun amatrix-assign1 (lhs aa i j x) (when (> (get ($@-function aa '$storage) 'refcount) 1) @@ -41,9 +56,19 @@ ((and (eq i '$all) (integerp j)) (amatrix-assign1-all-column aa j x)) ((and (integerp i) (eq j '$all)) - (amatrix-assign1-all-row aa i x)) + (amatrix-assign1-row-all aa i x)) ((and (eq i '$all) (eq j '$all)) (amatrix-assign1-all-all aa x)) + ((and ($listp i) (integerp j)) + (amatrix-assign1-list-integer aa i j x)) + ((and (integerp i) ($listp j)) + (amatrix-assign1-integer-list aa i j x)) + ((and ($listp i) (eq j '$all)) + (amatrix-assign1-list-all aa i x)) + ((and (eq i '$all) ($listp j)) + (amatrix-assign1-all-list aa j x)) + ((and ($listp i) ($listp j)) + (amatrix-assign1-list-list aa i j x)) (t `((mset) ((,aa array) ,i ,j) ,x)))) @@ -63,7 +88,7 @@ (amatrix-assign1-row-column aa (1+ i) j x)))) x) -(defun amatrix-assign1-all-row (aa i x) +(defun amatrix-assign1-row-all (aa i x) (let ((n ($@-function aa '$nc))) (if ($amatrixp x) ;; MIGHT WANT TO ENSURE THAT X HAS EXACTLY ONE ROW AND SAME NUMBER OF COLUMNS AS AA @@ -87,6 +112,74 @@ (amatrix-assign1-row-column aa (1+ i) (1+ j) x))))) x) +(defun amatrix-assign1-list-integer (aa l j x) + (amatrix-assign1-list-list aa l `((mlist) ,j) x)) + +(defun amatrix-assign1-integer-list (aa i l x) + (amatrix-assign1-list-list aa `((mlist) ,i) l x)) + +(defun amatrix-assign1-list-all (aa l x) + (let + ((m ($length l)) + (n ($@-function aa '$nc))) + (if ($amatrixp x) + ;; MIGHT WANT TO ENSURE THAT X HAS SAME NUMBER OF ROWS AND COLUMNS AS AA + (dotimes (i m) + (dotimes (j n) + (amatrix-assign1-row-column aa (nth (1+ i) l) (1+ j) (mfuncall '$get_element x (1+ i) (1+ j))))) + (dotimes (i m) + (dotimes (j n) + (amatrix-assign1-row-column aa (nth (1+ i) l) (1+ j) x))))) + x) + +(defun amatrix-assign1-all-list (aa l x) + (let + ((m ($@-function aa '$nr)) + (n ($length l))) + (if ($amatrixp x) + ;; MIGHT WANT TO ENSURE THAT X HAS SAME NUMBER OF ROWS AND COLUMNS AS AA + (dotimes (i m) + (dotimes (j n) + (amatrix-assign1-row-column aa (1+ i) (nth (1+ j) l) (mfuncall '$get_element x (1+ i) (1+ j))))) + (dotimes (i m) + (dotimes (j n) + (amatrix-assign1-row-column aa (1+ i) (nth (1+ j) l) x))))) + x) + +(defun amatrix-assign1-list-list (aa l1 l2 x) + (let + ((m ($length l1)) + (n ($length l2))) + (if ($amatrixp x) + ;; MIGHT WANT TO ENSURE THAT X HAS SAME NUMBER OF ROWS AND COLUMNS AS AA + (dotimes (i m) + (dotimes (j n) + (amatrix-assign1-row-column + aa + (nth (1+ i) l1) + (nth (1+ j) l2) + (mfuncall '$get_element x (1+ i) (1+ j))))) + (dotimes (i m) + (dotimes (j n) + (amatrix-assign1-row-column + aa + (nth (1+ i) l1) + (nth (1+ j) l2) + x))))) + x) + +(defun amatrix-assign1-amatrix-column (aa ai j x)) + +(defun amatrix-assign1-row-amatrix (aa i aj x)) + +(defun amatrix-assign1-amatrix-amatrix (aa ai aj x)) + +(defun amatrix-assign1-boolean-column (aa b j x)) + +(defun amatrix-assign1-row-boolean (aa i b x)) + +(defun amatrix-assign1-boolean-boolean (aa b1 b2 x)) + (displa-def $amatrix dim-$amatrix) ; CALL SIMPLIFYA IN DIM-$NEWMATRIX BECAUSE DIM-$MATRIX NEEDS TO SEE SIMP FLAG ... SIGH Index: amatrix.mac =================================================================== RCS file: /cvsroot/maxima/maxima/share/contrib/amatrix/amatrix.mac,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- amatrix.mac 5 Jul 2008 19:06:25 -0000 1.4 +++ amatrix.mac 14 Jul 2008 01:21:13 -0000 1.5 @@ -66,14 +66,10 @@ matchdeclare (a%, symbolp, [LI%, LI1%, LI2%], integer_listp, - [R%, R1%, R2%], relationalp, - [B%, B1%, B2%], booleanexprp, [MB%, MB1%, MB2%], putative_boolean_amatrixp, [ii%, jj%, i0%, j0%, u%, v%, x%, y%], integerp); integer_listp (e) := not atom(e) and op(e) = "[" and every (integerp, e); -relationalp (e) := not atom(e) and member (op(e), ["<", "<=", "=", "#", ">=", ">"]); -booleanexprp (e) := not atom(e) and member (op(e), ["and", "or", "not"]); putative_boolean_amatrixp (e) := not atom(e) and op(e) = amatrix @@ -102,17 +98,15 @@ then error ("Matrix index out of bounds") else ?aref (a%, i%)); -/* one subscript => [subscript, 1] or [1, subscript] */ +/* one integer */ tellsimpafter - (amatrix (u%, i0%, x%, v%, j0%, y%, a%) [ii%], - if u% = 1 then get_element_internal (u%, i0%, x%, v%, j0%, y%, a%, 1, ii%) - elseif v% = 1 then get_element_internal (u%, i0%, x%, v%, j0%, y%, a%, ii%, 1) - /* Throwing here is unsatisfactory. I might create a noun instead - * but by the time we get here, the symbol to which amatrix(...) - * is bound has been lost. - */ - else throw (oops ("This matrix requires two subscripts"))); + (amatrix (1, i0%, x%, v%, j0%, y%, a%) [ii%], + get_element_internal (1, i0%, x%, v%, j0%, y%, a%, 1, ii%)); + +tellsimpafter + (amatrix (u%, i0%, x%, 1, j0%, y%, a%) [ii%], + get_element_internal (u%, i0%, x%, 1, j0%, y%, a%, ii%, 1)); /* integers both */ @@ -120,6 +114,18 @@ (amatrix (u%, i0%, x%, v%, j0%, y%, a%) [ii%, jj%], get_element_internal (u%, i0%, x%, v%, j0%, y%, a%, ii%, jj%)); +/* one 'all */ + +tellsimpafter + (amatrix (1, i0%, x%, v%, j0%, y%, a%) [all], + (incprop (a%, '?refcount), + amatrix (1, i0%, x%, v%, j0%, y%, a%))); + +tellsimpafter + (amatrix (u%, i0%, x%, 1, j0%, y%, a%) [all], + (incprop (a%, '?refcount), + amatrix (u%, i0%, x%, 1, j0%, y%, a%))); + /* 'all and an integer */ tellsimpafter @@ -139,6 +145,16 @@ (incprop (a%, '?refcount), amatrix (u%, i0%, x%, v%, j0%, y%, a%))); +/* one list of integers */ + +tellsimpafter + (amatrix (1, i0%, x%, v%, j0%, y%, a%) [LI%], + submatrix_by_indices (1, i0%, x%, v%, j0%, y%, a%, [1], LI%)); + +tellsimpafter + (amatrix (u%, i0%, x%, 1, j0%, y%, a%) [LI%], + submatrix_by_indices (u%, i0%, x%, 1, j0%, y%, a%, LI%, [1])); + /* list of integers and an integer */ tellsimpafter @@ -165,6 +181,16 @@ (amatrix (u%, i0%, x%, v%, j0%, y%, a%) [LI1%, LI2%], submatrix_by_indices (u%, i0%, x%, v%, j0%, y%, a%, LI1%, LI2%)); +/* one amatrix of booleans */ + +tellsimpafter + (amatrix (1, i0%, x%, v%, j0%, y%, a%) [MB%], + submatrix_by_indices_and_flags (1, i0%, x%, v%, j0%, y%, a%, [1], MB%)); + +tellsimpafter + (amatrix (u%, i0%, x%, 1, j0%, y%, a%) [MB%], + submatrix_by_flags_and_indices (u%, i0%, x%, 1, j0%, y%, a%, MB%, [1])); + /* amatrix of booleans and an integer */ tellsimpafter |