1 |
;; Calculator for GNU Emacs, part II |
;; Calculator for GNU Emacs, part II |
2 |
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. |
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
3 |
;; Written by Dave Gillespie, daveg@synaptics.com. |
;; Written by Dave Gillespie, daveg@synaptics.com. |
4 |
|
|
5 |
;; This file is part of GNU Emacs. |
;; This file is part of GNU Emacs. |
30 |
;;;###autoload |
;;;###autoload |
31 |
(defun calc-extensions () |
(defun calc-extensions () |
32 |
"This function is part of the autoload linkage for parts of Calc." |
"This function is part of the autoload linkage for parts of Calc." |
33 |
t |
t) |
|
) |
|
34 |
|
|
35 |
;;; Auto-load calc.el part, in case this part was loaded first. |
;;; Auto-load calc.el part, in case this part was loaded first. |
36 |
(if (fboundp 'calc-dispatch) |
(if (fboundp 'calc-dispatch) |
1132 |
calc-kill calc-kill-region calc-yank) |
calc-kill calc-kill-region calc-yank) |
1133 |
|
|
1134 |
)) |
)) |
|
|
|
1135 |
) |
) |
1136 |
|
|
1137 |
(defun calc-init-prefixes () |
(defun calc-init-prefixes () |
1160 |
(define-key calc-mode-map "M" 'calc-more-recursion-depth) |
(define-key calc-mode-map "M" 'calc-more-recursion-depth) |
1161 |
(define-key calc-mode-map "S" 'calc-sin) |
(define-key calc-mode-map "S" 'calc-sin) |
1162 |
(define-key calc-mode-map "T" 'calc-tan) |
(define-key calc-mode-map "T" 'calc-tan) |
1163 |
(define-key calc-mode-map "U" 'calc-undo)) |
(define-key calc-mode-map "U" 'calc-undo))) |
|
) |
|
1164 |
|
|
1165 |
(calc-init-extensions) |
(calc-init-extensions) |
1166 |
|
|
1170 |
;;;; Miscellaneous. |
;;;; Miscellaneous. |
1171 |
|
|
1172 |
(defun calc-clear-command-flag (f) |
(defun calc-clear-command-flag (f) |
1173 |
(setq calc-command-flags (delq f calc-command-flags)) |
(setq calc-command-flags (delq f calc-command-flags))) |
|
) |
|
1174 |
|
|
1175 |
|
|
1176 |
(defun calc-record-message (tag &rest args) |
(defun calc-record-message (tag &rest args) |
1177 |
(let ((msg (apply 'format args))) |
(let ((msg (apply 'format args))) |
1178 |
(message "%s" msg) |
(message "%s" msg) |
1179 |
(calc-record msg tag)) |
(calc-record msg tag)) |
1180 |
(calc-clear-command-flag 'clear-message) |
(calc-clear-command-flag 'clear-message)) |
|
) |
|
1181 |
|
|
1182 |
|
|
1183 |
(defun calc-normalize-fancy (val) |
(defun calc-normalize-fancy (val) |
1196 |
((eq simp 'units) |
((eq simp 'units) |
1197 |
(math-simplify-units val)) |
(math-simplify-units val)) |
1198 |
(t ; nil, none, num |
(t ; nil, none, num |
1199 |
(math-normalize val)))) |
(math-normalize val))))) |
|
) |
|
1200 |
|
|
1201 |
|
|
1202 |
|
|
1218 |
(define-key calc-help-map "\C-n" 'calc-view-news) |
(define-key calc-help-map "\C-n" 'calc-view-news) |
1219 |
(define-key calc-help-map "\C-w" 'calc-describe-no-warranty) |
(define-key calc-help-map "\C-w" 'calc-describe-no-warranty) |
1220 |
(define-key calc-help-map "?" 'calc-help-for-help) |
(define-key calc-help-map "?" 'calc-help-for-help) |
1221 |
(define-key calc-help-map "\C-h" 'calc-help-for-help) |
(define-key calc-help-map "\C-h" 'calc-help-for-help)) |
|
) |
|
1222 |
|
|
1223 |
|
|
1224 |
(defun calc-do-prefix-help (msgs group key) |
(defun calc-do-prefix-help (msgs group key) |
1248 |
(message "%s: %s: %c-" group (car msgs) key) |
(message "%s: %s: %c-" group (car msgs) key) |
1249 |
(message "%s: (none) %c-" group (car msgs) key)) |
(message "%s: (none) %c-" group (car msgs) key)) |
1250 |
(message "%s: %s" group (car msgs)))) |
(message "%s: %s" group (car msgs)))) |
1251 |
(and key (calc-unread-command key))) |
(and key (calc-unread-command key)))) |
|
) |
|
1252 |
(defvar calc-prefix-help-phase 0) |
(defvar calc-prefix-help-phase 0) |
1253 |
|
|
1254 |
|
|
1291 |
(select-window win) |
(select-window win) |
1292 |
(enlarge-window (- calc-window-height height)) |
(enlarge-window (- calc-window-height height)) |
1293 |
(select-window swin))))))) |
(select-window swin))))))) |
1294 |
(message "(Calculator reset)") |
(message "(Calculator reset)")) |
|
) |
|
1295 |
|
|
1296 |
|
|
1297 |
(defun calc-scroll-left (n) |
(defun calc-scroll-left (n) |
1298 |
(interactive "P") |
(interactive "P") |
1299 |
(scroll-left (or n (/ (window-width) 2))) |
(scroll-left (or n (/ (window-width) 2)))) |
|
) |
|
1300 |
|
|
1301 |
(defun calc-scroll-right (n) |
(defun calc-scroll-right (n) |
1302 |
(interactive "P") |
(interactive "P") |
1303 |
(scroll-right (or n (/ (window-width) 2))) |
(scroll-right (or n (/ (window-width) 2)))) |
|
) |
|
1304 |
|
|
1305 |
(defun calc-scroll-up (n) |
(defun calc-scroll-up (n) |
1306 |
(interactive "P") |
(interactive "P") |
1315 |
(save-excursion |
(save-excursion |
1316 |
(forward-line (- (1- (window-height)))) |
(forward-line (- (1- (window-height)))) |
1317 |
(point))) |
(point))) |
1318 |
(forward-line -1))) |
(forward-line -1)))) |
|
) |
|
1319 |
|
|
1320 |
(defun calc-scroll-down (n) |
(defun calc-scroll-down (n) |
1321 |
(interactive "P") |
(interactive "P") |
1322 |
(or (pos-visible-in-window-p 1) |
(or (pos-visible-in-window-p 1) |
1323 |
(scroll-down (or n (/ (window-height) 2)))) |
(scroll-down (or n (/ (window-height) 2))))) |
|
) |
|
1324 |
|
|
1325 |
|
|
1326 |
(defun calc-precision (n) |
(defun calc-precision (n) |
1333 |
(< (nth 1 calc-float-format) |
(< (nth 1 calc-float-format) |
1334 |
(if (= calc-number-radix 10) 0 1)))) |
(if (= calc-number-radix 10) 0 1)))) |
1335 |
(calc-record calc-internal-prec "prec")) |
(calc-record calc-internal-prec "prec")) |
1336 |
(message "Floating-point precision is %d digits." calc-internal-prec)) |
(message "Floating-point precision is %d digits." calc-internal-prec))) |
|
) |
|
1337 |
|
|
1338 |
|
|
1339 |
(defun calc-inverse (&optional n) |
(defun calc-inverse (&optional n) |
1340 |
(interactive "P") |
(interactive "P") |
1341 |
(calc-fancy-prefix 'calc-inverse-flag "Inverse..." n) |
(calc-fancy-prefix 'calc-inverse-flag "Inverse..." n)) |
|
) |
|
1342 |
|
|
1343 |
(defconst calc-fancy-prefix-map |
(defconst calc-fancy-prefix-map |
1344 |
(let ((map (make-sparse-keymap))) |
(let ((map (make-sparse-keymap))) |
1400 |
(calc-select-buffer) |
(calc-select-buffer) |
1401 |
(setq calc-inverse-flag (not (calc-is-inverse)) |
(setq calc-inverse-flag (not (calc-is-inverse)) |
1402 |
calc-hyperbolic-flag (calc-is-hyperbolic) |
calc-hyperbolic-flag (calc-is-hyperbolic) |
1403 |
current-prefix-arg nil)) |
current-prefix-arg nil))) |
|
) |
|
1404 |
|
|
1405 |
(defun calc-is-inverse () |
(defun calc-is-inverse () |
1406 |
calc-inverse-flag |
calc-inverse-flag) |
|
) |
|
1407 |
|
|
1408 |
(defun calc-hyperbolic (&optional n) |
(defun calc-hyperbolic (&optional n) |
1409 |
(interactive "P") |
(interactive "P") |
1410 |
(calc-fancy-prefix 'calc-hyperbolic-flag "Hyperbolic..." n) |
(calc-fancy-prefix 'calc-hyperbolic-flag "Hyperbolic..." n)) |
|
) |
|
1411 |
|
|
1412 |
(defun calc-hyperbolic-func () |
(defun calc-hyperbolic-func () |
1413 |
(save-excursion |
(save-excursion |
1414 |
(calc-select-buffer) |
(calc-select-buffer) |
1415 |
(setq calc-inverse-flag (calc-is-inverse) |
(setq calc-inverse-flag (calc-is-inverse) |
1416 |
calc-hyperbolic-flag (not (calc-is-hyperbolic)) |
calc-hyperbolic-flag (not (calc-is-hyperbolic)) |
1417 |
current-prefix-arg nil)) |
current-prefix-arg nil))) |
|
) |
|
1418 |
|
|
1419 |
(defun calc-is-hyperbolic () |
(defun calc-is-hyperbolic () |
1420 |
calc-hyperbolic-flag |
calc-hyperbolic-flag) |
|
) |
|
1421 |
|
|
1422 |
(defun calc-keep-args (&optional n) |
(defun calc-keep-args (&optional n) |
1423 |
(interactive "P") |
(interactive "P") |
1424 |
(calc-fancy-prefix 'calc-keep-args-flag "Keep args..." n) |
(calc-fancy-prefix 'calc-keep-args-flag "Keep args..." n)) |
|
) |
|
1425 |
|
|
1426 |
|
|
1427 |
(defun calc-change-mode (var value &optional refresh option) |
(defun calc-change-mode (var value &optional refresh option) |
1475 |
(not (equal var '(calc-mode-save-mode))) |
(not (equal var '(calc-mode-save-mode))) |
1476 |
(calc-save-modes t)))) |
(calc-save-modes t)))) |
1477 |
(if calc-embedded-info (calc-embedded-modes-change var)) |
(if calc-embedded-info (calc-embedded-modes-change var)) |
1478 |
(symbol-value (car var)))) |
(symbol-value (car var))))) |
|
) |
|
1479 |
|
|
1480 |
(defun calc-refresh-top (n) |
(defun calc-refresh-top (n) |
1481 |
(interactive "p") |
(interactive "p") |
1495 |
(calc-push-list (mapcar 'car entries) |
(calc-push-list (mapcar 'car entries) |
1496 |
1 |
1 |
1497 |
(mapcar (function (lambda (x) (nth 2 x))) |
(mapcar (function (lambda (x) (nth 2 x))) |
1498 |
entries)))))) |
entries))))))) |
|
) |
|
1499 |
|
|
1500 |
(defun calc-refresh-evaltos (&optional which-var) |
(defun calc-refresh-evaltos (&optional which-var) |
1501 |
(and calc-any-evaltos calc-auto-recompute (not calc-no-refresh-evaltos) |
(and calc-any-evaltos calc-auto-recompute (not calc-no-refresh-evaltos) |
1518 |
(calc-pop-stack 1 (1+ num) t))))) |
(calc-pop-stack 1 (1+ num) t))))) |
1519 |
(setq num (1- num))))) |
(setq num (1- num))))) |
1520 |
(and calc-embedded-active which-var |
(and calc-embedded-active which-var |
1521 |
(calc-embedded-var-change which-var)) |
(calc-embedded-var-change which-var))) |
|
) |
|
1522 |
(setq calc-refreshing-evaltos nil) |
(setq calc-refreshing-evaltos nil) |
1523 |
(setq calc-no-refresh-evaltos nil) |
(setq calc-no-refresh-evaltos nil) |
1524 |
|
|
1525 |
|
|
1526 |
(defun calc-push (&rest vals) |
(defun calc-push (&rest vals) |
1527 |
(calc-push-list vals) |
(calc-push-list vals)) |
|
) |
|
1528 |
|
|
1529 |
(defun calc-pop-push (n &rest vals) |
(defun calc-pop-push (n &rest vals) |
1530 |
(calc-pop-push-list n vals) |
(calc-pop-push-list n vals)) |
|
) |
|
1531 |
|
|
1532 |
(defun calc-pop-push-record (n prefix &rest vals) |
(defun calc-pop-push-record (n prefix &rest vals) |
1533 |
(calc-pop-push-record-list n prefix vals) |
(calc-pop-push-record-list n prefix vals)) |
|
) |
|
1534 |
|
|
1535 |
|
|
1536 |
(defun calc-evaluate (n) |
(defun calc-evaluate (n) |
1545 |
(- n)) |
(- n)) |
1546 |
(calc-pop-push-record-list n "eval" (mapcar 'math-evaluate-expr |
(calc-pop-push-record-list n "eval" (mapcar 'math-evaluate-expr |
1547 |
(calc-top-list n))))) |
(calc-top-list n))))) |
1548 |
(calc-handle-whys)) |
(calc-handle-whys))) |
|
) |
|
1549 |
|
|
1550 |
|
|
1551 |
(defun calc-eval-num (n) |
(defun calc-eval-num (n) |
1559 |
(calc-symbolic-mode nil)) |
(calc-symbolic-mode nil)) |
1560 |
(calc-with-default-simplification |
(calc-with-default-simplification |
1561 |
(calc-pop-push-record 1 "num" (math-evaluate-expr (calc-top 1))))) |
(calc-pop-push-record 1 "num" (math-evaluate-expr (calc-top 1))))) |
1562 |
(calc-handle-whys)) |
(calc-handle-whys))) |
|
) |
|
1563 |
|
|
1564 |
|
|
1565 |
(defun calc-execute-extended-command (n) |
(defun calc-execute-extended-command (n) |
1567 |
(let* ((prompt (concat (calc-num-prefix-name n) "M-x ")) |
(let* ((prompt (concat (calc-num-prefix-name n) "M-x ")) |
1568 |
(cmd (intern (completing-read prompt obarray 'commandp t "calc-")))) |
(cmd (intern (completing-read prompt obarray 'commandp t "calc-")))) |
1569 |
(setq prefix-arg n) |
(setq prefix-arg n) |
1570 |
(command-execute cmd)) |
(command-execute cmd))) |
|
) |
|
1571 |
|
|
1572 |
|
|
1573 |
(defun calc-realign (&optional num) |
(defun calc-realign (&optional num) |
1587 |
(forward-line 1))) |
(forward-line 1))) |
1588 |
(calc-wrapper |
(calc-wrapper |
1589 |
(if (get-buffer-window (current-buffer)) |
(if (get-buffer-window (current-buffer)) |
1590 |
(set-window-hscroll (get-buffer-window (current-buffer)) 0))))) |
(set-window-hscroll (get-buffer-window (current-buffer)) 0)))))) |
|
) |
|
1591 |
|
|
1592 |
|
|
1593 |
|
|
1607 |
(if (eq (car-safe val) 'error) |
(if (eq (car-safe val) 'error) |
1608 |
(error "Bad format in variable contents: %s" (nth 2 val)) |
(error "Bad format in variable contents: %s" (nth 2 val)) |
1609 |
(set v val))) |
(set v val))) |
1610 |
(symbol-value v)))) |
(symbol-value v))))) |
|
) |
|
1611 |
|
|
1612 |
|
|
1613 |
|
|
1651 |
(calc-slow-wrapper |
(calc-slow-wrapper |
1652 |
(calc-unary-op "flt" |
(calc-unary-op "flt" |
1653 |
(if (calc-is-hyperbolic) 'calcFunc-float 'calcFunc-pfloat) |
(if (calc-is-hyperbolic) 'calcFunc-float 'calcFunc-pfloat) |
1654 |
arg)) |
arg))) |
|
) |
|
1655 |
|
|
1656 |
|
|
1657 |
(defvar calc-gnuplot-process nil) |
(defvar calc-gnuplot-process nil) |
1663 |
(buffer-name calc-gnuplot-buffer) |
(buffer-name calc-gnuplot-buffer) |
1664 |
calc-gnuplot-input |
calc-gnuplot-input |
1665 |
(buffer-name calc-gnuplot-input) |
(buffer-name calc-gnuplot-input) |
1666 |
(memq (process-status calc-gnuplot-process) '(run stop))) |
(memq (process-status calc-gnuplot-process) '(run stop)))) |
|
) |
|
1667 |
|
|
1668 |
|
|
1669 |
|
|
1713 |
(calc-Need-calc-vec) |
(calc-Need-calc-vec) |
1714 |
(calc-Need-calc-yank) |
(calc-Need-calc-yank) |
1715 |
|
|
1716 |
(message "All parts of Calc are now loaded.") |
(message "All parts of Calc are now loaded.")) |
|
) |
|
1717 |
|
|
1718 |
|
|
1719 |
;;; Vector commands. |
;;; Vector commands. |
1729 |
(calc-top 1) (calc-top 2)))) |
(calc-top 1) (calc-top 2)))) |
1730 |
(if (calc-is-hyperbolic) |
(if (calc-is-hyperbolic) |
1731 |
(calc-binary-op "apnd" 'calcFunc-append arg '(vec)) |
(calc-binary-op "apnd" 'calcFunc-append arg '(vec)) |
1732 |
(calc-binary-op "|" 'calcFunc-vconcat arg '(vec) nil '|)))) |
(calc-binary-op "|" 'calcFunc-vconcat arg '(vec) nil '|))))) |
|
) |
|
1733 |
|
|
1734 |
(defun calc-append (arg) |
(defun calc-append (arg) |
1735 |
(interactive "P") |
(interactive "P") |
1736 |
(calc-hyperbolic-func) |
(calc-hyperbolic-func) |
1737 |
(calc-concat arg) |
(calc-concat arg)) |
|
) |
|
1738 |
|
|
1739 |
|
|
1740 |
(defconst calc-arg-values '( ( var ArgA var-ArgA ) ( var ArgB var-ArgB ) |
(defconst calc-arg-values '( ( var ArgA var-ArgA ) ( var ArgB var-ArgB ) |
1745 |
)) |
)) |
1746 |
|
|
1747 |
(defun calc-invent-args (n) |
(defun calc-invent-args (n) |
1748 |
(nreverse (nthcdr (- (length calc-arg-values) n) (reverse calc-arg-values))) |
(nreverse (nthcdr (- (length calc-arg-values) n) (reverse calc-arg-values)))) |
|
) |
|
1749 |
|
|
1750 |
|
|
1751 |
|
|
1758 |
(let ((res (cdr (lookup-key calc-mode-map "z")))) |
(let ((res (cdr (lookup-key calc-mode-map "z")))) |
1759 |
(if (eq (car (car res)) 27) |
(if (eq (car (car res)) 27) |
1760 |
(cdr res) |
(cdr res) |
1761 |
res)) |
res))) |
|
) |
|
1762 |
|
|
1763 |
(defun calc-z-prefix-help () |
(defun calc-z-prefix-help () |
1764 |
(interactive) |
(interactive) |
1779 |
(calc-user-function-list kmap 6)) |
(calc-user-function-list kmap 6)) |
1780 |
(if (/= flags 0) |
(if (/= flags 0) |
1781 |
(setq msgs (cons buf msgs))) |
(setq msgs (cons buf msgs))) |
1782 |
(calc-do-prefix-help (nreverse msgs) "user" ?z)) |
(calc-do-prefix-help (nreverse msgs) "user" ?z))) |
|
) |
|
1783 |
|
|
1784 |
(defun calc-user-function-classify (key) |
(defun calc-user-function-classify (key) |
1785 |
(cond ((/= key (downcase key)) ; upper-case |
(cond ((/= key (downcase key)) ; upper-case |
1786 |
(if (assq (downcase key) (calc-user-key-map)) 9 1)) |
(if (assq (downcase key) (calc-user-key-map)) 9 1)) |
1787 |
((/= key (upcase key)) 2) ; lower-case |
((/= key (upcase key)) 2) ; lower-case |
1788 |
((= key ??) 0) |
((= key ??) 0) |
1789 |
(t 4)) ; other |
(t 4))) ; other |
|
) |
|
1790 |
|
|
1791 |
(defun calc-user-function-list (map flags) |
(defun calc-user-function-list (map flags) |
1792 |
(and map |
(and map |
1821 |
buf (concat (if (= flags 1) "SHIFT + " "") |
buf (concat (if (= flags 1) "SHIFT + " "") |
1822 |
desc)) |
desc)) |
1823 |
(setq buf (concat buf ", " desc)))))) |
(setq buf (concat buf ", " desc)))))) |
1824 |
(calc-user-function-list (cdr map) flags))) |
(calc-user-function-list (cdr map) flags)))) |
|
) |
|
1825 |
|
|
1826 |
|
|
1827 |
|
|
1834 |
"kbd-macros: < > (repeat), ( ) (for), { } (loop)" |
"kbd-macros: < > (repeat), ( ) (for), { } (loop)" |
1835 |
"kbd-macros: / (break)" |
"kbd-macros: / (break)" |
1836 |
"kbd-macros: ` (save), ' (restore)") |
"kbd-macros: ` (save), ' (restore)") |
1837 |
"user" ?Z) |
"user" ?Z)) |
|
) |
|
1838 |
|
|
1839 |
|
|
1840 |
;;;; Caches. |
;;;; Caches. |
1877 |
'(+ calc-internal-prec 2))) |
'(+ calc-internal-prec 2))) |
1878 |
cache-val)) |
cache-val)) |
1879 |
last-prec 'calc-internal-prec)) |
last-prec 'calc-internal-prec)) |
1880 |
last-val))) |
last-val)))) |
|
) |
|
1881 |
(put 'math-defcache 'lisp-indent-hook 2) |
(put 'math-defcache 'lisp-indent-hook 2) |
1882 |
|
|
1883 |
;;; Betcha didn't know that pi = 16 atan(1/5) - 4 atan(1/239). [F] [Public] |
;;; Betcha didn't know that pi = 16 atan(1/5) - 4 atan(1/239). [F] [Public] |
1932 |
(if symb |
(if symb |
1933 |
'(var pi var-pi) |
'(var pi var-pi) |
1934 |
(math-pi)) |
(math-pi)) |
1935 |
180) |
180)) |
|
) |
|
1936 |
|
|
1937 |
(defun math-full-circle (symb) |
(defun math-full-circle (symb) |
1938 |
(math-mul 2 (math-half-circle symb)) |
(math-mul 2 (math-half-circle symb))) |
|
) |
|
1939 |
|
|
1940 |
(defun math-quarter-circle (symb) |
(defun math-quarter-circle (symb) |
1941 |
(math-div (math-half-circle symb) 2) |
(math-div (math-half-circle symb) 2)) |
|
) |
|
1942 |
|
|
1943 |
|
|
1944 |
|
|
1950 |
(if (consp a) |
(if (consp a) |
1951 |
(and (memq (car a) '(bigpos bigneg)) |
(and (memq (car a) '(bigpos bigneg)) |
1952 |
(= (% (nth 1 a) 2) 1)) |
(= (% (nth 1 a) 2) 1)) |
1953 |
(/= (% a 2) 0)) |
(/= (% a 2) 0))) |
|
) |
|
1954 |
|
|
1955 |
;;; True if A is a small or big integer. [P x] [Public] |
;;; True if A is a small or big integer. [P x] [Public] |
1956 |
(defun math-integerp (a) |
(defun math-integerp (a) |
1957 |
(or (integerp a) |
(or (integerp a) |
1958 |
(memq (car-safe a) '(bigpos bigneg))) |
(memq (car-safe a) '(bigpos bigneg)))) |
|
) |
|
1959 |
|
|
1960 |
;;; True if A is (numerically) a non-negative integer. [P N] [Public] |
;;; True if A is (numerically) a non-negative integer. [P N] [Public] |
1961 |
(defun math-natnump (a) |
(defun math-natnump (a) |
1962 |
(or (natnump a) |
(or (natnump a) |
1963 |
(eq (car-safe a) 'bigpos)) |
(eq (car-safe a) 'bigpos))) |
|
) |
|
1964 |
|
|
1965 |
;;; True if A is a rational (or integer). [P x] [Public] |
;;; True if A is a rational (or integer). [P x] [Public] |
1966 |
(defun math-ratp (a) |
(defun math-ratp (a) |
1967 |
(or (integerp a) |
(or (integerp a) |
1968 |
(memq (car-safe a) '(bigpos bigneg frac))) |
(memq (car-safe a) '(bigpos bigneg frac)))) |
|
) |
|
1969 |
|
|
1970 |
;;; True if A is a real (or rational). [P x] [Public] |
;;; True if A is a real (or rational). [P x] [Public] |
1971 |
(defun math-realp (a) |
(defun math-realp (a) |
1972 |
(or (integerp a) |
(or (integerp a) |
1973 |
(memq (car-safe a) '(bigpos bigneg frac float))) |
(memq (car-safe a) '(bigpos bigneg frac float)))) |
|
) |
|
1974 |
|
|
1975 |
;;; True if A is a real or HMS form. [P x] [Public] |
;;; True if A is a real or HMS form. [P x] [Public] |
1976 |
(defun math-anglep (a) |
(defun math-anglep (a) |
1977 |
(or (integerp a) |
(or (integerp a) |
1978 |
(memq (car-safe a) '(bigpos bigneg frac float hms))) |
(memq (car-safe a) '(bigpos bigneg frac float hms)))) |
|
) |
|
1979 |
|
|
1980 |
;;; True if A is a number of any kind. [P x] [Public] |
;;; True if A is a number of any kind. [P x] [Public] |
1981 |
(defun math-numberp (a) |
(defun math-numberp (a) |
1982 |
(or (integerp a) |
(or (integerp a) |
1983 |
(memq (car-safe a) '(bigpos bigneg frac float cplx polar))) |
(memq (car-safe a) '(bigpos bigneg frac float cplx polar)))) |
|
) |
|
1984 |
|
|
1985 |
;;; True if A is a complex number or angle. [P x] [Public] |
;;; True if A is a complex number or angle. [P x] [Public] |
1986 |
(defun math-scalarp (a) |
(defun math-scalarp (a) |
1987 |
(or (integerp a) |
(or (integerp a) |
1988 |
(memq (car-safe a) '(bigpos bigneg frac float cplx polar hms))) |
(memq (car-safe a) '(bigpos bigneg frac float cplx polar hms)))) |
|
) |
|
1989 |
|
|
1990 |
;;; True if A is a vector. [P x] [Public] |
;;; True if A is a vector. [P x] [Public] |
1991 |
(defun math-vectorp (a) |
(defun math-vectorp (a) |
1992 |
(eq (car-safe a) 'vec) |
(eq (car-safe a) 'vec)) |
|
) |
|
1993 |
|
|
1994 |
;;; True if A is any vector or scalar data object. [P x] |
;;; True if A is any vector or scalar data object. [P x] |
1995 |
(defun math-objvecp (a) ; [Public] |
(defun math-objvecp (a) ; [Public] |
1996 |
(or (integerp a) |
(or (integerp a) |
1997 |
(memq (car-safe a) '(bigpos bigneg frac float cplx polar |
(memq (car-safe a) '(bigpos bigneg frac float cplx polar |
1998 |
hms date sdev intv mod vec incomplete))) |
hms date sdev intv mod vec incomplete)))) |
|
) |
|
1999 |
|
|
2000 |
;;; True if A is an object not composed of sub-formulas . [P x] [Public] |
;;; True if A is an object not composed of sub-formulas . [P x] [Public] |
2001 |
(defun math-primp (a) |
(defun math-primp (a) |
2002 |
(or (integerp a) |
(or (integerp a) |
2003 |
(memq (car-safe a) '(bigpos bigneg frac float cplx polar |
(memq (car-safe a) '(bigpos bigneg frac float cplx polar |
2004 |
hms date mod var))) |
hms date mod var)))) |
|
) |
|
2005 |
|
|
2006 |
;;; True if A is numerically (but not literally) an integer. [P x] [Public] |
;;; True if A is numerically (but not literally) an integer. [P x] [Public] |
2007 |
(defun math-messy-integerp (a) |
(defun math-messy-integerp (a) |
2008 |
(cond |
(cond |
2009 |
((eq (car-safe a) 'float) (>= (nth 2 a) 0)) |
((eq (car-safe a) 'float) (>= (nth 2 a) 0)) |
2010 |
((eq (car-safe a) 'frac) (Math-integerp (math-normalize a)))) |
((eq (car-safe a) 'frac) (Math-integerp (math-normalize a))))) |
|
) |
|
2011 |
|
|
2012 |
;;; True if A is numerically an integer. [P x] [Public] |
;;; True if A is numerically an integer. [P x] [Public] |
2013 |
(defun math-num-integerp (a) |
(defun math-num-integerp (a) |
2014 |
(or (Math-integerp a) |
(or (Math-integerp a) |
2015 |
(Math-messy-integerp a)) |
(Math-messy-integerp a))) |
|
) |
|
2016 |
|
|
2017 |
;;; True if A is (numerically) a non-negative integer. [P N] [Public] |
;;; True if A is (numerically) a non-negative integer. [P N] [Public] |
2018 |
(defun math-num-natnump (a) |
(defun math-num-natnump (a) |
2020 |
(eq (car-safe a) 'bigpos) |
(eq (car-safe a) 'bigpos) |
2021 |
(and (eq (car-safe a) 'float) |
(and (eq (car-safe a) 'float) |
2022 |
(Math-natnump (nth 1 a)) |
(Math-natnump (nth 1 a)) |
2023 |
(>= (nth 2 a) 0))) |
(>= (nth 2 a) 0)))) |
|
) |
|
2024 |
|
|
2025 |
;;; True if A is an integer or will evaluate to an integer. [P x] [Public] |
;;; True if A is an integer or will evaluate to an integer. [P x] [Public] |
2026 |
(defun math-provably-integerp (a) |
(defun math-provably-integerp (a) |
2031 |
calcFunc-roundu |
calcFunc-roundu |
2032 |
calcFunc-floor |
calcFunc-floor |
2033 |
calcFunc-ceil)) |
calcFunc-ceil)) |
2034 |
(= (length a) 2))) |
(= (length a) 2)))) |
|
) |
|
2035 |
|
|
2036 |
;;; True if A is a real or will evaluate to a real. [P x] [Public] |
;;; True if A is a real or will evaluate to a real. [P x] [Public] |
2037 |
(defun math-provably-realp (a) |
(defun math-provably-realp (a) |
2038 |
(or (Math-realp a) |
(or (Math-realp a) |
2039 |
(math-provably-integer a) |
(math-provably-integer a) |
2040 |
(memq (car-safe a) '(abs arg))) |
(memq (car-safe a) '(abs arg)))) |
|
) |
|
2041 |
|
|
2042 |
;;; True if A is a non-real, complex number. [P x] [Public] |
;;; True if A is a non-real, complex number. [P x] [Public] |
2043 |
(defun math-complexp (a) |
(defun math-complexp (a) |
2044 |
(memq (car-safe a) '(cplx polar)) |
(memq (car-safe a) '(cplx polar))) |
|
) |
|
2045 |
|
|
2046 |
;;; True if A is a non-real, rectangular complex number. [P x] [Public] |
;;; True if A is a non-real, rectangular complex number. [P x] [Public] |
2047 |
(defun math-rect-complexp (a) |
(defun math-rect-complexp (a) |
2048 |
(eq (car-safe a) 'cplx) |
(eq (car-safe a) 'cplx)) |
|
) |
|
2049 |
|
|
2050 |
;;; True if A is a non-real, polar complex number. [P x] [Public] |
;;; True if A is a non-real, polar complex number. [P x] [Public] |
2051 |
(defun math-polar-complexp (a) |
(defun math-polar-complexp (a) |
2052 |
(eq (car-safe a) 'polar) |
(eq (car-safe a) 'polar)) |
|
) |
|
2053 |
|
|
2054 |
;;; True if A is a matrix. [P x] [Public] |
;;; True if A is a matrix. [P x] [Public] |
2055 |
(defun math-matrixp (a) |
(defun math-matrixp (a) |
2061 |
(while (and (setq a (cdr a)) |
(while (and (setq a (cdr a)) |
2062 |
(Math-vectorp (car a)) |
(Math-vectorp (car a)) |
2063 |
(= (length (car a)) len))) |
(= (length (car a)) len))) |
2064 |
(null a))) |
(null a)))) |
|
) |
|
2065 |
|
|
2066 |
(defun math-matrixp-step (a len) ; [P L] |
(defun math-matrixp-step (a len) ; [P L] |
2067 |
(or (null a) |
(or (null a) |
2068 |
(and (Math-vectorp (car a)) |
(and (Math-vectorp (car a)) |
2069 |
(= (length (car a)) len) |
(= (length (car a)) len) |
2070 |
(math-matrixp-step (cdr a) len))) |
(math-matrixp-step (cdr a) len)))) |
|
) |
|
2071 |
|
|
2072 |
;;; True if A is a square matrix. [P V] [Public] |
;;; True if A is a square matrix. [P V] [Public] |
2073 |
(defun math-square-matrixp (a) |
(defun math-square-matrixp (a) |
2074 |
(let ((dims (math-mat-dimens a))) |
(let ((dims (math-mat-dimens a))) |
2075 |
(and (cdr dims) |
(and (cdr dims) |
2076 |
(= (car dims) (nth 1 dims)))) |
(= (car dims) (nth 1 dims))))) |
|
) |
|
2077 |
|
|
2078 |
;;; True if A is any scalar data object. [P x] |
;;; True if A is any scalar data object. [P x] |
2079 |
(defun math-objectp (a) ; [Public] |
(defun math-objectp (a) ; [Public] |
2080 |
(or (integerp a) |
(or (integerp a) |
2081 |
(memq (car-safe a) '(bigpos bigneg frac float cplx |
(memq (car-safe a) '(bigpos bigneg frac float cplx |
2082 |
polar hms date sdev intv mod))) |
polar hms date sdev intv mod)))) |
|
) |
|
2083 |
|
|
2084 |
;;; Verify that A is an integer and return A in integer form. [I N; - x] |
;;; Verify that A is an integer and return A in integer form. [I N; - x] |
2085 |
(defun math-check-integer (a) ; [Public] |
(defun math-check-integer (a) ; [Public] |
2087 |
((math-integerp a) a) |
((math-integerp a) a) |
2088 |
((math-messy-integerp a) |
((math-messy-integerp a) |
2089 |
(math-trunc a)) |
(math-trunc a)) |
2090 |
(t (math-reject-arg a 'integerp))) |
(t (math-reject-arg a 'integerp)))) |
|
) |
|
2091 |
|
|
2092 |
;;; Verify that A is a small integer and return A in integer form. [S N; - x] |
;;; Verify that A is a small integer and return A in integer form. [S N; - x] |
2093 |
(defun math-check-fixnum (a &optional allow-inf) ; [Public] |
(defun math-check-fixnum (a &optional allow-inf) ; [Public] |
2104 |
(lsh -1 -1)) |
(lsh -1 -1)) |
2105 |
((and allow-inf (equal a '(neg (var inf var-inf)))) |
((and allow-inf (equal a '(neg (var inf var-inf)))) |
2106 |
(- (lsh -1 -1))) |
(- (lsh -1 -1))) |
2107 |
(t (math-reject-arg a 'fixnump))) |
(t (math-reject-arg a 'fixnump)))) |
|
) |
|
2108 |
|
|
2109 |
;;; Verify that A is an integer >= 0 and return A in integer form. [I N; - x] |
;;; Verify that A is an integer >= 0 and return A in integer form. [I N; - x] |
2110 |
(defun math-check-natnum (a) ; [Public] |
(defun math-check-natnum (a) ; [Public] |
2112 |
((and (not (math-negp a)) |
((and (not (math-negp a)) |
2113 |
(Math-num-integerp a)) |
(Math-num-integerp a)) |
2114 |
(math-trunc a)) |
(math-trunc a)) |
2115 |
(t (math-reject-arg a 'natnump))) |
(t (math-reject-arg a 'natnump)))) |
|
) |
|
2116 |
|
|
2117 |
;;; Verify that A is in floating-point form, or force it to be a float. [F N] |
;;; Verify that A is in floating-point form, or force it to be a float. [F N] |
2118 |
(defun math-check-float (a) ; [Public] |
(defun math-check-float (a) ; [Public] |
2119 |
(cond ((eq (car-safe a) 'float) a) |
(cond ((eq (car-safe a) 'float) a) |
2120 |
((Math-vectorp a) (math-map-vec 'math-check-float a)) |
((Math-vectorp a) (math-map-vec 'math-check-float a)) |
2121 |
((Math-objectp a) (math-float a)) |
((Math-objectp a) (math-float a)) |
2122 |
(t a)) |
(t a))) |
|
) |
|
2123 |
|
|
2124 |
;;; Verify that A is a constant. |
;;; Verify that A is a constant. |
2125 |
(defun math-check-const (a &optional exp-ok) |
(defun math-check-const (a &optional exp-ok) |
2126 |
(if (or (math-constp a) |
(if (or (math-constp a) |
2127 |
(and exp-ok math-expand-formulas)) |
(and exp-ok math-expand-formulas)) |
2128 |
a |
a |
2129 |
(math-reject-arg a 'constp)) |
(math-reject-arg a 'constp))) |
|
) |
|
2130 |
|
|
2131 |
|
|
2132 |
;;; Coerce integer A to be a small integer. [S I] |
;;; Coerce integer A to be a small integer. [S I] |
2137 |
(- (math-fixnum-big (cdr a))) |
(- (math-fixnum-big (cdr a))) |
2138 |
(math-fixnum-big (cdr a))) |
(math-fixnum-big (cdr a))) |
2139 |
0) |
0) |
2140 |
a) |
a)) |
|
) |
|
2141 |
|
|
2142 |
(defun math-fixnum-big (a) |
(defun math-fixnum-big (a) |
2143 |
(if (cdr a) |
(if (cdr a) |
2144 |
(+ (car a) (* (math-fixnum-big (cdr a)) 1000)) |
(+ (car a) (* (math-fixnum-big (cdr a)) 1000)) |
2145 |
(car a)) |
(car a))) |
|
) |
|
2146 |
|
|
2147 |
|
|
2148 |
(defun math-normalize-fancy (a) |
(defun math-normalize-fancy (a) |
2212 |
((or (integerp (car a)) (consp (car a))) |
((or (integerp (car a)) (consp (car a))) |
2213 |
(if (null (cdr a)) |
(if (null (cdr a)) |
2214 |
(math-normalize (car a)) |
(math-normalize (car a)) |
2215 |
(error "Can't use multi-valued function in an expression")))) |
(error "Can't use multi-valued function in an expression"))))) |
|
) |
|
2216 |
|
|
2217 |
(defun math-normalize-nonstandard () ; uses "a" |
(defun math-normalize-nonstandard () ; uses "a" |
2218 |
(if (consp calc-simplify-mode) |
(if (consp calc-simplify-mode) |
2229 |
(while (and aptr (math-constp (car aptr))) |
(while (and aptr (math-constp (car aptr))) |
2230 |
(setq aptr (cdr aptr))) |
(setq aptr (cdr aptr))) |
2231 |
aptr))) |
aptr))) |
2232 |
(cons (car a) (mapcar 'math-normalize (cdr a))))) |
(cons (car a) (mapcar 'math-normalize (cdr a)))))) |
|
) |
|
2233 |
|
|
2234 |
|
|
2235 |
|
|
2245 |
(and last |
(and last |
2246 |
(progn |
(progn |
2247 |
(setcdr last nil) |
(setcdr last nil) |
2248 |
a))) |
a)))) |
|
) |
|
2249 |
|
|
2250 |
(defun math-bignum-test (a) ; [B N; B s; b b] |
(defun math-bignum-test (a) ; [B N; B s; b b] |
2251 |
(if (consp a) |
(if (consp a) |
2252 |
a |
a |
2253 |
(math-bignum a)) |
(math-bignum a))) |
|
) |
|
2254 |
|
|
2255 |
|
|
2256 |
;;; Return 0 for zero, -1 for negative, 1 for positive. [S n] [Public] |
;;; Return 0 for zero, -1 for negative, 1 for positive. [S n] [Public] |
2263 |
(t (calc-record-why 'realp a) |
(t (calc-record-why 'realp a) |
2264 |
(if x |
(if x |
2265 |
(list 'calcFunc-sign a x) |
(list 'calcFunc-sign a x) |
2266 |
(list 'calcFunc-sign a))))) |
(list 'calcFunc-sign a)))))) |
|
) |
|
2267 |
|
|
2268 |
;;; Return 0 if A is numerically equal to B, <0 if less, >0 if more. |
;;; Return 0 if A is numerically equal to B, <0 if less, >0 if more. |
2269 |
;;; Arguments must be normalized! [S N N] |
;;; Arguments must be normalized! [S N N] |
2375 |
(eq (car a) (car b)) |
(eq (car a) (car b)) |
2376 |
(math-compare-lists (cdr a) (cdr b))) |
(math-compare-lists (cdr a) (cdr b))) |
2377 |
0 |
0 |
2378 |
2))) |
2)))) |
|
) |
|
2379 |
|
|
2380 |
;;; Compare two bignum digit lists, return -1 for A<B, 0 for A=B, 1 for A>B. |
;;; Compare two bignum digit lists, return -1 for A<B, 0 for A=B, 1 for A>B. |
2381 |
(defun math-compare-bignum (a b) ; [S l l] |
(defun math-compare-bignum (a b) ; [S l l] |
2392 |
(while (eq (car a) 0) (setq a (cdr a))) |
(while (eq (car a) 0) (setq a (cdr a))) |
2393 |
(if a 1 res)) |
(if a 1 res)) |
2394 |
(while (eq (car b) 0) (setq b (cdr b))) |
(while (eq (car b) 0) (setq b (cdr b))) |
2395 |
(if b -1 res))) |
(if b -1 res)))) |
|
) |
|
2396 |
|
|
2397 |
(defun math-compare-lists (a b) |
(defun math-compare-lists (a b) |
2398 |
(cond ((null a) (null b)) |
(cond ((null a) (null b)) |
2399 |
((null b) nil) |
((null b) nil) |
2400 |
(t (and (Math-equal (car a) (car b)) |
(t (and (Math-equal (car a) (car b)) |
2401 |
(math-compare-lists (cdr a) (cdr b))))) |
(math-compare-lists (cdr a) (cdr b)))))) |
|
) |
|
2402 |
|
|
2403 |
(defun math-lessp-float (a b) ; [P F F] |
(defun math-lessp-float (a b) ; [P F F] |
2404 |
(let ((ediff (- (nth 2 a) (nth 2 b)))) |
(let ((ediff (- (nth 2 a) (nth 2 b)))) |
2415 |
(Math-integer-negp (nth 1 a)) |
(Math-integer-negp (nth 1 a)) |
2416 |
(Math-integer-posp (nth 1 b))) |
(Math-integer-posp (nth 1 b))) |
2417 |
(Math-lessp (nth 1 a) |
(Math-lessp (nth 1 a) |
2418 |
(math-scale-int (nth 1 b) ediff))))) |
(math-scale-int (nth 1 b) ediff)))))) |
|
) |
|
2419 |
|
|
2420 |
;;; True if A is numerically equal to B. [P N N] [Public] |
;;; True if A is numerically equal to B. [P N N] [Public] |
2421 |
(defun math-equal (a b) |
(defun math-equal (a b) |
2422 |
(= (math-compare a b) 0) |
(= (math-compare a b) 0)) |
|
) |
|
2423 |
|
|
2424 |
;;; True if A is numerically less than B. [P R R] [Public] |
;;; True if A is numerically less than B. [P R R] [Public] |
2425 |
(defun math-lessp (a b) |
(defun math-lessp (a b) |
2426 |
(= (math-compare a b) -1) |
(= (math-compare a b) -1)) |
|
) |
|
2427 |
|
|
2428 |
;;; True if A is numerically equal to the integer B. [P N S] [Public] |
;;; True if A is numerically equal to the integer B. [P N S] [Public] |
2429 |
;;; B must not be a multiple of 10. |
;;; B must not be a multiple of 10. |
2431 |
(or (eq a b) |
(or (eq a b) |
2432 |
(and (eq (car-safe a) 'float) |
(and (eq (car-safe a) 'float) |
2433 |
(eq (nth 1 a) b) |
(eq (nth 1 a) b) |
2434 |
(= (nth 2 a) 0))) |
(= (nth 2 a) 0)))) |
|
) |
|
2435 |
|
|
2436 |
|
|
2437 |
|
|
2443 |
(cons (1- (length m)) |
(cons (1- (length m)) |
2444 |
(math-mat-dimens (nth 1 m))) |
(math-mat-dimens (nth 1 m))) |
2445 |
(list (1- (length m)))) |
(list (1- (length m)))) |
2446 |
nil) |
nil)) |
|
) |
|
2447 |
|
|
2448 |
|
|
2449 |
|
|
2469 |
(mapcar (function |
(mapcar (function |
2470 |
(lambda (x) |
(lambda (x) |
2471 |
(list func x rhs))) |
(list func x rhs))) |
2472 |
(calc-top-list-n (- n) 2))))))) |
(calc-top-list-n (- n) 2)))))))) |
|
) |
|
2473 |
|
|
2474 |
(defun calc-unary-op-fancy (name func arg) |
(defun calc-unary-op-fancy (name func arg) |
2475 |
(let ((n (prefix-numeric-value arg))) |
(let ((n (prefix-numeric-value arg))) |
2485 |
(calc-enter-result 1 |
(calc-enter-result 1 |
2486 |
name |
name |
2487 |
(list func (calc-top-n (- n))) |
(list func (calc-top-n (- n))) |
2488 |
(- n))))) |
(- n)))))) |
|
) |
|
2489 |
|
|
2490 |
|
|
2491 |
|
|
2501 |
|
|
2502 |
(defun math-inexact-result () |
(defun math-inexact-result () |
2503 |
(and calc-symbolic-mode |
(and calc-symbolic-mode |
2504 |
(signal 'inexact-result nil)) |
(signal 'inexact-result nil))) |
|
) |
|
2505 |
|
|
2506 |
(defun math-overflow (&optional exp) |
(defun math-overflow (&optional exp) |
2507 |
(if (and exp (math-negp exp)) |
(if (and exp (math-negp exp)) |
2508 |
(math-underflow) |
(math-underflow) |
2509 |
(signal 'math-overflow nil)) |
(signal 'math-overflow nil))) |
|
) |
|
2510 |
|
|
2511 |
(defun math-underflow () |
(defun math-underflow () |
2512 |
(signal 'math-underflow nil) |
(signal 'math-underflow nil)) |
|
) |
|
2513 |
|
|
2514 |
|
|
2515 |
|
|
2542 |
(setq c b |
(setq c b |
2543 |
b (% a b) |
b (% a b) |
2544 |
a c)) |
a c)) |
2545 |
a))) |
a)))) |
|
) |
|
2546 |
|
|
2547 |
|
|
2548 |
;;;; Algebra. |
;;;; Algebra. |
2551 |
(defun math-evaluate-expr (x) ; [Public] |
(defun math-evaluate-expr (x) ; [Public] |
2552 |
(if calc-embedded-info |
(if calc-embedded-info |
2553 |
(calc-embedded-evaluate-expr x) |
(calc-embedded-evaluate-expr x) |
2554 |
(calc-normalize (math-evaluate-expr-rec x))) |
(calc-normalize (math-evaluate-expr-rec x)))) |
2555 |
) |
|
2556 |
(fset 'calcFunc-evalv (symbol-function 'math-evaluate-expr)) |
(defalias 'calcFunc-evalv 'math-evaluate-expr) |
2557 |
|
|
2558 |
(defun calcFunc-evalvn (x &optional prec) |
(defun calcFunc-evalvn (x &optional prec) |
2559 |
(if prec |
(if prec |
2573 |
(let ((calc-internal-prec prec)) |
(let ((calc-internal-prec prec)) |
2574 |
(calcFunc-evalvn x)))) |
(calcFunc-evalvn x)))) |
2575 |
(let ((calc-symbolic-mode nil)) |
(let ((calc-symbolic-mode nil)) |
2576 |
(math-evaluate-expr x))) |
(math-evaluate-expr x)))) |
|
) |
|
2577 |
|
|
2578 |
(defun math-evaluate-expr-rec (x) |
(defun math-evaluate-expr-rec (x) |
2579 |
(if (consp x) |
(if (consp x) |
2597 |
(if (Math-primp x) |
(if (Math-primp x) |
2598 |
x |
x |
2599 |
(cons (car x) (mapcar 'math-evaluate-expr-rec (cdr x)))))) |
(cons (car x) (mapcar 'math-evaluate-expr-rec (cdr x)))))) |
2600 |
x) |
x)) |
|
) |
|
|
|
|
|
|
|
2601 |
|
|
2602 |
(setq math-simplifying nil) |
(setq math-simplifying nil) |
2603 |
(setq math-living-dangerously nil) ; true if unsafe simplifications are okay. |
(setq math-living-dangerously nil) ; true if unsafe simplifications are okay. |
2604 |
(setq math-integrating nil) |
(setq math-integrating nil) |
2605 |
|
|
|
|
|
|
|
|
|
|
|
2606 |
(defmacro math-defsimplify (funcs &rest code) |
(defmacro math-defsimplify (funcs &rest code) |
2607 |
(append '(progn (math-need-std-simps)) |
(append '(progn (math-need-std-simps)) |
2608 |
(mapcar (function |
(mapcar (function |
2614 |
(list 'function |
(list 'function |
2615 |
(append '(lambda (expr)) |
(append '(lambda (expr)) |
2616 |
code))))))) |
code))))))) |
2617 |
(if (symbolp funcs) (list funcs) funcs))) |
(if (symbolp funcs) (list funcs) funcs)))) |
|
) |
|
2618 |
(put 'math-defsimplify 'lisp-indent-hook 1) |
(put 'math-defsimplify 'lisp-indent-hook 1) |
2619 |
|
|
|
|
|
2620 |
(defun math-any-floats (expr) |
(defun math-any-floats (expr) |
2621 |
(if (Math-primp expr) |
(if (Math-primp expr) |
2622 |
(math-floatp expr) |
(math-floatp expr) |
2623 |
(while (and (setq expr (cdr expr)) (not (math-any-floats (car expr))))) |
(while (and (setq expr (cdr expr)) (not (math-any-floats (car expr))))) |
2624 |
expr) |
expr)) |
|
) |
|
2625 |
|
|
2626 |
(defvar var-FactorRules 'calc-FactorRules) |
(defvar var-FactorRules 'calc-FactorRules) |
2627 |
|
|
|
|
|
|
|
|
2628 |
(defun math-map-tree (mmt-func mmt-expr &optional mmt-many) |
(defun math-map-tree (mmt-func mmt-expr &optional mmt-many) |
2629 |
(or mmt-many (setq mmt-many 1000000)) |
(or mmt-many (setq mmt-many 1000000)) |
2630 |
(math-map-tree-rec mmt-expr) |
(math-map-tree-rec mmt-expr)) |
|
) |
|
2631 |
|
|
2632 |
(defun math-map-tree-rec (mmt-expr) |
(defun math-map-tree-rec (mmt-expr) |
2633 |
(or (= mmt-many 0) |
(or (= mmt-many 0) |
2648 |
(if (equal mmt-nextval mmt-expr) |
(if (equal mmt-nextval mmt-expr) |
2649 |
(setq mmt-done t) |
(setq mmt-done t) |
2650 |
(setq mmt-expr mmt-nextval)))))) |
(setq mmt-expr mmt-nextval)))))) |
2651 |
mmt-expr |
mmt-expr) |
|
) |
|
|
|
|
|
|
|
|
|
|
2652 |
|
|
2653 |
(setq math-rewrite-selections nil) |
(setq math-rewrite-selections nil) |
2654 |
|
|
2655 |
(defun math-is-true (expr) |
(defun math-is-true (expr) |
2656 |
(if (Math-numberp expr) |
(if (Math-numberp expr) |
2657 |
(not (Math-zerop expr)) |
(not (Math-zerop expr)) |
2658 |
(math-known-nonzerop expr)) |
(math-known-nonzerop expr))) |
|
) |
|
2659 |
|
|
2660 |
(defun math-const-var (expr) |
(defun math-const-var (expr) |
2661 |
(and (consp expr) |
(and (consp expr) |
2663 |
(or (and (symbolp (nth 2 expr)) |
(or (and (symbolp (nth 2 expr)) |
2664 |
(boundp (nth 2 expr)) |
(boundp (nth 2 expr)) |
2665 |
(eq (car-safe (symbol-value (nth 2 expr))) 'special-const)) |
(eq (car-safe (symbol-value (nth 2 expr))) 'special-const)) |
2666 |
(memq (nth 2 expr) '(var-inf var-uinf var-nan)))) |
(memq (nth 2 expr) '(var-inf var-uinf var-nan))))) |
|
) |
|
|
|
|
|
|
|
|
|
|
2667 |
|
|
2668 |
(defmacro math-defintegral (funcs &rest code) |
(defmacro math-defintegral (funcs &rest code) |
2669 |
(setq math-integral-cache nil) |
(setq math-integral-cache nil) |
2677 |
(list 'function |
(list 'function |
2678 |
(append '(lambda (u)) |
(append '(lambda (u)) |
2679 |
code))))))) |
code))))))) |
2680 |
(if (symbolp funcs) (list funcs) funcs))) |
(if (symbolp funcs) (list funcs) funcs)))) |
|
) |
|
2681 |
(put 'math-defintegral 'lisp-indent-hook 1) |
(put 'math-defintegral 'lisp-indent-hook 1) |
2682 |
|
|
2683 |
(defmacro math-defintegral-2 (funcs &rest code) |
(defmacro math-defintegral-2 (funcs &rest code) |
2693 |
(list 'function |
(list 'function |
2694 |
(append '(lambda (u v)) |
(append '(lambda (u v)) |
2695 |
code))))))) |
code))))))) |
2696 |
(if (symbolp funcs) (list funcs) funcs))) |
(if (symbolp funcs) (list funcs) funcs)))) |
|
) |
|
2697 |
(put 'math-defintegral-2 'lisp-indent-hook 1) |
(put 'math-defintegral-2 'lisp-indent-hook 1) |
2698 |
|
|
|
|
|
2699 |
(defvar var-IntegAfterRules 'calc-IntegAfterRules) |
(defvar var-IntegAfterRules 'calc-IntegAfterRules) |
2700 |
|
|
|
|
|
2701 |
(defvar var-FitRules 'calc-FitRules) |
(defvar var-FitRules 'calc-FitRules) |
2702 |
|
|
|
|
|
2703 |
(setq math-poly-base-variable nil) |
(setq math-poly-base-variable nil) |
2704 |
(setq math-poly-neg-powers nil) |
(setq math-poly-neg-powers nil) |
2705 |
(setq math-poly-mult-powers 1) |
(setq math-poly-mult-powers 1) |
2706 |
(setq math-poly-frac-powers nil) |
(setq math-poly-frac-powers nil) |
2707 |
(setq math-poly-exp-base nil) |
(setq math-poly-exp-base nil) |
2708 |
|
|
|
|
|
|
|
|
|
|
|
2709 |
(defun math-build-var-name (name) |
(defun math-build-var-name (name) |
2710 |
(if (stringp name) |
(if (stringp name) |
2711 |
(setq name (intern name))) |
(setq name (intern name))) |
2712 |
(if (string-match "\\`var-." (symbol-name name)) |
(if (string-match "\\`var-." (symbol-name name)) |
2713 |
(list 'var (intern (substring (symbol-name name) 4)) name) |
(list 'var (intern (substring (symbol-name name) 4)) name) |
2714 |
(list 'var name (intern (concat "var-" (symbol-name name))))) |
(list 'var name (intern (concat "var-" (symbol-name name)))))) |
|
) |
|
2715 |
|
|
2716 |
(setq math-simplifying-units nil) |
(setq math-simplifying-units nil) |
2717 |
(setq math-combining-units t) |
(setq math-combining-units t) |
2880 |
(math-match-substring s 2)))) |
(math-match-substring s 2)))) |
2881 |
|
|
2882 |
;; Syntax error! |
;; Syntax error! |
2883 |
(t nil)) |
(t nil))) |
|
) |
|
2884 |
|
|
2885 |
(defun math-read-radix (s r) ; [I X D] |
(defun math-read-radix (s r) ; [I X D] |
2886 |
(setq s (upcase s)) |
(setq s (upcase s)) |
2893 |
(setq res (math-add (math-mul res r) dig) |
(setq res (math-add (math-mul res r) dig) |
2894 |
i (1+ i))) |
i (1+ i))) |
2895 |
(and (= i (length s)) |
(and (= i (length s)) |
2896 |
res)) |
res))) |
|
) |
|
2897 |
|
|
2898 |
|
|
2899 |
|
|
2914 |
(list 'error exp-old-pos val) |
(list 'error exp-old-pos val) |
2915 |
(if (equal exp-token 'end) |
(if (equal exp-token 'end) |
2916 |
val |
val |
2917 |
(list 'error exp-old-pos "Syntax error"))))) |
(list 'error exp-old-pos "Syntax error")))))) |
|
) |
|
2918 |
|
|
2919 |
(defun math-read-plain-expr (exp-str &optional error-check) |
(defun math-read-plain-expr (exp-str &optional error-check) |
2920 |
(let* ((calc-language nil) |
(let* ((calc-language nil) |
2923 |
(and error-check |
(and error-check |
2924 |
(eq (car-safe val) 'error) |
(eq (car-safe val) 'error) |
2925 |
(error "%s: %s" (nth 2 val) exp-str)) |
(error "%s: %s" (nth 2 val) exp-str)) |
2926 |
val) |
val)) |
|
) |
|
2927 |
|
|
2928 |
|
|
2929 |
(defun math-read-string () |
(defun math-read-string () |
2932 |
(stringp (car str))) |
(stringp (car str))) |
2933 |
(throw 'syntax "Error in string constant")) |
(throw 'syntax "Error in string constant")) |
2934 |
(math-read-token) |
(math-read-token) |
2935 |
(append '(vec) (car str) nil)) |
(append '(vec) (car str) nil))) |
|
) |
|
2936 |
|
|
2937 |
|
|
2938 |
|
|
2975 |
(math-read-big-rec 0 0 width (length lines))) |
(math-read-big-rec 0 0 width (length lines))) |
2976 |
err-msg |
err-msg |
2977 |
'(error 0 "Syntax error")) |
'(error 0 "Syntax error")) |
2978 |
(math-read-expr str)))) |
(math-read-expr str))))) |
|
) |
|
2979 |
|
|
2980 |
(defun math-read-big-bigp (lines) |
(defun math-read-big-bigp (lines) |
2981 |
(and (cdr lines) |
(and (cdr lines) |
3011 |
v (1+ v))) |
v (1+ v))) |
3012 |
(or (and (> height 1) |
(or (and (> height 1) |
3013 |
(not (cdr lines))) |
(not (cdr lines))) |
3014 |
matrix))) |
matrix)))) |
|
) |
|
3015 |
|
|
3016 |
|
|
3017 |
|
|
3093 |
(symbol-name (car a)))) |
(symbol-name (car a)))) |
3094 |
"(" |
"(" |
3095 |
(math-format-flat-vector (cdr a) ", " 0) |
(math-format-flat-vector (cdr a) ", " 0) |
3096 |
")")))))) |
")"))))))) |
|
) |
|
3097 |
(setq math-format-hash-args nil) |
(setq math-format-hash-args nil) |
3098 |
|
|
3099 |
(defun math-format-flat-vector (vec sep prec) |
(defun math-format-flat-vector (vec sep prec) |
3102 |
(while (setq vec (cdr vec)) |
(while (setq vec (cdr vec)) |
3103 |
(setq buf (concat buf sep (math-format-flat-expr (car vec) prec)))) |
(setq buf (concat buf sep (math-format-flat-expr (car vec) prec)))) |
3104 |
buf) |
buf) |
3105 |
"") |
"")) |
|
) |
|
3106 |
(setq calc-can-abbrev-vectors nil) |
(setq calc-can-abbrev-vectors nil) |
3107 |
|
|
3108 |
(defun math-format-nice-expr (x w) |
(defun math-format-nice-expr (x w) |
3129 |
(substring str p)) |
(substring str p)) |
3130 |
pos (1+ p)) |
pos (1+ p)) |
3131 |
(setq pos (+ pos w))))) |
(setq pos (+ pos w))))) |
3132 |
str))) |
str)))) |
|
) |
|
3133 |
|
|
3134 |
(defun math-assq2 (v a) |
(defun math-assq2 (v a) |
3135 |
(while (and a (not (eq v (nth 1 (car a))))) |
(while (and a (not (eq v (nth 1 (car a))))) |
3136 |
(setq a (cdr a))) |
(setq a (cdr a))) |
3137 |
(car a) |
(car a)) |
|
) |
|
3138 |
|
|
3139 |
|
|
3140 |
(defun math-format-number-fancy (a prec) |
(defun math-format-number-fancy (a prec) |
3225 |
(math-format-number (nth 2 a)))) |
(math-format-number (nth 2 a)))) |
3226 |
((eq (car a) 'vec) |
((eq (car a) 'vec) |
3227 |
(math-format-flat-expr a 0)) |
(math-format-flat-expr a 0)) |
3228 |
(t (format "%s" a))) |
(t (format "%s" a)))) |
|
) |
|
3229 |
|
|
3230 |
(defun math-adjust-fraction (a) |
(defun math-adjust-fraction (a) |
3231 |
(if (nth 1 calc-frac-format) |
(if (nth 1 calc-frac-format) |
3235 |
(math-gcd (nth 2 a) |
(math-gcd (nth 2 a) |
3236 |
(nth 1 calc-frac-format))))) |
(nth 1 calc-frac-format))))) |
3237 |
(list 'frac (math-mul (nth 1 a) g) (math-mul (nth 2 a) g)))) |
(list 'frac (math-mul (nth 1 a) g) (math-mul (nth 2 a) g)))) |
3238 |
a) |
a)) |
|
) |
|
3239 |
|
|
3240 |
(defun math-format-bignum-fancy (a) ; [X L] |
(defun math-format-bignum-fancy (a) ; [X L] |
3241 |
(let ((str (cond ((= calc-number-radix 10) |
(let ((str (cond ((= calc-number-radix 10) |
3270 |
(if calc-radix-formatter |
(if calc-radix-formatter |
3271 |
(funcall calc-radix-formatter calc-number-radix str) |
(funcall calc-radix-formatter calc-number-radix str) |
3272 |
(format "%d#%s" calc-number-radix str)) |
(format "%d#%s" calc-number-radix str)) |
3273 |
str)) |
str))) |
|
) |
|
3274 |
|
|
3275 |
|
|
3276 |
(defun math-group-float (str) ; [X X] |
(defun math-group-float (str) ; [X X] |
3289 |
str (concat (substring str 0 i) |
str (concat (substring str 0 i) |
3290 |
calc-group-char |
calc-group-char |
3291 |
(substring str i)))) |
(substring str i)))) |
3292 |
str) |
str)) |
|
) |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
3293 |
|
|
3294 |
(setq math-compose-level 0) |
(setq math-compose-level 0) |
3295 |
(setq math-comp-selected nil) |
(setq math-comp-selected nil) |
3310 |
list containing a numeric entry string, or nil. |
list containing a numeric entry string, or nil. |
3311 |
A key may contain additional specs for Inverse, Hyperbolic, and Inv+Hyp.") |
A key may contain additional specs for Inverse, Hyperbolic, and Inv+Hyp.") |
3312 |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
3313 |
(run-hooks 'calc-ext-load-hook) |
(run-hooks 'calc-ext-load-hook) |
3314 |
|
|
3315 |
|
;;; calc-ext.el ends here |
3316 |
|
|
3317 |
|
|