Mercurial > emacs
comparison lisp/calc/calc-misc.el @ 41045:3491bfbd825e
(math-fixnump, math-fixnatnump, calcFunc-trunc, calcFunc-floor,
calc-report-bug): Use `defalias' instead of `fset' and
`symbol-function'.
Style cleanup; don't put closing parens on their
own line, add "foo.el ends here" to each file, and update
copyright date.
author | Colin Walters <walters@gnu.org> |
---|---|
date | Wed, 14 Nov 2001 09:06:05 +0000 |
parents | ee9c2872370b |
children | e9718841a5b1 |
comparison
equal
deleted
inserted
replaced
41044:4549dec29728 | 41045:3491bfbd825e |
---|---|
93 (scroll-down)) | 93 (scroll-down)) |
94 (error (beep)))) | 94 (error (beep)))) |
95 (calc-unread-command (cdr key)))))) | 95 (calc-unread-command (cdr key)))))) |
96 (calc-do-dispatch nil)) | 96 (calc-do-dispatch nil)) |
97 (let ((calc-dispatch-help t)) | 97 (let ((calc-dispatch-help t)) |
98 (calc-do-dispatch arg))) | 98 (calc-do-dispatch arg)))) |
99 ) | |
100 | 99 |
101 | 100 |
102 (defun calc-big-or-small (arg) | 101 (defun calc-big-or-small (arg) |
103 "Toggle Calc between full-screen and regular mode." | 102 "Toggle Calc between full-screen and regular mode." |
104 (interactive "P") | 103 (interactive "P") |
121 (progn | 120 (progn |
122 (calc-quit) | 121 (calc-quit) |
123 (calc nil calc-full-mode nil)))) | 122 (calc nil calc-full-mode nil)))) |
124 (message (if calc-full-mode | 123 (message (if calc-full-mode |
125 "Now using full screen for Calc." | 124 "Now using full screen for Calc." |
126 "Now using partial screen for Calc."))) | 125 "Now using partial screen for Calc.")))) |
127 ) | |
128 | 126 |
129 (defun calc-other-window () | 127 (defun calc-other-window () |
130 "Invoke the Calculator in another window." | 128 "Invoke the Calculator in another window." |
131 (interactive) | 129 (interactive) |
132 (if (memq major-mode '(calc-mode calc-trail-mode)) | 130 (if (memq major-mode '(calc-mode calc-trail-mode)) |
135 (if (memq major-mode '(calc-mode calc-trail-mode)) | 133 (if (memq major-mode '(calc-mode calc-trail-mode)) |
136 (other-window 1))) | 134 (other-window 1))) |
137 (if (get-buffer-window "*Calculator*") | 135 (if (get-buffer-window "*Calculator*") |
138 (calc-quit) | 136 (calc-quit) |
139 (let ((win (selected-window))) | 137 (let ((win (selected-window))) |
140 (calc nil win (interactive-p))))) | 138 (calc nil win (interactive-p)))))) |
141 ) | |
142 | 139 |
143 (defun another-calc () | 140 (defun another-calc () |
144 "Create another, independent Calculator buffer." | 141 "Create another, independent Calculator buffer." |
145 (interactive) | 142 (interactive) |
146 (if (eq major-mode 'calc-mode) | 143 (if (eq major-mode 'calc-mode) |
147 (mapcar (function | 144 (mapcar (function |
148 (lambda (v) | 145 (lambda (v) |
149 (set-default v (symbol-value v)))) calc-local-var-list)) | 146 (set-default v (symbol-value v)))) calc-local-var-list)) |
150 (set-buffer (generate-new-buffer "*Calculator*")) | 147 (set-buffer (generate-new-buffer "*Calculator*")) |
151 (pop-to-buffer (current-buffer)) | 148 (pop-to-buffer (current-buffer)) |
152 (calc-mode) | 149 (calc-mode)) |
153 ) | |
154 | 150 |
155 | 151 |
156 ;;; Make an attempt to preserve the window configuration, while deleting | 152 ;;; Make an attempt to preserve the window configuration, while deleting |
157 ;;; windows on "bufs". Emacs 19's delete-window function will probably | 153 ;;; windows on "bufs". Emacs 19's delete-window function will probably |
158 ;;; make this kludgery unnecessary, but Emacs 18's tendency to grow all | 154 ;;; make this kludgery unnecessary, but Emacs 18's tendency to grow all |
214 (select-window w)) | 210 (select-window w)) |
215 (setq main w | 211 (setq main w |
216 mainpos (nth 1 (car wins)) | 212 mainpos (nth 1 (car wins)) |
217 wins (cdr wins))) | 213 wins (cdr wins))) |
218 (if (window-point sel) | 214 (if (window-point sel) |
219 (select-window sel)))))) | 215 (select-window sel))))))) |
220 ) | |
221 | 216 |
222 | 217 |
223 (defun calc-info () | 218 (defun calc-info () |
224 "Run the Emacs Info system on the Calculator documentation." | 219 "Run the Emacs Info system on the Calculator documentation." |
225 (interactive) | 220 (interactive) |
239 (info) | 234 (info) |
240 (error nil)) | 235 (error nil)) |
241 (or (and (boundp 'Info-current-file) | 236 (or (and (boundp 'Info-current-file) |
242 (stringp Info-current-file) | 237 (stringp Info-current-file) |
243 (string-match "calc" Info-current-file)) | 238 (string-match "calc" Info-current-file)) |
244 (Info-find-node calc-info-filename "Top")) | 239 (Info-find-node calc-info-filename "Top"))) |
245 ) | |
246 | 240 |
247 (defun calc-tutorial () | 241 (defun calc-tutorial () |
248 "Run the Emacs Info system on the Calculator Tutorial." | 242 "Run the Emacs Info system on the Calculator Tutorial." |
249 (interactive) | 243 (interactive) |
250 (if (get-buffer-window "*Calculator*") | 244 (if (get-buffer-window "*Calculator*") |
251 (calc-quit)) | 245 (calc-quit)) |
252 (calc-info) | 246 (calc-info) |
253 (Info-goto-node "Interactive Tutorial") | 247 (Info-goto-node "Interactive Tutorial") |
254 (calc-other-window) | 248 (calc-other-window) |
255 (message "Welcome to the Calc Tutorial!") | 249 (message "Welcome to the Calc Tutorial!")) |
256 ) | |
257 | 250 |
258 (defun calc-info-summary () | 251 (defun calc-info-summary () |
259 "Run the Emacs Info system on the Calculator Summary." | 252 "Run the Emacs Info system on the Calculator Summary." |
260 (interactive) | 253 (interactive) |
261 (calc-info) | 254 (calc-info) |
262 (Info-goto-node "Summary") | 255 (Info-goto-node "Summary")) |
263 ) | |
264 | 256 |
265 (defun calc-help () | 257 (defun calc-help () |
266 (interactive) | 258 (interactive) |
267 (let ((msgs (append | 259 (let ((msgs (append |
268 '("Press `h' for complete help; press `?' repeatedly for a summary" | 260 '("Press `h' for complete help; press `?' repeatedly for a summary" |
305 (make-string (- (apply 'max | 297 (make-string (- (apply 'max |
306 (mapcar 'length | 298 (mapcar 'length |
307 msgs)) | 299 msgs)) |
308 (length msg)) 32) | 300 (length msg)) 32) |
309 " [?=MORE]") | 301 " [?=MORE]") |
310 "")))))) | 302 ""))))))) |
311 ) | |
312 | 303 |
313 | 304 |
314 | 305 |
315 | 306 |
316 ;;;; Stack and buffer management. | 307 ;;;; Stack and buffer management. |
331 (if (eq calc-auto-why t) | 322 (if (eq calc-auto-why t) |
332 (cdr calc-why) | 323 (cdr calc-why) |
333 (if calc-auto-why | 324 (if calc-auto-why |
334 (eq (car (nth 1 calc-why)) '*)))) | 325 (eq (car (nth 1 calc-why)) '*)))) |
335 (setq calc-last-why-command this-command) | 326 (setq calc-last-why-command this-command) |
336 (calc-clear-command-flag 'clear-message))) | 327 (calc-clear-command-flag 'clear-message)))) |
337 ) | |
338 | 328 |
339 (defun calc-record-why (&rest stuff) | 329 (defun calc-record-why (&rest stuff) |
340 (if (eq (car stuff) 'quiet) | 330 (if (eq (car stuff) 'quiet) |
341 (setq stuff (cdr stuff)) | 331 (setq stuff (cdr stuff)) |
342 (if (and (symbolp (car stuff)) | 332 (if (and (symbolp (car stuff)) |
349 (if (and (stringp (car stuff)) | 339 (if (and (stringp (car stuff)) |
350 (string-match "\\`\\*" (car stuff))) | 340 (string-match "\\`\\*" (car stuff))) |
351 (setq stuff (cons '* (cons (substring (car stuff) 1) | 341 (setq stuff (cons '* (cons (substring (car stuff) 1) |
352 (cdr stuff))))))) | 342 (cdr stuff))))))) |
353 (setq calc-next-why (cons stuff calc-next-why)) | 343 (setq calc-next-why (cons stuff calc-next-why)) |
354 nil | 344 nil) |
355 ) | |
356 | 345 |
357 ;;; True if A is a constant or vector of constants. [P x] [Public] | 346 ;;; True if A is a constant or vector of constants. [P x] [Public] |
358 (defun math-constp (a) | 347 (defun math-constp (a) |
359 (or (Math-scalarp a) | 348 (or (Math-scalarp a) |
360 (and (memq (car a) '(sdev intv mod vec)) | 349 (and (memq (car a) '(sdev intv mod vec)) |
361 (progn | 350 (progn |
362 (while (and (setq a (cdr a)) | 351 (while (and (setq a (cdr a)) |
363 (or (Math-scalarp (car a)) ; optimization | 352 (or (Math-scalarp (car a)) ; optimization |
364 (math-constp (car a))))) | 353 (math-constp (car a))))) |
365 (null a)))) | 354 (null a))))) |
366 ) | |
367 | 355 |
368 | 356 |
369 (defun calc-roll-down-stack (n &optional m) | 357 (defun calc-roll-down-stack (n &optional m) |
370 (if (< n 0) | 358 (if (< n 0) |
371 (calc-roll-up-stack (- n) m) | 359 (calc-roll-up-stack (- n) m) |
376 (if (and calc-any-selections | 364 (if (and calc-any-selections |
377 (not calc-use-selections)) | 365 (not calc-use-selections)) |
378 (calc-roll-down-with-selections n m) | 366 (calc-roll-down-with-selections n m) |
379 (calc-pop-push-list n | 367 (calc-pop-push-list n |
380 (append (calc-top-list m 1) | 368 (append (calc-top-list m 1) |
381 (calc-top-list (- n m) (1+ m))))))) | 369 (calc-top-list (- n m) (1+ m)))))))) |
382 ) | |
383 | 370 |
384 (defun calc-roll-up-stack (n &optional m) | 371 (defun calc-roll-up-stack (n &optional m) |
385 (if (< n 0) | 372 (if (< n 0) |
386 (calc-roll-down-stack (- n) m) | 373 (calc-roll-down-stack (- n) m) |
387 (if (or (= n 0) (> n (calc-stack-size))) (setq n (calc-stack-size))) | 374 (if (or (= n 0) (> n (calc-stack-size))) (setq n (calc-stack-size))) |
391 (if (and calc-any-selections | 378 (if (and calc-any-selections |
392 (not calc-use-selections)) | 379 (not calc-use-selections)) |
393 (calc-roll-up-with-selections n m) | 380 (calc-roll-up-with-selections n m) |
394 (calc-pop-push-list n | 381 (calc-pop-push-list n |
395 (append (calc-top-list (- n m) 1) | 382 (append (calc-top-list (- n m) 1) |
396 (calc-top-list m (- n m -1))))))) | 383 (calc-top-list m (- n m -1)))))))) |
397 ) | |
398 | 384 |
399 | 385 |
400 (defun calc-do-refresh () | 386 (defun calc-do-refresh () |
401 (if calc-hyperbolic-flag | 387 (if calc-hyperbolic-flag |
402 (progn | 388 (progn |
403 (setq calc-display-dirty t) | 389 (setq calc-display-dirty t) |
404 nil) | 390 nil) |
405 (calc-refresh) | 391 (calc-refresh) |
406 t) | 392 t)) |
407 ) | |
408 | 393 |
409 | 394 |
410 (defun calc-record-list (vals &optional prefix) | 395 (defun calc-record-list (vals &optional prefix) |
411 (while vals | 396 (while vals |
412 (or (eq (car vals) 'top-of-stack) | 397 (or (eq (car vals) 'top-of-stack) |
413 (progn | 398 (progn |
414 (calc-record (car vals) prefix) | 399 (calc-record (car vals) prefix) |
415 (setq prefix "..."))) | 400 (setq prefix "..."))) |
416 (setq vals (cdr vals))) | 401 (setq vals (cdr vals)))) |
417 ) | |
418 | 402 |
419 | 403 |
420 (defun calc-last-args-stub (arg) | 404 (defun calc-last-args-stub (arg) |
421 (interactive "p") | 405 (interactive "p") |
422 (calc-extensions) | 406 (calc-extensions) |
423 (calc-last-args arg) | 407 (calc-last-args arg)) |
424 ) | |
425 | 408 |
426 | 409 |
427 (defun calc-power (arg) | 410 (defun calc-power (arg) |
428 (interactive "P") | 411 (interactive "P") |
429 (calc-slow-wrapper | 412 (calc-slow-wrapper |
430 (if (and calc-extensions-loaded | 413 (if (and calc-extensions-loaded |
431 (calc-is-inverse)) | 414 (calc-is-inverse)) |
432 (calc-binary-op "root" 'calcFunc-nroot arg nil nil) | 415 (calc-binary-op "root" 'calcFunc-nroot arg nil nil) |
433 (calc-binary-op "^" 'calcFunc-pow arg nil nil '^))) | 416 (calc-binary-op "^" 'calcFunc-pow arg nil nil '^)))) |
434 ) | |
435 | 417 |
436 (defun calc-mod (arg) | 418 (defun calc-mod (arg) |
437 (interactive "P") | 419 (interactive "P") |
438 (calc-slow-wrapper | 420 (calc-slow-wrapper |
439 (calc-binary-op "%" 'calcFunc-mod arg nil nil '%)) | 421 (calc-binary-op "%" 'calcFunc-mod arg nil nil '%))) |
440 ) | |
441 | 422 |
442 (defun calc-inv (arg) | 423 (defun calc-inv (arg) |
443 (interactive "P") | 424 (interactive "P") |
444 (calc-slow-wrapper | 425 (calc-slow-wrapper |
445 (calc-unary-op "inv" 'calcFunc-inv arg)) | 426 (calc-unary-op "inv" 'calcFunc-inv arg))) |
446 ) | |
447 | 427 |
448 (defun calc-percent () | 428 (defun calc-percent () |
449 (interactive) | 429 (interactive) |
450 (calc-slow-wrapper | 430 (calc-slow-wrapper |
451 (calc-pop-push-record-list | 431 (calc-pop-push-record-list |
452 1 "%" (list (list 'calcFunc-percent (calc-top-n 1))))) | 432 1 "%" (list (list 'calcFunc-percent (calc-top-n 1)))))) |
453 ) | |
454 | 433 |
455 | 434 |
456 (defun calc-over (n) | 435 (defun calc-over (n) |
457 (interactive "P") | 436 (interactive "P") |
458 (if n | 437 (if n |
459 (calc-enter (- (prefix-numeric-value n))) | 438 (calc-enter (- (prefix-numeric-value n))) |
460 (calc-enter -2)) | 439 (calc-enter -2))) |
461 ) | |
462 | 440 |
463 | 441 |
464 (defun calc-pop-above (n) | 442 (defun calc-pop-above (n) |
465 (interactive "P") | 443 (interactive "P") |
466 (if n | 444 (if n |
467 (calc-pop (- (prefix-numeric-value n))) | 445 (calc-pop (- (prefix-numeric-value n))) |
468 (calc-pop -2)) | 446 (calc-pop -2))) |
469 ) | |
470 | 447 |
471 (defun calc-roll-down (n) | 448 (defun calc-roll-down (n) |
472 (interactive "P") | 449 (interactive "P") |
473 (calc-wrapper | 450 (calc-wrapper |
474 (let ((nn (prefix-numeric-value n))) | 451 (let ((nn (prefix-numeric-value n))) |
479 ((= nn 0) | 456 ((= nn 0) |
480 (calc-pop-push-list (calc-stack-size) | 457 (calc-pop-push-list (calc-stack-size) |
481 (reverse | 458 (reverse |
482 (calc-top-list (calc-stack-size))))) | 459 (calc-top-list (calc-stack-size))))) |
483 (t | 460 (t |
484 (calc-roll-down-stack (calc-stack-size) (- nn)))))) | 461 (calc-roll-down-stack (calc-stack-size) (- nn))))))) |
485 ) | |
486 | 462 |
487 (defun calc-roll-up (n) | 463 (defun calc-roll-up (n) |
488 (interactive "P") | 464 (interactive "P") |
489 (calc-wrapper | 465 (calc-wrapper |
490 (let ((nn (prefix-numeric-value n))) | 466 (let ((nn (prefix-numeric-value n))) |
495 ((= nn 0) | 471 ((= nn 0) |
496 (calc-pop-push-list (calc-stack-size) | 472 (calc-pop-push-list (calc-stack-size) |
497 (reverse | 473 (reverse |
498 (calc-top-list (calc-stack-size))))) | 474 (calc-top-list (calc-stack-size))))) |
499 (t | 475 (t |
500 (calc-roll-up-stack (calc-stack-size) (- nn)))))) | 476 (calc-roll-up-stack (calc-stack-size) (- nn))))))) |
501 ) | |
502 | 477 |
503 | 478 |
504 | 479 |
505 | 480 |
506 ;;; Other commands. | 481 ;;; Other commands. |
508 (defun calc-num-prefix-name (n) | 483 (defun calc-num-prefix-name (n) |
509 (cond ((eq n '-) "- ") | 484 (cond ((eq n '-) "- ") |
510 ((equal n '(4)) "C-u ") | 485 ((equal n '(4)) "C-u ") |
511 ((consp n) (format "%d " (car n))) | 486 ((consp n) (format "%d " (car n))) |
512 ((integerp n) (format "%d " n)) | 487 ((integerp n) (format "%d " n)) |
513 (t "")) | 488 (t ""))) |
514 ) | |
515 | 489 |
516 (defun calc-missing-key (n) | 490 (defun calc-missing-key (n) |
517 "This is a placeholder for a command which needs to be loaded from calc-ext. | 491 "This is a placeholder for a command which needs to be loaded from calc-ext. |
518 When this key is used, calc-ext (the Calculator extensions module) will be | 492 When this key is used, calc-ext (the Calculator extensions module) will be |
519 loaded and the keystroke automatically re-typed." | 493 loaded and the keystroke automatically re-typed." |
520 (interactive "P") | 494 (interactive "P") |
521 (calc-extensions) | 495 (calc-extensions) |
522 (if (keymapp (key-binding (char-to-string last-command-char))) | 496 (if (keymapp (key-binding (char-to-string last-command-char))) |
523 (message "%s%c-" (calc-num-prefix-name n) last-command-char)) | 497 (message "%s%c-" (calc-num-prefix-name n) last-command-char)) |
524 (calc-unread-command) | 498 (calc-unread-command) |
525 (setq prefix-arg n) | 499 (setq prefix-arg n)) |
526 ) | |
527 | 500 |
528 (defun calc-shift-Y-prefix-help () | 501 (defun calc-shift-Y-prefix-help () |
529 (interactive) | 502 (interactive) |
530 (calc-extensions) | 503 (calc-extensions) |
531 (calc-do-prefix-help calc-Y-help-msgs "other" ?Y) | 504 (calc-do-prefix-help calc-Y-help-msgs "other" ?Y)) |
532 ) | |
533 | 505 |
534 | 506 |
535 | 507 |
536 | 508 |
537 (defun calcDigit-letter () | 509 (defun calcDigit-letter () |
538 (interactive) | 510 (interactive) |
539 (if (calc-minibuffer-contains "[-+]?\\(1[1-9]\\|[2-9][0-9]\\)#.*") | 511 (if (calc-minibuffer-contains "[-+]?\\(1[1-9]\\|[2-9][0-9]\\)#.*") |
540 (progn | 512 (progn |
541 (setq last-command-char (upcase last-command-char)) | 513 (setq last-command-char (upcase last-command-char)) |
542 (calcDigit-key)) | 514 (calcDigit-key)) |
543 (calcDigit-nondigit)) | 515 (calcDigit-nondigit))) |
544 ) | |
545 | 516 |
546 | 517 |
547 ;; A Lisp version of temp_minibuffer_message from minibuf.c. | 518 ;; A Lisp version of temp_minibuffer_message from minibuf.c. |
548 (defun calc-temp-minibuffer-message (m) | 519 (defun calc-temp-minibuffer-message (m) |
549 (let ((savemax (point-max))) | 520 (let ((savemax (point-max))) |
556 (sit-for 2) | 527 (sit-for 2) |
557 (identity 1) ; this forces a call to QUIT; in bytecode.c. | 528 (identity 1) ; this forces a call to QUIT; in bytecode.c. |
558 (setq okay t)) | 529 (setq okay t)) |
559 (progn | 530 (progn |
560 (delete-region savemax (point-max)) | 531 (delete-region savemax (point-max)) |
561 (or okay (abort-recursive-edit)))))) | 532 (or okay (abort-recursive-edit))))))) |
562 ) | |
563 | 533 |
564 | 534 |
565 (put 'math-with-extra-prec 'lisp-indent-hook 1) | 535 (put 'math-with-extra-prec 'lisp-indent-hook 1) |
566 | 536 |
567 | 537 |
580 (if (and (math-vectorp v2) | 550 (if (and (math-vectorp v2) |
581 (or (math-matrixp v2) | 551 (or (math-matrixp v2) |
582 (not (math-matrixp v1)))) | 552 (not (math-matrixp v1)))) |
583 (cdr v2) | 553 (cdr v2) |
584 (list v2))) | 554 (list v2))) |
585 (list '| v1 v2))) | 555 (list '| v1 v2)))) |
586 ) | |
587 | 556 |
588 | 557 |
589 ;;; True if A is zero. Works for un-normalized values. [P n] [Public] | 558 ;;; True if A is zero. Works for un-normalized values. [P n] [Public] |
590 (defun math-zerop (a) | 559 (defun math-zerop (a) |
591 (if (consp a) | 560 (if (consp a) |
598 (and (math-zerop (nth 1 a)) (math-zerop (nth 2 a)))) | 567 (and (math-zerop (nth 1 a)) (math-zerop (nth 2 a)))) |
599 ((eq (car a) 'hms) | 568 ((eq (car a) 'hms) |
600 (and (math-zerop (nth 1 a)) | 569 (and (math-zerop (nth 1 a)) |
601 (math-zerop (nth 2 a)) | 570 (math-zerop (nth 2 a)) |
602 (math-zerop (nth 3 a))))) | 571 (math-zerop (nth 3 a))))) |
603 (eq a 0)) | 572 (eq a 0))) |
604 ) | |
605 | 573 |
606 | 574 |
607 ;;; True if A is real and negative. [P n] [Public] | 575 ;;; True if A is real and negative. [P n] [Public] |
608 | 576 |
609 (defun math-negp (a) | 577 (defun math-negp (a) |
623 ((eq (car a) 'intv) | 591 ((eq (car a) 'intv) |
624 (or (math-negp (nth 3 a)) | 592 (or (math-negp (nth 3 a)) |
625 (and (math-zerop (nth 3 a)) | 593 (and (math-zerop (nth 3 a)) |
626 (memq (nth 1 a) '(0 2))))) | 594 (memq (nth 1 a) '(0 2))))) |
627 ((equal a '(neg (var inf var-inf))) t)) | 595 ((equal a '(neg (var inf var-inf))) t)) |
628 (< a 0)) | 596 (< a 0))) |
629 ) | |
630 | 597 |
631 ;;; True if A is a negative number or an expression the starts with '-'. | 598 ;;; True if A is a negative number or an expression the starts with '-'. |
632 (defun math-looks-negp (a) ; [P x] [Public] | 599 (defun math-looks-negp (a) ; [P x] [Public] |
633 (or (Math-negp a) | 600 (or (Math-negp a) |
634 (eq (car-safe a) 'neg) | 601 (eq (car-safe a) 'neg) |
635 (and (memq (car-safe a) '(* /)) | 602 (and (memq (car-safe a) '(* /)) |
636 (or (math-looks-negp (nth 1 a)) | 603 (or (math-looks-negp (nth 1 a)) |
637 (math-looks-negp (nth 2 a)))) | 604 (math-looks-negp (nth 2 a)))) |
638 (and (eq (car-safe a) '-) | 605 (and (eq (car-safe a) '-) |
639 (math-looks-negp (nth 1 a)))) | 606 (math-looks-negp (nth 1 a))))) |
640 ) | |
641 | 607 |
642 | 608 |
643 ;;; True if A is real and positive. [P n] [Public] | 609 ;;; True if A is real and positive. [P n] [Public] |
644 (defun math-posp (a) | 610 (defun math-posp (a) |
645 (if (consp a) | 611 (if (consp a) |
660 ((eq (car a) 'intv) | 626 ((eq (car a) 'intv) |
661 (or (math-posp (nth 2 a)) | 627 (or (math-posp (nth 2 a)) |
662 (and (math-zerop (nth 2 a)) | 628 (and (math-zerop (nth 2 a)) |
663 (memq (nth 1 a) '(0 1))))) | 629 (memq (nth 1 a) '(0 1))))) |
664 ((equal a '(var inf var-inf)) t)) | 630 ((equal a '(var inf var-inf)) t)) |
665 (> a 0)) | 631 (> a 0))) |
666 ) | 632 |
667 | 633 (defalias math-fixnump 'integerp) |
668 (fset 'math-fixnump (symbol-function 'integerp)) | 634 (defalias math-fixnatnump 'natnump) |
669 (fset 'math-fixnatnump (symbol-function 'natnump)) | |
670 | 635 |
671 | 636 |
672 ;;; True if A is an even integer. [P R R] [Public] | 637 ;;; True if A is an even integer. [P R R] [Public] |
673 (defun math-evenp (a) | 638 (defun math-evenp (a) |
674 (if (consp a) | 639 (if (consp a) |
675 (and (memq (car a) '(bigpos bigneg)) | 640 (and (memq (car a) '(bigpos bigneg)) |
676 (= (% (nth 1 a) 2) 0)) | 641 (= (% (nth 1 a) 2) 0)) |
677 (= (% a 2) 0)) | 642 (= (% a 2) 0))) |
678 ) | |
679 | 643 |
680 ;;; Compute A / 2, for small or big integer A. [I i] | 644 ;;; Compute A / 2, for small or big integer A. [I i] |
681 ;;; If A is negative, type of truncation is undefined. | 645 ;;; If A is negative, type of truncation is undefined. |
682 (defun math-div2 (a) | 646 (defun math-div2 (a) |
683 (if (consp a) | 647 (if (consp a) |
684 (if (cdr a) | 648 (if (cdr a) |
685 (math-normalize (cons (car a) (math-div2-bignum (cdr a)))) | 649 (math-normalize (cons (car a) (math-div2-bignum (cdr a)))) |
686 0) | 650 0) |
687 (/ a 2)) | 651 (/ a 2))) |
688 ) | |
689 | 652 |
690 (defun math-div2-bignum (a) ; [l l] | 653 (defun math-div2-bignum (a) ; [l l] |
691 (if (cdr a) | 654 (if (cdr a) |
692 (cons (+ (/ (car a) 2) (* (% (nth 1 a) 2) 500)) | 655 (cons (+ (/ (car a) 2) (* (% (nth 1 a) 2) 500)) |
693 (math-div2-bignum (cdr a))) | 656 (math-div2-bignum (cdr a))) |
694 (list (/ (car a) 2))) | 657 (list (/ (car a) 2)))) |
695 ) | |
696 | 658 |
697 | 659 |
698 ;;; Reject an argument to a calculator function. [Public] | 660 ;;; Reject an argument to a calculator function. [Public] |
699 (defun math-reject-arg (&optional a p option) | 661 (defun math-reject-arg (&optional a p option) |
700 (if option | 662 (if option |
701 (calc-record-why option p a) | 663 (calc-record-why option p a) |
702 (if p | 664 (if p |
703 (calc-record-why p a))) | 665 (calc-record-why p a))) |
704 (signal 'wrong-type-argument (and a (if p (list p a) (list a)))) | 666 (signal 'wrong-type-argument (and a (if p (list p a) (list a))))) |
705 ) | |
706 | 667 |
707 | 668 |
708 ;;; Coerce A to be an integer (by truncation toward zero). [I N] [Public] | 669 ;;; Coerce A to be an integer (by truncation toward zero). [I N] [Public] |
709 (defun math-trunc (a &optional prec) | 670 (defun math-trunc (a &optional prec) |
710 (cond (prec | 671 (cond (prec |
714 ((Math-looks-negp a) | 675 ((Math-looks-negp a) |
715 (math-neg (math-trunc (math-neg a)))) | 676 (math-neg (math-trunc (math-neg a)))) |
716 ((eq (car a) 'float) | 677 ((eq (car a) 'float) |
717 (math-scale-int (nth 1 a) (nth 2 a))) | 678 (math-scale-int (nth 1 a) (nth 2 a))) |
718 (t (calc-extensions) | 679 (t (calc-extensions) |
719 (math-trunc-fancy a))) | 680 (math-trunc-fancy a)))) |
720 ) | 681 (defalias calcFunc-trunc 'math-trunc) |
721 (fset 'calcFunc-trunc (symbol-function 'math-trunc)) | |
722 | 682 |
723 ;;; Coerce A to be an integer (by truncation toward minus infinity). [I N] | 683 ;;; Coerce A to be an integer (by truncation toward minus infinity). [I N] |
724 (defun math-floor (a &optional prec) ; [Public] | 684 (defun math-floor (a &optional prec) ; [Public] |
725 (cond (prec | 685 (cond (prec |
726 (calc-extensions) | 686 (calc-extensions) |
730 ((Math-realp a) | 690 ((Math-realp a) |
731 (if (Math-negp a) | 691 (if (Math-negp a) |
732 (math-add (math-trunc a) -1) | 692 (math-add (math-trunc a) -1) |
733 (math-trunc a))) | 693 (math-trunc a))) |
734 (t (calc-extensions) | 694 (t (calc-extensions) |
735 (math-floor-fancy a))) | 695 (math-floor-fancy a)))) |
736 ) | 696 (defalias calcFunc-floor 'math-floor) |
737 (fset 'calcFunc-floor (symbol-function 'math-floor)) | |
738 | 697 |
739 | 698 |
740 (defun math-imod (a b) ; [I I I] [Public] | 699 (defun math-imod (a b) ; [I I I] [Public] |
741 (if (and (not (consp a)) (not (consp b))) | 700 (if (and (not (consp a)) (not (consp b))) |
742 (if (= b 0) | 701 (if (= b 0) |
743 (math-reject-arg a "*Division by zero") | 702 (math-reject-arg a "*Division by zero") |
744 (% a b)) | 703 (% a b)) |
745 (cdr (math-idivmod a b))) | 704 (cdr (math-idivmod a b)))) |
746 ) | |
747 | 705 |
748 | 706 |
749 (defun calcFunc-inv (m) | 707 (defun calcFunc-inv (m) |
750 (if (Math-vectorp m) | 708 (if (Math-vectorp m) |
751 (progn | 709 (progn |
752 (calc-extensions) | 710 (calc-extensions) |
753 (if (math-square-matrixp m) | 711 (if (math-square-matrixp m) |
754 (or (math-with-extra-prec 2 (math-matrix-inv-raw m)) | 712 (or (math-with-extra-prec 2 (math-matrix-inv-raw m)) |
755 (math-reject-arg m "*Singular matrix")) | 713 (math-reject-arg m "*Singular matrix")) |
756 (math-reject-arg m 'square-matrixp))) | 714 (math-reject-arg m 'square-matrixp))) |
757 (math-div 1 m)) | 715 (math-div 1 m))) |
758 ) | |
759 | 716 |
760 | 717 |
761 (defun math-do-working (msg arg) | 718 (defun math-do-working (msg arg) |
762 (or executing-kbd-macro | 719 (or executing-kbd-macro |
763 (progn | 720 (progn |
766 (if math-working-step-2 | 723 (if math-working-step-2 |
767 (setq msg (format "[%d/%d] %s" | 724 (setq msg (format "[%d/%d] %s" |
768 math-working-step math-working-step-2 msg)) | 725 math-working-step math-working-step-2 msg)) |
769 (setq msg (format "[%d] %s" math-working-step msg)))) | 726 (setq msg (format "[%d] %s" math-working-step msg)))) |
770 (message "Working... %s = %s" msg | 727 (message "Working... %s = %s" msg |
771 (math-showing-full-precision (math-format-number arg))))) | 728 (math-showing-full-precision (math-format-number arg)))))) |
772 ) | |
773 | 729 |
774 | 730 |
775 ;;; Compute A modulo B, defined in terms of truncation toward minus infinity. | 731 ;;; Compute A modulo B, defined in terms of truncation toward minus infinity. |
776 (defun math-mod (a b) ; [R R R] [Public] | 732 (defun math-mod (a b) ; [R R R] [Public] |
777 (cond ((and (Math-zerop a) (not (eq (car-safe a) 'mod))) a) | 733 (cond ((and (Math-zerop a) (not (eq (car-safe a) 'mod))) a) |
780 ((and (Math-natnump a) (Math-natnump b)) | 736 ((and (Math-natnump a) (Math-natnump b)) |
781 (math-imod a b)) | 737 (math-imod a b)) |
782 ((and (Math-anglep a) (Math-anglep b)) | 738 ((and (Math-anglep a) (Math-anglep b)) |
783 (math-sub a (math-mul (math-floor (math-div a b)) b))) | 739 (math-sub a (math-mul (math-floor (math-div a b)) b))) |
784 (t (calc-extensions) | 740 (t (calc-extensions) |
785 (math-mod-fancy a b))) | 741 (math-mod-fancy a b)))) |
786 ) | |
787 | 742 |
788 | 743 |
789 | 744 |
790 ;;; General exponentiation. | 745 ;;; General exponentiation. |
791 | 746 |
810 (math-make-float 1 b) | 765 (math-make-float 1 b) |
811 (math-with-extra-prec 2 | 766 (math-with-extra-prec 2 |
812 (math-ipow a b)))) | 767 (math-ipow a b)))) |
813 (t | 768 (t |
814 (calc-extensions) | 769 (calc-extensions) |
815 (math-pow-fancy a b))) | 770 (math-pow-fancy a b)))) |
816 ) | |
817 | 771 |
818 (defun math-ipow (a n) ; [O O I] [Public] | 772 (defun math-ipow (a n) ; [O O I] [Public] |
819 (cond ((Math-integer-negp n) | 773 (cond ((Math-integer-negp n) |
820 (math-ipow (math-div 1 a) (Math-integer-neg n))) | 774 (math-ipow (math-div 1 a) (Math-integer-neg n))) |
821 ((not (consp n)) | 775 ((not (consp n)) |
824 (math-iipow a n))) | 778 (math-iipow a n))) |
825 ((math-evenp n) | 779 ((math-evenp n) |
826 (math-ipow (math-mul a a) (math-div2 n))) | 780 (math-ipow (math-mul a a) (math-div2 n))) |
827 (t | 781 (t |
828 (math-mul a (math-ipow (math-mul a a) | 782 (math-mul a (math-ipow (math-mul a a) |
829 (math-div2 (math-add n -1)))))) | 783 (math-div2 (math-add n -1))))))) |
830 ) | |
831 | 784 |
832 (defun math-iipow (a n) ; [O O S] | 785 (defun math-iipow (a n) ; [O O S] |
833 (cond ((= n 0) 1) | 786 (cond ((= n 0) 1) |
834 ((= n 1) a) | 787 ((= n 1) a) |
835 ((= (% n 2) 0) (math-iipow (math-mul a a) (/ n 2))) | 788 ((= (% n 2) 0) (math-iipow (math-mul a a) (/ n 2))) |
836 (t (math-mul a (math-iipow (math-mul a a) (/ n 2))))) | 789 (t (math-mul a (math-iipow (math-mul a a) (/ n 2)))))) |
837 ) | |
838 | 790 |
839 (defun math-iipow-show (a n) ; [O O S] | 791 (defun math-iipow-show (a n) ; [O O S] |
840 (math-working "pow" a) | 792 (math-working "pow" a) |
841 (let ((val (cond | 793 (let ((val (cond |
842 ((= n 0) 1) | 794 ((= n 0) 1) |
843 ((= n 1) a) | 795 ((= n 1) a) |
844 ((= (% n 2) 0) (math-iipow-show (math-mul a a) (/ n 2))) | 796 ((= (% n 2) 0) (math-iipow-show (math-mul a a) (/ n 2))) |
845 (t (math-mul a (math-iipow-show (math-mul a a) (/ n 2))))))) | 797 (t (math-mul a (math-iipow-show (math-mul a a) (/ n 2))))))) |
846 (math-working "pow" val) | 798 (math-working "pow" val) |
847 val) | 799 val)) |
848 ) | |
849 | 800 |
850 | 801 |
851 (defun math-read-radix-digit (dig) ; [D S; Z S] | 802 (defun math-read-radix-digit (dig) ; [D S; Z S] |
852 (if (> dig ?9) | 803 (if (> dig ?9) |
853 (if (< dig ?A) | 804 (if (< dig ?A) |
854 nil | 805 nil |
855 (- dig 55)) | 806 (- dig 55)) |
856 (if (>= dig ?0) | 807 (if (>= dig ?0) |
857 (- dig ?0) | 808 (- dig ?0) |
858 nil)) | 809 nil))) |
859 ) | |
860 | 810 |
861 | 811 |
862 | 812 |
863 | 813 |
864 | 814 |
869 Prompts for bug subject. Leaves you in a mail buffer." | 819 Prompts for bug subject. Leaves you in a mail buffer." |
870 (interactive "sBug Subject: ") | 820 (interactive "sBug Subject: ") |
871 (mail nil calc-bug-address topic) | 821 (mail nil calc-bug-address topic) |
872 (goto-char (point-max)) | 822 (goto-char (point-max)) |
873 (insert "\nIn Calc " calc-version ", Emacs " (emacs-version) "\n\n") | 823 (insert "\nIn Calc " calc-version ", Emacs " (emacs-version) "\n\n") |
874 (message (substitute-command-keys "Type \\[mail-send] to send bug report.")) | 824 (message (substitute-command-keys "Type \\[mail-send] to send bug report."))) |
875 ) | 825 (defalias calc-report-bug 'report-calc-bug) |
876 (fset 'calc-report-bug (symbol-function 'report-calc-bug)) | 826 |
877 | 827 ;;; calc-misc.el ends here |