home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume24 / gnucalc / part22 < prev    next >
Encoding:
Text File  |  1991-10-31  |  55.2 KB  |  1,884 lines
  1. Newsgroups: comp.sources.misc
  2. From: daveg@synaptics.com (David Gillespie)
  3. Subject:  v24i070:  gnucalc - GNU Emacs Calculator, v2.00, Part22/56
  4. Message-ID: <1991Oct31.072701.18039@sparky.imd.sterling.com>
  5. X-Md4-Signature: de49189cd5559a325671d1b2159a017c
  6. Date: Thu, 31 Oct 1991 07:27:01 GMT
  7. Approved: kent@sparky.imd.sterling.com
  8.  
  9. Submitted-by: daveg@synaptics.com (David Gillespie)
  10. Posting-number: Volume 24, Issue 70
  11. Archive-name: gnucalc/part22
  12. Environment: Emacs
  13. Supersedes: gmcalc: Volume 13, Issue 27-45
  14.  
  15. ---- Cut Here and unpack ----
  16. #!/bin/sh
  17. # do not concatenate these parts, unpack them in order with /bin/sh
  18. # file calc-math.el continued
  19. #
  20. if test ! -r _shar_seq_.tmp; then
  21.     echo 'Please unpack part 1 first!'
  22.     exit 1
  23. fi
  24. (read Scheck
  25.  if test "$Scheck" != 22; then
  26.     echo Please unpack part "$Scheck" next!
  27.     exit 1
  28.  else
  29.     exit 0
  30.  fi
  31. ) < _shar_seq_.tmp || exit 1
  32. if test ! -f _shar_wnt_.tmp; then
  33.     echo 'x - still skipping calc-math.el'
  34. else
  35. echo 'x - continuing file calc-math.el'
  36. sed 's/^X//' << 'SHAR_EOF' >> 'calc-math.el' &&
  37. X     x)
  38. X    (t (calc-record-why 'numberp x)
  39. X       (list 'calcFunc-arccosh x)))
  40. )
  41. (put 'calcFunc-arccosh 'math-expandable t)
  42. X
  43. (defun calcFunc-arctanh (x)   ; [N N] [Public]
  44. X  (cond ((eq x 0) 0)
  45. X    ((and (Math-equal-int x 1) calc-infinite-mode)
  46. X     '(var inf var-inf))
  47. X    ((and (Math-equal-int x -1) calc-infinite-mode)
  48. X     '(neg (var inf var-inf)))
  49. X    (math-expand-formulas
  50. X     (list '/ (list '-
  51. X            (list 'calcFunc-ln (list '+ 1 x))
  52. X            (list 'calcFunc-ln (list '- 1 x))) 2))
  53. X    ((Math-numberp x)
  54. X     (if calc-symbolic-mode (signal 'inexact-result nil))
  55. X     (math-with-extra-prec 2
  56. X       (if (or (memq (car-safe x) '(cplx polar))
  57. X           (Math-lessp 1 x))
  58. X           (math-mul (math-sub (math-ln-raw (math-add '(float 1 0) x))
  59. X                   (math-ln-raw (math-sub '(float 1 0) x)))
  60. X             '(float 5 -1))
  61. X         (if (and (math-equal-int x 1) calc-infinite-mode)
  62. X         '(var inf var-inf)
  63. X           (if (and (math-equal-int x -1) calc-infinite-mode)
  64. X           '(neg (var inf var-inf))
  65. X         (math-mul (math-ln-raw (math-div (math-add '(float 1 0) x)
  66. X                          (math-sub 1 x)))
  67. X               '(float 5 -1)))))))
  68. X    ((eq (car-safe x) 'sdev)
  69. X     (math-make-sdev (calcFunc-arctanh (nth 1 x))
  70. X             (math-div (nth 2 x)
  71. X                   (math-sub 1 (math-sqr (nth 1 x))))))
  72. X    ((eq (car x) 'intv)
  73. X     (math-sort-intv (nth 1 x)
  74. X             (calcFunc-arctanh (nth 2 x))
  75. X             (calcFunc-arctanh (nth 3 x))))
  76. X    ((equal x '(var nan var-nan))
  77. X     x)
  78. X    (t (calc-record-why 'numberp x)
  79. X       (list 'calcFunc-arctanh x)))
  80. )
  81. (put 'calcFunc-arctanh 'math-expandable t)
  82. X
  83. X
  84. ;;; Convert A from HMS or degrees to radians.
  85. (defun calcFunc-rad (a)   ; [R R] [Public]
  86. X  (cond ((or (Math-numberp a)
  87. X         (eq (car a) 'intv))
  88. X     (math-with-extra-prec 2
  89. X       (math-mul a (math-pi-over-180))))
  90. X    ((eq (car a) 'hms)
  91. X     (math-from-hms a 'rad))
  92. X    ((eq (car a) 'sdev)
  93. X     (math-make-sdev (calcFunc-rad (nth 1 a))
  94. X             (calcFunc-rad (nth 2 a))))
  95. X    (math-expand-formulas
  96. X     (math-div (math-mul a '(var pi var-pi)) 180))
  97. X    ((math-infinitep a) a)
  98. X    (t (list 'calcFunc-rad a)))
  99. )
  100. (put 'calcFunc-rad 'math-expandable t)
  101. X
  102. ;;; Convert A from HMS or radians to degrees.
  103. (defun calcFunc-deg (a)   ; [R R] [Public]
  104. X  (cond ((or (Math-numberp a)
  105. X         (eq (car a) 'intv))
  106. X     (math-with-extra-prec 2
  107. X       (math-div a (math-pi-over-180))))
  108. X    ((eq (car a) 'hms)
  109. X     (math-from-hms a 'deg))
  110. X    ((eq (car a) 'sdev)
  111. X     (math-make-sdev (calcFunc-deg (nth 1 a))
  112. X             (calcFunc-deg (nth 2 a))))
  113. X    (math-expand-formulas
  114. X     (math-div (math-mul 180 a) '(var pi var-pi)))
  115. X    ((math-infinitep a) a)
  116. X    (t (list 'calcFunc-deg a)))
  117. )
  118. (put 'calcFunc-deg 'math-expandable t)
  119. X
  120. X
  121. X
  122. X
  123. SHAR_EOF
  124. echo 'File calc-math.el is complete' &&
  125. chmod 0644 calc-math.el ||
  126. echo 'restore of calc-math.el failed'
  127. Wc_c="`wc -c < 'calc-math.el'`"
  128. test 52594 -eq "$Wc_c" ||
  129.     echo 'calc-math.el: original size 52594, current size' "$Wc_c"
  130. rm -f _shar_wnt_.tmp
  131. fi
  132. # ============= calc-misc.el ==============
  133. if test -f 'calc-misc.el' -a X"$1" != X"-c"; then
  134.     echo 'x - skipping calc-misc.el (File already exists)'
  135.     rm -f _shar_wnt_.tmp
  136. else
  137. > _shar_wnt_.tmp
  138. echo 'x - extracting calc-misc.el (Text)'
  139. sed 's/^X//' << 'SHAR_EOF' > 'calc-misc.el' &&
  140. ;; Calculator for GNU Emacs, part I [calc-misc.el]
  141. ;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  142. ;; Written by Dave Gillespie, daveg@csvax.cs.caltech.edu.
  143. X
  144. ;; This file is part of GNU Emacs.
  145. X
  146. ;; GNU Emacs is distributed in the hope that it will be useful,
  147. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  148. ;; accepts responsibility to anyone for the consequences of using it
  149. ;; or for whether it serves any particular purpose or works at all,
  150. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  151. ;; License for full details.
  152. X
  153. ;; Everyone is granted permission to copy, modify and redistribute
  154. ;; GNU Emacs, but only under the conditions described in the
  155. ;; GNU Emacs General Public License.   A copy of this license is
  156. ;; supposed to have been given to you along with GNU Emacs so you
  157. ;; can know your rights and responsibilities.  It should be in a
  158. ;; file named COPYING.  Among other things, the copyright notice
  159. ;; and this notice must be preserved on all copies.
  160. X
  161. X
  162. X
  163. ;; This file is autoloaded from calc.el.
  164. (require 'calc)
  165. X
  166. (require 'calc-macs)
  167. X
  168. (defun calc-Need-calc-misc () nil)
  169. X
  170. X
  171. (defun calc-dispatch-help (arg)
  172. X  "M-# is a prefix key; follow it with one of these letters:
  173. X
  174. For turning Calc on and off:
  175. X  C  calc.  Start the Calculator in a window at the bottom of the screen.
  176. X  O  calc-other-window.  Start the Calculator but don't select its window.
  177. X  B  calc-big-or-small.  Control whether to use the full Emacs screen for Calc.
  178. X  Q  quick-calc.  Use the Calculator in the minibuffer.
  179. X  K  calc-keypad.  Start the Calculator in keypad mode (X window system only).
  180. X  E  calc-embedded.  Use the Calculator on a formula in this editing buffer.
  181. X  J  calc-embedded-select.  Like E, but select appropriate half of => or :=.
  182. X  W  calc-embedded-word.  Like E, but activate a single word, i.e., a number.
  183. X  Z  calc-user-invocation.  Invoke Calc in the way you defined with `Z I' cmd.
  184. X  X  calc-quit.  Turn Calc off.
  185. X
  186. For moving data into and out of Calc:
  187. X  G  calc-grab-region.  Grab the region defined by mark and point into Calc.
  188. X  R  calc-grab-rectangle.  Grab the rectangle defined by mark, point into Calc.
  189. X  Y  calc-copy-to-buffer.  Copy a value from the stack into the editing buffer.
  190. X  :  calc-grab-sum-down.  Grab a rectangle and sum the columns.
  191. X  _  calc-grab-sum-across.  Grab a rectangle and sum the rows.
  192. X
  193. For use with Embedded mode:
  194. X  A  calc-embedded-activate.  Find and activate all :='s and =>'s in buffer.
  195. X  D  calc-embedded-duplicate.  Make a copy of this formula and select it.
  196. X  F  calc-embedded-new-formula.  Insert a new formula at current point.
  197. X  N  calc-embedded-next.  Advance cursor to next known formula in buffer.
  198. X  P  calc-embedded-previous.  Advance cursor to previous known formula.
  199. X  U  calc-embedded-update-formula.  Re-evaluate formula at point.
  200. X  `  calc-embedded-edit.  Use calc-edit to edit formula at point.
  201. X
  202. Documentation:
  203. X  I  calc-info.  Read the Calculator manual in the Emacs Info system.
  204. X  T  calc-tutorial.  Run the Calculator Tutorial using the Emacs Info system.
  205. X  S  calc-summary.  Read the Summary from the Calculator manual in Info.
  206. X
  207. Miscellaneous:
  208. X  L  calc-load-everything.  Load all parts of the Calculator into memory.
  209. X  M  read-kbd-macro.  Read a region of keystroke names as a keyboard macro.
  210. X  0  (zero) calc-reset.  Reset Calc stack and modes to default state.
  211. X
  212. Press twice (`M-# M-#' or `M-# #') to turn Calc on or off using the same
  213. Calc user interface as before (either M-# C or M-# K; initially M-# C)."
  214. X  (interactive "P")
  215. X  (calc-check-defines)
  216. X  (if calc-dispatch-help
  217. X      (progn
  218. X    (save-window-excursion
  219. X      (describe-function 'calc-dispatch-help)
  220. X      (let ((win (get-buffer-window "*Help*")))
  221. X        (if win
  222. X        (let (key)
  223. X          (select-window win)
  224. X          (while (progn
  225. X               (message "Calc options: Calc, Keypad, ...  %s"
  226. X                    "press SPC, DEL to scroll, C-g to cancel")
  227. X               (memq (setq key (read-char))
  228. X                 '(?  ?\C-h ?\C-? ?\C-v ?\M-v)))
  229. X            (condition-case err
  230. X            (if (memq key '(?  ?\C-v))
  231. X                (scroll-up)
  232. X              (scroll-down))
  233. X              (error (beep))))
  234. X          (setq unread-command-char key)))))
  235. X    (calc-do-dispatch nil))
  236. X    (let ((calc-dispatch-help t))
  237. X      (calc-do-dispatch arg)))
  238. )
  239. X
  240. X
  241. (defun calc-big-or-small (arg)
  242. X  "Toggle Calc between full-screen and regular mode."
  243. X  (interactive "P")
  244. X  (let ((cwin (get-buffer-window "*Calculator*"))
  245. X    (twin (get-buffer-window "*Calc Trail*"))
  246. X    (kwin (get-buffer-window "*Calc Keypad*")))
  247. X    (if cwin
  248. X    (setq calc-full-mode
  249. X          (if kwin
  250. X          (and twin (eq (window-width twin) (screen-width)))
  251. X        (eq (window-height cwin) (1- (screen-height))))))
  252. X    (setq calc-full-mode (if arg
  253. X                 (> (prefix-numeric-value arg) 0)
  254. X               (not calc-full-mode)))
  255. X    (if kwin
  256. X    (progn
  257. X      (calc-quit)
  258. X      (calc-do-keypad calc-full-mode nil))
  259. X      (if cwin
  260. X      (progn
  261. X        (calc-quit)
  262. X        (calc nil calc-full-mode nil))))
  263. X    (message (if calc-full-mode
  264. X         "Now using full screen for Calc."
  265. X           "Now using partial screen for Calc.")))
  266. )
  267. X
  268. (defun calc-other-window ()
  269. X  "Invoke the Calculator in another window."
  270. X  (interactive)
  271. X  (if (memq major-mode '(calc-mode calc-trail-mode))
  272. X      (progn
  273. X    (other-window 1)
  274. X    (if (memq major-mode '(calc-mode calc-trail-mode))
  275. X        (other-window 1)))
  276. X    (if (get-buffer-window "*Calculator*")
  277. X    (calc-quit)
  278. X      (let ((win (selected-window)))
  279. X    (calc nil win (interactive-p)))))
  280. )
  281. X
  282. (defun another-calc ()
  283. X  "Create another, independent Calculator buffer."
  284. X  (interactive)
  285. X  (if (eq major-mode 'calc-mode)
  286. X      (mapcar (function
  287. X           (lambda (v)
  288. X         (set-default v (symbol-value v)))) calc-local-var-list))
  289. X  (set-buffer (generate-new-buffer "*Calculator*"))
  290. X  (pop-to-buffer (current-buffer))
  291. X  (calc-mode)
  292. )
  293. X
  294. X
  295. ;;; Make an attempt to preserve the window configuration, while deleting
  296. ;;; windows on "bufs".  Emacs 19's delete-window function will probably
  297. ;;; make this kludgery unnecessary, but Emacs 18's tendency to grow all
  298. ;;; windows on the screen to take up the slack from the deleted windows
  299. ;;; can be annoying when Calc was called during another multi-window
  300. ;;; application, such as GNUS.
  301. X
  302. (defun calc-delete-windows-keep (&rest bufs)
  303. X  (if (one-window-p)
  304. X      (mapcar 'delete-windows-on bufs)
  305. X    (let* ((w (car calc-was-split))
  306. X       (e (window-edges w))
  307. X       (wins nil)
  308. X       w2 e2)
  309. X      (while (progn
  310. X           (setq w2 (previous-window w)
  311. X             e2 (window-edges w2))
  312. X           (and (= (car e2) (car e))
  313. X            (= (nth 2 e2) (nth 2 e))
  314. X            (< (nth 1 e2) (nth 1 e))))
  315. X    (setq w w2 e e2))
  316. X      (setq w2 w e2 e)
  317. X      (while (progn
  318. X           (setq wins (cons (list w (nth 1 e) (window-buffer w)
  319. X                      (window-point w) (window-start w))
  320. X                wins)
  321. X             w (next-window w)
  322. X             e (window-edges w))
  323. X           (and (not (eq w w2))
  324. X            (= (car e2) (car e))
  325. X            (= (nth 2 e2) (nth 2 e)))))
  326. X      (setq wins (nreverse wins))
  327. X      (mapcar 'delete-windows-on bufs)
  328. X      (or (one-window-p)
  329. X      (let ((w wins)
  330. X        (main nil)
  331. X        (mainpos 0)
  332. X        (sel (if (window-point (nth 2 calc-was-split))
  333. X             (nth 2 calc-was-split)
  334. X               (selected-window))))
  335. X        (while w
  336. X          (if (window-point (car (car w)))
  337. X          (if main
  338. X              (delete-window (car (car w)))
  339. X            (setq main (car (car w))
  340. X              mainpos (nth 1 (car w))
  341. X              wins (cdr wins)))
  342. X        (setq wins (delq (car w) wins)))
  343. X          (setq w (cdr w)))
  344. X        (while wins
  345. X          (setq w (split-window main
  346. X                    (if (eq main (car calc-was-split))
  347. X                    (nth 1 calc-was-split)
  348. X                      (- (nth 1 (car wins)) mainpos))))
  349. X          (set-window-buffer w (nth 2 (car wins)))
  350. X          (set-window-point w (nth 3 (car wins)))
  351. X          (set-window-start w (nth 4 (car wins)))
  352. X          (if (eq sel (car (car wins)))
  353. X          (select-window w))
  354. X          (setq main w
  355. X            mainpos (nth 1 (car wins))
  356. X            wins (cdr wins)))
  357. X        (if (window-point sel)
  358. X        (select-window sel))))))
  359. )
  360. X
  361. X
  362. (defun calc-info ()
  363. X  "Run the Emacs Info system on the Calculator documentation."
  364. X  (interactive)
  365. X  (require 'info)
  366. X  (select-window (get-largest-window))
  367. X  (or (file-name-absolute-p calc-info-filename)
  368. X       (let ((p load-path)
  369. X         name)
  370. X     (if (boundp 'Info-directory)
  371. X         (setq p (cons Info-directory p)))
  372. X     (while (and p (not (file-exists-p
  373. X                 (setq name (expand-file-name calc-info-filename
  374. X                              (car p))))))
  375. X       (setq p (cdr p)))
  376. X     (if p (setq calc-info-filename name))))
  377. X  (info)
  378. X  (or (and (boundp 'Info-current-file)
  379. X       (stringp Info-current-file)
  380. X       (string-match "calc" Info-current-file))
  381. X      (Info-find-node calc-info-filename "Top"))
  382. )
  383. X
  384. (defun calc-tutorial ()
  385. X  "Run the Emacs Info system on the Calculator Tutorial."
  386. X  (interactive)
  387. X  (if (get-buffer-window "*Calculator*")
  388. X      (calc-quit))
  389. X  (calc-info)
  390. X  (Info-goto-node "Interactive Tutorial")
  391. X  (calc-other-window)
  392. X  (message "Welcome to the Calc Tutorial!")
  393. )
  394. X
  395. (defun calc-info-summary ()
  396. X  "Run the Emacs Info system on the Calculator Summary."
  397. X  (interactive)
  398. X  (calc-info)
  399. X  (Info-goto-node "Summary")
  400. )
  401. X
  402. (defun calc-help ()
  403. X  (interactive)
  404. X  (let ((msgs
  405. X     '("Press `h' for complete help; press `?' repeatedly for a summary"
  406. X       "Letter keys: Negate; Precision; Yank; Why; Xtended cmd; Quit"
  407. X       "Letter keys: SHIFT + Undo, reDo; Keep-args; Inverse, Hyperbolic"
  408. X       "Letter keys: SHIFT + sQrt; Sin, Cos, Tan; Exp, Ln, logB"
  409. X       "Letter keys: SHIFT + Floor, Round; Abs, conJ, arG; Pi"
  410. X       "Letter keys: SHIFT + Num-eval; More-recn; eXec-kbd-macro"
  411. X       "Other keys: +, -, *, /, ^, \\ (int div), : (frac div)"
  412. X       "Other keys: & (1/x), | (concat), % (modulo), ! (factorial)"
  413. X       "Other keys: ' (alg-entry), = (eval), ` (edit); M-RET (last-args)"
  414. X       "Other keys: SPC/RET (enter/dup), LFD (over); < > (scroll horiz)"
  415. X       "Other keys: DEL (drop), M-DEL (drop-above); { } (scroll vert)"
  416. X       "Other keys: TAB (swap/roll-dn), M-TAB (roll-up)"
  417. X       "Other keys: [ , ; ] (vector), ( , ) (complex), ( ; ) (polar)"
  418. X       "Prefix keys: Algebra, Binary/business, Convert, Display"
  419. X       "Prefix keys: Functions, Graphics, Help, J (select)"
  420. X       "Prefix keys: Kombinatorics/statistics, Modes, Store/recall"
  421. X       "Prefix keys: Trail/time, Units/statistics, Vector/matrix"
  422. X       "Prefix keys: Z (user), SHIFT + Z (define)"
  423. X       "Prefix keys: prefix + ? gives further help for that prefix"
  424. X       "  Calc 2.00 by Dave Gillespie, daveg@csvax.cs.caltech.edu")))
  425. X    (if calc-full-help-flag
  426. X    msgs
  427. X      (if (or calc-inverse-flag calc-hyperbolic-flag)
  428. X      (if calc-inverse-flag
  429. X          (if calc-hyperbolic-flag
  430. X          (calc-inv-hyp-prefix-help)
  431. X        (calc-inverse-prefix-help))
  432. X        (calc-hyperbolic-prefix-help))
  433. X    (setq calc-help-phase
  434. X          (if (eq this-command last-command)
  435. X          (% (1+ calc-help-phase) (1+ (length msgs)))
  436. X        0))
  437. X    (let ((msg (nth calc-help-phase msgs)))
  438. X      (message "%s" (if msg
  439. X                (concat msg ":"
  440. X                    (make-string (- (apply 'max
  441. X                               (mapcar 'length
  442. X                                   msgs))
  443. X                            (length msg)) 32)
  444. X                    "  [?=MORE]")
  445. X              ""))))))
  446. )
  447. X
  448. X
  449. X
  450. X
  451. ;;;; Stack and buffer management.
  452. X
  453. X
  454. (defun calc-do-handle-whys ()
  455. X  (setq calc-why (sort calc-next-why
  456. X               (function
  457. X            (lambda (x y)
  458. X              (and (eq (car x) '*) (not (eq (car y) '*))))))
  459. X    calc-next-why nil)
  460. X  (if (and calc-why (or (eq calc-auto-why t)
  461. X            (and (eq (car (car calc-why)) '*)
  462. X                 calc-auto-why)))
  463. X      (progn
  464. X    (calc-extensions)
  465. X    (calc-explain-why (car calc-why)
  466. X              (if (eq calc-auto-why t)
  467. X                  (cdr calc-why)
  468. X                (if calc-auto-why
  469. X                (eq (car (nth 1 calc-why)) '*))))
  470. X    (setq calc-last-why-command this-command)
  471. X    (calc-clear-command-flag 'clear-message)))
  472. )
  473. X
  474. (defun calc-record-why (&rest stuff)
  475. X  (if (eq (car stuff) 'quiet)
  476. X      (setq stuff (cdr stuff))
  477. X    (if (and (symbolp (car stuff))
  478. X         (cdr stuff)
  479. X         (or (Math-objectp (nth 1 stuff))
  480. X         (and (Math-vectorp (nth 1 stuff))
  481. X              (math-constp (nth 1 stuff)))
  482. X         (math-infinitep (nth 1 stuff))))
  483. X    (setq stuff (cons '* stuff))
  484. X      (if (and (stringp (car stuff))
  485. X           (string-match "\\`\\*" (car stuff)))
  486. X      (setq stuff (cons '* (cons (substring (car stuff) 1)
  487. X                     (cdr stuff)))))))
  488. X  (setq calc-next-why (cons stuff calc-next-why))
  489. X  nil
  490. )
  491. X
  492. ;;; True if A is a constant or vector of constants.  [P x] [Public]
  493. (defun math-constp (a)
  494. X  (or (Math-scalarp a)
  495. X      (and (memq (car a) '(sdev intv mod vec))
  496. X       (progn
  497. X         (while (and (setq a (cdr a))
  498. X             (or (Math-scalarp (car a))  ; optimization
  499. X                 (math-constp (car a)))))
  500. X         (null a))))
  501. )
  502. X
  503. X
  504. (defun calc-roll-down-stack (n &optional m)
  505. X  (if (< n 0)
  506. X      (calc-roll-up-stack (- n) m)
  507. X    (if (or (= n 0) (> n (calc-stack-size))) (setq n (calc-stack-size)))
  508. X    (or m (setq m 1))
  509. X    (and (> n 1)
  510. X     (< m n)
  511. X     (if (and calc-any-selections
  512. X          (not calc-use-selections))
  513. X         (calc-roll-down-with-selections n m)
  514. X       (calc-pop-push-list n
  515. X                   (append (calc-top-list m 1)
  516. X                       (calc-top-list (- n m) (1+ m)))))))
  517. )
  518. X
  519. (defun calc-roll-up-stack (n &optional m)
  520. X  (if (< n 0)
  521. X      (calc-roll-down-stack (- n) m)
  522. X    (if (or (= n 0) (> n (calc-stack-size))) (setq n (calc-stack-size)))
  523. X    (or m (setq m 1))
  524. X    (and (> n 1)
  525. X     (< m n)
  526. X     (if (and calc-any-selections
  527. X          (not calc-use-selections))
  528. X         (calc-roll-up-with-selections n m)
  529. X       (calc-pop-push-list n
  530. X                   (append (calc-top-list (- n m) 1)
  531. X                       (calc-top-list m (- n m -1)))))))
  532. )
  533. X
  534. X
  535. (defun calc-do-refresh ()
  536. X  (if calc-hyperbolic-flag
  537. X      (progn
  538. X    (setq calc-display-dirty t)
  539. X    nil)
  540. X    (calc-refresh)
  541. X    t)
  542. )
  543. X
  544. X
  545. (defun calc-record-list (vals &optional prefix)
  546. X  (while vals
  547. X    (or (eq (car vals) 'top-of-stack)
  548. X    (progn
  549. X      (calc-record (car vals) prefix)
  550. X      (setq prefix "...")))
  551. X    (setq vals (cdr vals)))
  552. )
  553. X
  554. X
  555. (defun calc-last-args-stub (arg)
  556. X  (interactive "p")
  557. X  (calc-extensions)
  558. X  (calc-last-args arg)
  559. )
  560. X
  561. X
  562. (defun calc-power (arg)
  563. X  (interactive "P")
  564. X  (calc-slow-wrapper
  565. X   (if (and calc-extensions-loaded
  566. X        (calc-is-inverse))
  567. X       (calc-binary-op "root" 'calcFunc-nroot arg nil nil)
  568. X     (calc-binary-op "^" 'calcFunc-pow arg nil nil '^)))
  569. )
  570. X
  571. (defun calc-mod (arg)
  572. X  (interactive "P")
  573. X  (calc-slow-wrapper
  574. X   (calc-binary-op "%" 'calcFunc-mod arg nil nil '%))
  575. )
  576. X
  577. (defun calc-inv (arg)
  578. X  (interactive "P")
  579. X  (calc-slow-wrapper
  580. X   (calc-unary-op "inv" 'calcFunc-inv arg))
  581. )
  582. X
  583. X
  584. (defun calc-over (n)
  585. X  (interactive "P")
  586. X  (if n
  587. X      (calc-enter (- (prefix-numeric-value n)))
  588. X    (calc-enter -2))
  589. )
  590. X
  591. X
  592. (defun calc-pop-above (n)
  593. X  (interactive "P")
  594. X  (if n
  595. X      (calc-pop (- (prefix-numeric-value n)))
  596. X    (calc-pop -2))
  597. )
  598. X
  599. (defun calc-roll-down (n)
  600. X  (interactive "P")
  601. X  (calc-wrapper
  602. X   (let ((nn (prefix-numeric-value n)))
  603. X     (cond ((null n)
  604. X        (calc-roll-down-stack 2))
  605. X       ((> nn 0)
  606. X        (calc-roll-down-stack nn))
  607. X       ((= nn 0)
  608. X        (calc-pop-push-list (calc-stack-size)
  609. X                (reverse
  610. X                 (calc-top-list (calc-stack-size)))))
  611. X       (t
  612. X        (calc-roll-down-stack (calc-stack-size) (- nn))))))
  613. )
  614. X
  615. (defun calc-roll-up (n)
  616. X  (interactive "P")
  617. X  (calc-wrapper
  618. X   (let ((nn (prefix-numeric-value n)))
  619. X     (cond ((null n)
  620. X        (calc-roll-up-stack 3))
  621. X       ((> nn 0)
  622. X        (calc-roll-up-stack nn))
  623. X       ((= nn 0)
  624. X        (calc-pop-push-list (calc-stack-size)
  625. X                (reverse
  626. X                 (calc-top-list (calc-stack-size)))))
  627. X       (t
  628. X        (calc-roll-up-stack (calc-stack-size) (- nn))))))
  629. )
  630. X
  631. X
  632. X
  633. X
  634. ;;; Other commands.
  635. X
  636. (defun calc-num-prefix-name (n)
  637. X  (cond ((eq n '-) "- ")
  638. X    ((equal n '(4)) "C-u ")
  639. X    ((consp n) (format "%d " (car n)))
  640. X    ((integerp n) (format "%d " n))
  641. X    (t ""))
  642. )
  643. X
  644. (defun calc-missing-key (n)
  645. X  "This is a placeholder for a command which needs to be loaded from calc-ext.
  646. When this key is used, calc-ext (the Calculator extensions module) will be
  647. loaded and the keystroke automatically re-typed."
  648. X  (interactive "P")
  649. X  (calc-extensions)
  650. X  (if (keymapp (key-binding (char-to-string last-command-char)))
  651. X      (message "%s%c-" (calc-num-prefix-name n) last-command-char))
  652. X  (setq unread-command-char last-command-char
  653. X    prefix-arg n)
  654. )
  655. X
  656. (defun calc-shift-Y-prefix-help ()
  657. X  (interactive)
  658. X  (calc-extensions)
  659. X  (calc-do-prefix-help calc-Y-help-msgs "other" ?Y)
  660. )
  661. X
  662. X
  663. X
  664. X
  665. (defun calcDigit-letter ()
  666. X  (interactive)
  667. X  (if (calc-minibuffer-contains "[-+]?\\(1[1-9]\\|[2-9][0-9]\\)#.*")
  668. X      (progn
  669. X    (setq last-command-char (upcase last-command-char))
  670. X    (calcDigit-key))
  671. X    (calcDigit-nondigit))
  672. )
  673. X
  674. X
  675. ;; A Lisp version of temp_minibuffer_message from minibuf.c.
  676. (defun calc-temp-minibuffer-message (m)
  677. X  (let ((savemax (point-max)))
  678. X    (save-excursion
  679. X      (goto-char (point-max))
  680. X      (insert m))
  681. X    (let ((okay nil))
  682. X      (unwind-protect
  683. X      (progn
  684. X        (sit-for 2)
  685. X        (identity 1)   ; this forces a call to QUIT; in bytecode.c.
  686. X        (setq okay t))
  687. X    (progn
  688. X      (delete-region savemax (point-max))
  689. X      (or okay (abort-recursive-edit))))))
  690. )
  691. X
  692. X
  693. (put 'math-with-extra-prec 'lisp-indent-hook 1)
  694. X
  695. X
  696. ;;; Concatenate two vectors, or a vector and an object.  [V O O] [Public]
  697. (defun math-concat (v1 v2)
  698. X  (if (stringp v1)
  699. X      (concat v1 v2)
  700. X    (calc-extensions)
  701. X    (if (and (or (math-objvecp v1) (math-known-scalarp v1))
  702. X         (or (math-objvecp v2) (math-known-scalarp v2)))
  703. X    (append (if (and (math-vectorp v1)
  704. X             (or (math-matrixp v1)
  705. X                 (not (math-matrixp v2))))
  706. X            v1
  707. X          (list 'vec v1))
  708. X        (if (and (math-vectorp v2)
  709. X             (or (math-matrixp v2)
  710. X                 (not (math-matrixp v1))))
  711. X            (cdr v2)
  712. X          (list v2)))
  713. X      (list '| v1 v2)))
  714. )
  715. X
  716. X
  717. ;;; True if A is zero.  Works for un-normalized values.  [P n] [Public]
  718. (defun math-zerop (a)
  719. X  (if (consp a)
  720. X      (cond ((memq (car a) '(bigpos bigneg))
  721. X         (while (eq (car (setq a (cdr a))) 0))
  722. X         (null a))
  723. X        ((memq (car a) '(frac float polar mod))
  724. X         (math-zerop (nth 1 a)))
  725. X        ((eq (car a) 'cplx)
  726. X         (and (math-zerop (nth 1 a)) (math-zerop (nth 2 a))))
  727. X        ((eq (car a) 'hms)
  728. X         (and (math-zerop (nth 1 a))
  729. X          (math-zerop (nth 2 a))
  730. X          (math-zerop (nth 3 a)))))
  731. X    (eq a 0))
  732. )
  733. X
  734. X
  735. ;;; True if A is real and negative.  [P n] [Public]
  736. X
  737. (defun math-negp (a)
  738. X  (if (consp a)
  739. X      (cond ((eq (car a) 'bigpos) nil)
  740. X        ((eq (car a) 'bigneg) (cdr a))
  741. X        ((memq (car a) '(float frac))
  742. X         (Math-integer-negp (nth 1 a)))
  743. X        ((eq (car a) 'hms)
  744. X         (if (math-zerop (nth 1 a))
  745. X         (if (math-zerop (nth 2 a))
  746. X             (math-negp (nth 3 a))
  747. X           (math-negp (nth 2 a)))
  748. X           (math-negp (nth 1 a))))
  749. X        ((eq (car a) 'date)
  750. X         (math-negp (nth 1 a)))
  751. X        ((eq (car a) 'intv)
  752. X         (or (math-negp (nth 3 a))
  753. X         (and (math-zerop (nth 3 a))
  754. X              (memq (nth 1 a) '(0 2)))))
  755. X        ((equal a '(neg (var inf var-inf))) t))
  756. X    (< a 0))
  757. )
  758. X
  759. ;;; True if A is a negative number or an expression the starts with '-'.
  760. (defun math-looks-negp (a)   ; [P x] [Public]
  761. X  (or (Math-negp a)
  762. X      (eq (car-safe a) 'neg)
  763. X      (and (memq (car-safe a) '(* /))
  764. X       (or (math-looks-negp (nth 1 a))
  765. X           (math-looks-negp (nth 2 a))))
  766. X      (and (eq (car-safe a) '-)
  767. X       (math-looks-negp (nth 1 a))))
  768. )
  769. X
  770. X
  771. ;;; True if A is real and positive.  [P n] [Public]
  772. (defun math-posp (a)
  773. X  (if (consp a)
  774. X      (cond ((eq (car a) 'bigpos) (cdr a))
  775. X        ((eq (car a) 'bigneg) nil)
  776. X        ((memq (car a) '(float frac))
  777. X         (Math-integer-posp (nth 1 a)))
  778. X        ((eq (car a) 'hms)
  779. X         (if (math-zerop (nth 1 a))
  780. X         (if (math-zerop (nth 2 a))
  781. X             (math-posp (nth 3 a))
  782. X           (math-posp (nth 2 a)))
  783. X           (math-posp (nth 1 a))))
  784. X        ((eq (car a) 'date)
  785. X         (math-posp (nth 1 a)))
  786. X        ((eq (car a) 'mod)
  787. X         (not (math-zerop (nth 1 a))))
  788. X        ((eq (car a) 'intv)
  789. X         (or (math-posp (nth 2 a))
  790. X         (and (math-zerop (nth 2 a))
  791. X              (memq (nth 1 a) '(0 1)))))
  792. X        ((equal a '(var inf var-inf)) t))
  793. X    (> a 0))
  794. )
  795. X
  796. (fset 'math-fixnump (symbol-function 'integerp))
  797. (fset 'math-fixnatnump (symbol-function 'natnump))
  798. X
  799. X
  800. ;;; True if A is an even integer.  [P R R] [Public]
  801. (defun math-evenp (a)
  802. X  (if (consp a)
  803. X      (and (memq (car a) '(bigpos bigneg))
  804. X       (= (% (nth 1 a) 2) 0))
  805. X    (= (% a 2) 0))
  806. )
  807. X
  808. ;;; Compute A / 2, for small or big integer A.  [I i]
  809. ;;; If A is negative, type of truncation is undefined.
  810. (defun math-div2 (a)
  811. X  (if (consp a)
  812. X      (if (cdr a)
  813. X      (math-normalize (cons (car a) (math-div2-bignum (cdr a))))
  814. X    0)
  815. X    (/ a 2))
  816. )
  817. X
  818. (defun math-div2-bignum (a)   ; [l l]
  819. X  (if (cdr a)
  820. X      (cons (+ (/ (car a) 2) (* (% (nth 1 a) 2) 500))
  821. X        (math-div2-bignum (cdr a)))
  822. X    (list (/ (car a) 2)))
  823. )
  824. X
  825. X
  826. ;;; Reject an argument to a calculator function.  [Public]
  827. (defun math-reject-arg (&optional a p option)
  828. X  (if option
  829. X      (calc-record-why option p a)
  830. X    (if p
  831. X    (calc-record-why p a)))
  832. X  (signal 'wrong-type-argument (and a (if p (list p a) (list a))))
  833. )
  834. X
  835. X
  836. ;;; Coerce A to be an integer (by truncation toward zero).  [I N] [Public]
  837. (defun math-trunc (a &optional prec)
  838. X  (cond (prec
  839. X     (calc-extensions)
  840. X     (math-trunc-special a prec))
  841. X    ((Math-integerp a) a)
  842. X    ((Math-looks-negp a)
  843. X     (math-neg (math-trunc (math-neg a))))
  844. X    ((eq (car a) 'float)
  845. X     (math-scale-int (nth 1 a) (nth 2 a)))
  846. X    (t (calc-extensions)
  847. X       (math-trunc-fancy a)))
  848. )
  849. (fset 'calcFunc-trunc (symbol-function 'math-trunc))
  850. X
  851. ;;; Coerce A to be an integer (by truncation toward minus infinity).  [I N]
  852. (defun math-floor (a &optional prec)    ;  [Public]
  853. X  (cond (prec
  854. X     (calc-extensions)
  855. X     (math-floor-special a prec))
  856. X    ((Math-integerp a) a)
  857. X    ((Math-messy-integerp a) (math-trunc a))
  858. X    ((Math-realp a)
  859. X     (if (Math-negp a)
  860. X         (math-add (math-trunc a) -1)
  861. X       (math-trunc a)))
  862. X    (t (calc-extensions)
  863. X       (math-floor-fancy a)))
  864. )
  865. (fset 'calcFunc-floor (symbol-function 'math-floor))
  866. X
  867. X
  868. (defun math-imod (a b)   ; [I I I] [Public]
  869. X  (if (and (not (consp a)) (not (consp b)))
  870. X      (if (= b 0)
  871. X      (math-reject-arg a "*Division by zero")
  872. X    (% a b))
  873. X    (cdr (math-idivmod a b)))
  874. )
  875. X
  876. X
  877. (defun calcFunc-inv (m)
  878. X  (if (Math-vectorp m)
  879. X      (progn
  880. X    (calc-extensions)
  881. X    (if (math-square-matrixp m)
  882. X        (or (math-with-extra-prec 2 (math-matrix-inv-raw m))
  883. X        (math-reject-arg m "*Singular matrix"))
  884. X      (math-reject-arg m 'square-matrixp)))
  885. X    (math-div 1 m))
  886. )
  887. X
  888. X
  889. (defun math-do-working (msg arg)
  890. X  (or executing-macro
  891. X      (progn
  892. X    (calc-set-command-flag 'clear-message)
  893. X    (if math-working-step
  894. X        (if math-working-step-2
  895. X        (setq msg (format "[%d/%d] %s"
  896. X                  math-working-step math-working-step-2 msg))
  897. X          (setq msg (format "[%d] %s" math-working-step msg))))
  898. X    (message "Working... %s = %s" msg
  899. X         (math-showing-full-precision (math-format-number arg)))))
  900. )
  901. X
  902. X
  903. ;;; Compute A modulo B, defined in terms of truncation toward minus infinity.
  904. (defun math-mod (a b)   ; [R R R] [Public]
  905. X  (cond ((and (Math-zerop a) (not (eq (car-safe a) 'mod))) a)
  906. X    ((Math-zerop b)
  907. X     (math-reject-arg a "*Division by zero"))
  908. X    ((and (Math-natnump a) (Math-natnump b))
  909. X     (math-imod a b))
  910. X    ((and (Math-anglep a) (Math-anglep b))
  911. X     (math-sub a (math-mul (math-floor (math-div a b)) b)))
  912. X    (t (calc-extensions)
  913. X       (math-mod-fancy a b)))
  914. )
  915. X
  916. X
  917. X
  918. ;;; General exponentiation.
  919. X
  920. (defun math-pow (a b)   ; [O O N] [Public]
  921. X  (cond ((equal b '(var nan var-nan))
  922. X     b)
  923. X    ((Math-zerop a)
  924. X     (if (and (Math-scalarp b) (Math-posp b))
  925. X         (if (math-floatp b) (math-float a) a)
  926. X       (calc-extensions)
  927. X       (math-pow-of-zero a b)))
  928. X    ((or (eq a 1) (eq b 1)) a)
  929. X    ((or (equal a '(float 1 0)) (equal b '(float 1 0))) a)
  930. X    ((Math-zerop b)
  931. X     (if (Math-scalarp a)
  932. X         (if (or (math-floatp a) (math-floatp b))
  933. X         '(float 1 0) 1)
  934. X       (calc-extensions)
  935. X       (math-pow-zero a b)))
  936. X    ((and (Math-integerp b) (or (Math-numberp a) (Math-vectorp a)))
  937. X     (if (and (equal a '(float 1 1)) (integerp b))
  938. X         (math-make-float 1 b)
  939. X       (math-with-extra-prec 2
  940. X         (math-ipow a b))))
  941. X    (t
  942. X     (calc-extensions)
  943. X     (math-pow-fancy a b)))
  944. )
  945. X
  946. (defun math-ipow (a n)   ; [O O I] [Public]
  947. X  (cond ((Math-integer-negp n)
  948. X     (math-ipow (math-div 1 a) (Math-integer-neg n)))
  949. X    ((not (consp n))
  950. X     (if (and (Math-ratp a) (> n 20))
  951. X         (math-iipow-show a n)
  952. X       (math-iipow a n)))
  953. X    ((math-evenp n)
  954. X     (math-ipow (math-mul a a) (math-div2 n)))
  955. X    (t
  956. X     (math-mul a (math-ipow (math-mul a a)
  957. X                (math-div2 (math-add n -1))))))
  958. )
  959. X
  960. (defun math-iipow (a n)   ; [O O S]
  961. X  (cond ((= n 0) 1)
  962. X    ((= n 1) a)
  963. X    ((= (% n 2) 0) (math-iipow (math-mul a a) (/ n 2)))
  964. X    (t (math-mul a (math-iipow (math-mul a a) (/ n 2)))))
  965. )
  966. X
  967. (defun math-iipow-show (a n)   ; [O O S]
  968. X  (math-working "pow" a)
  969. X  (let ((val (cond
  970. X          ((= n 0) 1)
  971. X          ((= n 1) a)
  972. X          ((= (% n 2) 0) (math-iipow-show (math-mul a a) (/ n 2)))
  973. X          (t (math-mul a (math-iipow-show (math-mul a a) (/ n 2)))))))
  974. X    (math-working "pow" val)
  975. X    val)
  976. )
  977. X
  978. X
  979. (defun math-read-radix-digit (dig)   ; [D S; Z S]
  980. X  (if (> dig ?9)
  981. X      (if (< dig ?A)
  982. X      nil
  983. X    (- dig 55))
  984. X    (if (>= dig ?0)
  985. X    (- dig ?0)
  986. X      nil))
  987. )
  988. X
  989. X
  990. X
  991. X
  992. X
  993. ;;; Bug reporting
  994. X
  995. (defun report-calc-bug (topic)
  996. X  "Report a bug in Calc, the GNU Emacs calculator.
  997. Prompts for bug subject.  Leaves you in a mail buffer."
  998. X  (interactive "sBug Subject: ")
  999. X  (mail nil calc-bug-address topic)
  1000. X  (goto-char (point-max))
  1001. X  (insert "\nIn Calc " calc-version ", Emacs " (emacs-version) "\n\n")
  1002. X  (message (substitute-command-keys "Type \\[mail-send] to send bug report."))
  1003. )
  1004. (fset 'calc-report-bug (symbol-function 'report-calc-bug))
  1005. X
  1006. SHAR_EOF
  1007. chmod 0644 calc-misc.el ||
  1008. echo 'restore of calc-misc.el failed'
  1009. Wc_c="`wc -c < 'calc-misc.el'`"
  1010. test 24690 -eq "$Wc_c" ||
  1011.     echo 'calc-misc.el: original size 24690, current size' "$Wc_c"
  1012. rm -f _shar_wnt_.tmp
  1013. fi
  1014. # ============= calc-mode.el ==============
  1015. if test -f 'calc-mode.el' -a X"$1" != X"-c"; then
  1016.     echo 'x - skipping calc-mode.el (File already exists)'
  1017.     rm -f _shar_wnt_.tmp
  1018. else
  1019. > _shar_wnt_.tmp
  1020. echo 'x - extracting calc-mode.el (Text)'
  1021. sed 's/^X//' << 'SHAR_EOF' > 'calc-mode.el' &&
  1022. ;; Calculator for GNU Emacs, part II [calc-mode.el]
  1023. ;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  1024. ;; Written by Dave Gillespie, daveg@csvax.cs.caltech.edu.
  1025. X
  1026. ;; This file is part of GNU Emacs.
  1027. X
  1028. ;; GNU Emacs is distributed in the hope that it will be useful,
  1029. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  1030. ;; accepts responsibility to anyone for the consequences of using it
  1031. ;; or for whether it serves any particular purpose or works at all,
  1032. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  1033. ;; License for full details.
  1034. X
  1035. ;; Everyone is granted permission to copy, modify and redistribute
  1036. ;; GNU Emacs, but only under the conditions described in the
  1037. ;; GNU Emacs General Public License.   A copy of this license is
  1038. ;; supposed to have been given to you along with GNU Emacs so you
  1039. ;; can know your rights and responsibilities.  It should be in a
  1040. ;; file named COPYING.  Among other things, the copyright notice
  1041. ;; and this notice must be preserved on all copies.
  1042. X
  1043. X
  1044. X
  1045. ;; This file is autoloaded from calc-ext.el.
  1046. (require 'calc-ext)
  1047. X
  1048. (require 'calc-macs)
  1049. X
  1050. (defun calc-Need-calc-mode () nil)
  1051. X
  1052. X
  1053. (defun calc-line-numbering (n)
  1054. X  (interactive "P")
  1055. X  (calc-wrapper
  1056. X   (message (if (calc-change-mode 'calc-line-numbering n t t)
  1057. X        "Displaying stack level numbers."
  1058. X          "Hiding stack level numbers.")))
  1059. )
  1060. X
  1061. (defun calc-line-breaking (n)
  1062. X  (interactive "P")
  1063. X  (calc-wrapper
  1064. X   (setq n (if n
  1065. X           (and (> (setq n (prefix-numeric-value n)) 0)
  1066. X            (or (< n 5)
  1067. X            n))
  1068. X         (not calc-line-breaking)))
  1069. X   (if (calc-change-mode 'calc-line-breaking n t)
  1070. X       (if (integerp calc-line-breaking)
  1071. X       (message "Breaking lines longer than %d characters." n)
  1072. X     (message "Breaking long lines in Stack display."))
  1073. X     (message "Not breaking long lines in Stack display.")))
  1074. )
  1075. X
  1076. X
  1077. (defun calc-left-justify (n)
  1078. X  (interactive "P")
  1079. X  (calc-wrapper
  1080. X   (and n (setq n (prefix-numeric-value n)))
  1081. X   (calc-change-mode '(calc-display-just calc-display-origin)
  1082. X             (list nil n) t)
  1083. X   (if n
  1084. X       (message "Displaying stack entries indented by %d." n)
  1085. X     (message "Displaying stack entries left-justified.")))
  1086. )
  1087. X
  1088. (defun calc-center-justify (n)
  1089. X  (interactive "P")
  1090. X  (calc-wrapper
  1091. X   (and n (setq n (prefix-numeric-value n)))
  1092. X   (calc-change-mode '(calc-display-just calc-display-origin)
  1093. X             (list 'center n) t)
  1094. X   (if n
  1095. X       (message "Displaying stack entries centered on column %d." n)
  1096. X     (message "Displaying stack entries centered in window.")))
  1097. )
  1098. X
  1099. (defun calc-right-justify (n)
  1100. X  (interactive "P")
  1101. X  (calc-wrapper
  1102. X   (and n (setq n (prefix-numeric-value n)))
  1103. X   (calc-change-mode '(calc-display-just calc-display-origin)
  1104. X             (list 'right n) t)
  1105. X   (if n
  1106. X       (message "Displaying stack entries right-justified to column %d." n)
  1107. X     (message "Displaying stack entries right-justified in window.")))
  1108. )
  1109. X
  1110. (defun calc-left-label (s)
  1111. X  (interactive "sLefthand label: ")
  1112. X  (calc-wrapper
  1113. X   (or (equal s "")
  1114. X       (setq s (concat s " ")))
  1115. X   (calc-change-mode 'calc-left-label s t))
  1116. )
  1117. X
  1118. (defun calc-right-label (s)
  1119. X  (interactive "sRighthand label: ")
  1120. X  (calc-wrapper
  1121. X   (or (equal s "")
  1122. X       (setq s (concat " " s)))
  1123. X   (calc-change-mode 'calc-right-label s t))
  1124. )
  1125. X
  1126. (defun calc-auto-why (n)
  1127. X  (interactive "P")
  1128. X  (calc-wrapper
  1129. X   (if n
  1130. X       (progn
  1131. X     (setq n (prefix-numeric-value n))
  1132. X     (if (<= n 0) (setq n nil)
  1133. X       (if (> n 1) (setq n t))))
  1134. X     (setq n (and (not (eq calc-auto-why t)) (if calc-auto-why t 1))))
  1135. X   (calc-change-mode 'calc-auto-why n nil)
  1136. X   (cond ((null n)
  1137. X      (message "User must press `w' to explain unsimplified results."))
  1138. X     ((eq n t)
  1139. X      (message "Automatically doing `w' to explain unsimplified results."))
  1140. X     (t
  1141. X      (message "Automatically doing `w' only for unusual messages."))))
  1142. )
  1143. X
  1144. (defun calc-group-digits (n)
  1145. X  (interactive "P")
  1146. X  (calc-wrapper
  1147. X   (if n
  1148. X       (progn
  1149. X     (setq n (prefix-numeric-value n))
  1150. X     (cond ((or (> n 0) (< n -1)))
  1151. X           ((= n -1)
  1152. X        (setq n nil))
  1153. X           (t
  1154. X        (setq n calc-group-digits))))
  1155. X     (setq n (not calc-group-digits)))
  1156. X   (calc-change-mode 'calc-group-digits n t)
  1157. X   (cond ((null n)
  1158. X      (message "Grouping is off."))
  1159. X     ((integerp n)
  1160. X      (message "Grouping every %d digits." (math-abs n)))
  1161. X     (t
  1162. X      (message "Grouping is on."))))
  1163. )
  1164. X
  1165. (defun calc-group-char (ch)
  1166. X  (interactive "cGrouping character: ")
  1167. X  (calc-wrapper
  1168. X   (or (>= ch 32)
  1169. X       (error "Control characters not allowed for grouping."))
  1170. X   (if (= ch ?\\)
  1171. X       (setq ch "\\,")
  1172. X     (setq ch (char-to-string ch)))
  1173. X   (calc-change-mode 'calc-group-char ch calc-group-digits)
  1174. X   (message "Digit grouping character is \"%s\"." ch))
  1175. )
  1176. X
  1177. (defun calc-point-char (ch)
  1178. X  (interactive "cCharacter to use as decimal point: ")
  1179. X  (calc-wrapper
  1180. X   (or (>= ch 32)
  1181. X       (error "Control characters not allowed as decimal point."))
  1182. X   (calc-change-mode 'calc-point-char (char-to-string ch) t)
  1183. X   (message "Decimal point character is \"%c\"." ch))
  1184. )
  1185. X
  1186. (defun calc-normal-notation (n)
  1187. X  (interactive "P")
  1188. X  (calc-wrapper
  1189. X   (calc-change-mode 'calc-float-format
  1190. X             (setq n (list 'float (if n (prefix-numeric-value n) 0)))
  1191. X             t)
  1192. X   (if (eq (nth 1 n) 0)
  1193. X       (message "Displaying floating-point numbers normally.")
  1194. X     (if (> (nth 1 n) 0)
  1195. X     (message
  1196. X      "Displaying floating-point numbers with %d significant digits."
  1197. X      (nth 1 n))
  1198. X       (message "Displaying floating-point numbers with (precision%d)."
  1199. X        (nth 1 n)))))
  1200. )
  1201. X
  1202. (defun calc-fix-notation (n)
  1203. X  (interactive "NDigits after decimal point: ")
  1204. X  (calc-wrapper
  1205. X   (calc-change-mode 'calc-float-format
  1206. X             (setq n (list 'fix (if n (prefix-numeric-value n) 0)))
  1207. X             t)
  1208. X   (message "Displaying floats with %d digits after decimal."
  1209. X        (math-abs (nth 1 n))))
  1210. )
  1211. X
  1212. (defun calc-sci-notation (n)
  1213. X  (interactive "P")
  1214. X  (calc-wrapper
  1215. X   (calc-change-mode 'calc-float-format
  1216. X             (setq n (list 'sci (if n (prefix-numeric-value n) 0)))
  1217. X             t)
  1218. X   (if (eq (nth 1 n) 0)
  1219. X       (message "Displaying floats in scientific notation.")
  1220. X     (if (> (nth 1 n) 0)
  1221. X     (message "Displaying scientific notation with %d significant digits."
  1222. X          (nth 1 n))
  1223. X       (message "Displaying scientific notation with (precision%d)."
  1224. X        (nth 1 n)))))
  1225. )
  1226. X
  1227. (defun calc-eng-notation (n)
  1228. X  (interactive "P")
  1229. X  (calc-wrapper
  1230. X   (calc-change-mode 'calc-float-format
  1231. X             (setq n (list 'eng (if n (prefix-numeric-value n) 0)))
  1232. X             t)
  1233. X   (if (eq (nth 1 n) 0)
  1234. X       (message "Displaying floats in engineering notation.")
  1235. X     (if (> (nth 1 n) 0)
  1236. X     (message "Displaying engineering notation with %d significant digits."
  1237. X          (nth 1 n))
  1238. X       (message "Displaying engineering notation with (precision%d)."
  1239. X        (nth 1 n)))))
  1240. )
  1241. X
  1242. X
  1243. (defun calc-truncate-stack (n &optional rel)
  1244. X  (interactive "P")
  1245. X  (calc-wrapper
  1246. X   (let ((oldtop calc-stack-top)
  1247. X     (newtop calc-stack-top))
  1248. X     (calc-record-undo (list 'set 'saved-stack-top calc-stack-top))
  1249. X     (let ((calc-stack-top 0)
  1250. X       (nn (prefix-numeric-value n)))
  1251. X       (setq newtop
  1252. X         (if n
  1253. X         (progn
  1254. X           (if rel
  1255. X               (setq nn (+ oldtop nn))
  1256. X             (if (< nn 0)
  1257. X             (setq nn (+ nn (calc-stack-size)))
  1258. X               (setq nn (1+ nn))))
  1259. X           (if (< nn 1)
  1260. X               1
  1261. X             (if (> nn (calc-stack-size))
  1262. X             (calc-stack-size)
  1263. X               nn)))
  1264. X           (max 1 (calc-locate-cursor-element (point)))))
  1265. X       (if (= newtop oldtop)
  1266. X       ()
  1267. X     (calc-pop-stack 1 oldtop t)
  1268. X     (calc-push-list '(top-of-stack) newtop)
  1269. X     (if calc-line-numbering
  1270. X         (calc-refresh))))
  1271. X     (calc-record-undo (list 'set 'saved-stack-top 0))
  1272. X     (setq calc-stack-top newtop)))
  1273. )
  1274. X
  1275. (defun calc-truncate-up (n)
  1276. X  (interactive "p")
  1277. X  (calc-truncate-stack n t)
  1278. )
  1279. X
  1280. (defun calc-truncate-down (n)
  1281. X  (interactive "p")
  1282. X  (calc-truncate-stack (- n) t)
  1283. )
  1284. X
  1285. (defun calc-display-raw (arg)
  1286. X  (interactive "P")
  1287. X  (calc-wrapper
  1288. X   (setq calc-display-raw (if calc-display-raw nil (if arg 0 t)))
  1289. X   (calc-do-refresh)
  1290. X   (if calc-display-raw
  1291. X       (message "Press d ' again to cancel \"raw\" display mode.")))
  1292. )
  1293. X
  1294. X
  1295. X
  1296. X
  1297. ;;; Mode commands.
  1298. X
  1299. (defun calc-save-modes (&optional quiet)
  1300. X  (interactive)
  1301. X  (calc-wrapper
  1302. X   (let (pos
  1303. X     (vals (mapcar (function (lambda (v) (symbol-value (car v))))
  1304. X               calc-mode-var-list)))
  1305. X     (set-buffer (find-file-noselect (substitute-in-file-name
  1306. X                      calc-settings-file)))
  1307. X     (goto-char (point-min))
  1308. X     (if (and (search-forward ";;; Mode settings stored by Calc" nil t)
  1309. X          (progn
  1310. X        (beginning-of-line)
  1311. X        (setq pos (point))
  1312. X        (search-forward "\n;;; End of mode settings" nil t)))
  1313. X     (progn
  1314. X       (beginning-of-line)
  1315. X       (forward-line 1)
  1316. X       (delete-region pos (point)))
  1317. X       (goto-char (point-max))
  1318. X       (insert "\n\n")
  1319. X       (forward-char -1))
  1320. X     (insert ";;; Mode settings stored by Calc on " (current-time-string) "\n")
  1321. X     (let ((list calc-mode-var-list))
  1322. X       (while list
  1323. X     (let* ((v (car (car list)))
  1324. X        (def (nth 1 (car list)))
  1325. X        (val (car vals)))
  1326. X       (or (equal val def)
  1327. X           (progn
  1328. X         (insert "(setq " (symbol-name v) " ")
  1329. X         (if (and (or (listp val)
  1330. X                  (symbolp val))
  1331. X              (not (memq val '(nil t))))
  1332. X             (insert "'"))
  1333. X         (insert (prin1-to-string val) ")\n"))))
  1334. X     (setq list (cdr list)
  1335. X           vals (cdr vals))))
  1336. X     (run-hooks 'calc-mode-save-hook)
  1337. X     (insert ";;; End of mode settings\n")
  1338. X     (if quiet
  1339. X     (let ((executing-macro ""))   ; what a kludge!
  1340. X       (save-buffer))
  1341. X       (save-buffer))))
  1342. )
  1343. X
  1344. (defun calc-settings-file-name (name &optional arg)
  1345. X  (interactive "sSettings file name (normally ~/.emacs): \nP")
  1346. X  (calc-wrapper
  1347. X   (setq arg (if arg (prefix-numeric-value arg) 0))
  1348. X   (if (equal name "")
  1349. X       (message "Calc settings file is \"%s\"" calc-settings-file)
  1350. X     (if (< (math-abs arg) 2)
  1351. X     (let ((list calc-mode-var-list))
  1352. X       (while list
  1353. X         (set (car (car list)) (nth 1 (car list)))
  1354. X         (setq list (cdr list)))))
  1355. X     (setq calc-settings-file name)
  1356. X     (or (and (string-match "\\.emacs" calc-settings-file)
  1357. X          (> arg 0))
  1358. X     (< arg 0)
  1359. X     (load name t)
  1360. X     (message "New file"))))
  1361. )
  1362. X
  1363. (defun calc-shift-prefix (arg)
  1364. X  (interactive "P")
  1365. X  (calc-wrapper
  1366. X   (setq calc-shift-prefix (if arg
  1367. X                   (> (prefix-numeric-value arg) 0)
  1368. X                 (not calc-shift-prefix)))
  1369. X   (calc-init-prefixes)
  1370. X   (message (if calc-shift-prefix
  1371. X        "Prefix keys are now case-insensitive"
  1372. X          "Prefix keys must be unshifted (except V, Z)")))
  1373. )
  1374. X
  1375. (defun calc-mode-record-mode (n)
  1376. X  (interactive "P")
  1377. X  (calc-wrapper
  1378. X   (calc-change-mode 'calc-mode-save-mode
  1379. X             (cond ((null n)
  1380. X                (cond ((not calc-embedded-info)
  1381. X                   (if (eq calc-mode-save-mode 'save)
  1382. X                       'local 'save))
  1383. X                  ((eq calc-mode-save-mode 'local)  'edit)
  1384. X                  ((eq calc-mode-save-mode 'edit)   'perm)
  1385. X                  ((eq calc-mode-save-mode 'perm)   'global)
  1386. X                  ((eq calc-mode-save-mode 'global) 'save)
  1387. X                  ((eq calc-mode-save-mode 'save)   nil)
  1388. X                  ((eq calc-mode-save-mode nil)     'local)))
  1389. X               ((= (setq n (prefix-numeric-value n)) 0) nil)
  1390. X               ((= n 2) 'edit)
  1391. X               ((= n 3) 'perm)
  1392. X               ((= n 4) 'global)
  1393. X               ((= n 5) 'save)
  1394. X               (t 'local)))
  1395. X   (message (cond ((and (eq calc-mode-save-mode 'local) calc-embedded-info)
  1396. X           "Recording mode changes with [calc-mode: ...]")
  1397. X          ((eq calc-mode-save-mode 'edit)
  1398. X           "Recording mode changes with [calc-edit-mode: ...]")
  1399. X          ((eq calc-mode-save-mode 'perm)
  1400. X           "Recording mode changes with [calc-perm-mode: ...]")
  1401. X          ((eq calc-mode-save-mode 'global)
  1402. X           "Recording mode changes with [calc-global-mode: ...]")
  1403. X          ((eq calc-mode-save-mode 'save)
  1404. X           (format "Recording mode changes in \"%s\"."
  1405. X               calc-settings-file))
  1406. X          (t
  1407. X           "Not recording mode changes permanently."))))
  1408. )
  1409. X
  1410. (defun calc-total-algebraic-mode (flag)
  1411. X  (interactive "P")
  1412. X  (calc-wrapper
  1413. X   (if (eq calc-algebraic-mode 'total)
  1414. X       (calc-algebraic-mode nil)
  1415. X     (calc-change-mode '(calc-algebraic-mode calc-incomplete-algebraic-mode)
  1416. X               '(total nil))
  1417. X     (use-local-map calc-alg-map)
  1418. X     (message
  1419. X      "All keys begin algebraic entry; use Meta (ESC) for Calc keys.")))
  1420. )
  1421. X
  1422. (defun calc-algebraic-mode (flag)
  1423. X  (interactive "P")
  1424. X  (calc-wrapper
  1425. X   (if flag
  1426. X       (calc-change-mode '(calc-algebraic-mode
  1427. X               calc-incomplete-algebraic-mode)
  1428. X             (list nil (not calc-incomplete-algebraic-mode)))
  1429. X     (calc-change-mode '(calc-algebraic-mode calc-incomplete-algebraic-mode)
  1430. X               (list (not calc-algebraic-mode) nil)))
  1431. X   (use-local-map calc-mode-map)
  1432. X   (message (if calc-algebraic-mode
  1433. X        "Numeric keys and ( and [ begin algebraic entry."
  1434. X          (if calc-incomplete-algebraic-mode
  1435. X          "Only ( and [ begin algebraic entry."
  1436. X        "No keys except ' and $ begin algebraic entry."))))
  1437. )
  1438. X
  1439. (defun calc-symbolic-mode (n)
  1440. X  (interactive "P")
  1441. X  (calc-wrapper
  1442. X   
  1443. X   (message (if (calc-change-mode 'calc-symbolic-mode n nil t)
  1444. X        "Inexact computations like sqrt(2) are deferred."
  1445. X          "Numerical computations are always done immediately.")))
  1446. )
  1447. X
  1448. (defun calc-infinite-mode (n)
  1449. X  (interactive "P")
  1450. X  (calc-wrapper
  1451. X   (if (eq n 0)
  1452. X       (progn
  1453. X     (calc-change-mode 'calc-infinite-mode 1)
  1454. X     (message "Computations like 1 / 0 produce \"inf\"."))
  1455. X     (message (if (calc-change-mode 'calc-infinite-mode n nil t)
  1456. X          "Computations like 1 / 0 produce \"uinf\"."
  1457. X        "Computations like 1 / 0 are left unsimplified."))))
  1458. )
  1459. X
  1460. (defun calc-matrix-mode (arg)
  1461. X  (interactive "P")
  1462. X  (calc-wrapper
  1463. X   (calc-change-mode 'calc-matrix-mode
  1464. X             (cond ((eq arg 0) 'scalar)
  1465. X               ((< (prefix-numeric-value arg) 1)
  1466. X                (error "Dimension must be 1 or more"))
  1467. X               (arg (prefix-numeric-value arg))
  1468. X               ((eq calc-matrix-mode 'matrix) 'scalar)
  1469. X               ((eq calc-matrix-mode 'scalar) nil)
  1470. X               (t 'matrix)))
  1471. X   (if (integerp calc-matrix-mode)
  1472. X       (message "Variables are assumed to be %dx%d matrices."
  1473. X        calc-matrix-mode calc-matrix-mode)
  1474. X     (message (if (eq calc-matrix-mode 'matrix)
  1475. X          "Variables are assumed to be matrices."
  1476. X        (if calc-matrix-mode
  1477. X            "Variables are assumed to be scalars (non-matrices)."
  1478. X          "Variables are not assumed to be matrix or scalar.")))))
  1479. )
  1480. X
  1481. (defun calc-set-simplify-mode (mode arg msg)
  1482. X  (calc-change-mode 'calc-simplify-mode
  1483. X            (if arg
  1484. X            (and (> (prefix-numeric-value arg) 0)
  1485. X                 mode)
  1486. X              (and (not (eq calc-simplify-mode mode))
  1487. X               mode)))
  1488. X  (message (if (eq calc-simplify-mode mode)
  1489. X           msg
  1490. X         "Default simplifications enabled."))
  1491. )
  1492. X
  1493. (defun calc-no-simplify-mode (arg)
  1494. X  (interactive "P")
  1495. X  (calc-wrapper
  1496. X   (calc-set-simplify-mode 'none arg
  1497. X               "All default simplifications are disabled."))
  1498. )
  1499. X
  1500. (defun calc-num-simplify-mode (arg)
  1501. X  (interactive "P")
  1502. X  (calc-wrapper
  1503. X   (calc-set-simplify-mode 'num arg
  1504. X               "Default simplifications apply only if arguments are numeric."))
  1505. )
  1506. X
  1507. (defun calc-default-simplify-mode ()
  1508. X  (interactive)
  1509. X  (calc-wrapper
  1510. X   (calc-set-simplify-mode nil nil "Usual default simplifications are enabled."))
  1511. )
  1512. X
  1513. (defun calc-bin-simplify-mode (arg)
  1514. X  (interactive "P")
  1515. X  (calc-wrapper
  1516. X   (calc-set-simplify-mode 'binary arg
  1517. X               (format "Binary simplification occurs by default (word size=%d)."
  1518. X                   calc-word-size)))
  1519. )
  1520. X
  1521. (defun calc-alg-simplify-mode (arg)
  1522. X  (interactive "P")
  1523. X  (calc-wrapper
  1524. X   (calc-set-simplify-mode 'alg arg
  1525. X               "Algebraic simplification occurs by default."))
  1526. )
  1527. X
  1528. (defun calc-ext-simplify-mode (arg)
  1529. X  (interactive "P")
  1530. X  (calc-wrapper
  1531. X   (calc-set-simplify-mode 'ext arg
  1532. X               "Extended algebraic simplification occurs by default."))
  1533. )
  1534. X
  1535. (defun calc-units-simplify-mode (arg)
  1536. X  (interactive "P")
  1537. X  (calc-wrapper
  1538. X   (calc-set-simplify-mode 'units arg
  1539. X               "Units simplification occurs by default."))
  1540. )
  1541. X
  1542. (defun calc-auto-recompute (arg)
  1543. X  (interactive "P")
  1544. X  (calc-wrapper
  1545. X   (calc-change-mode 'calc-auto-recompute arg nil t)
  1546. X   (calc-refresh-evaltos)
  1547. X   (message (if calc-auto-recompute
  1548. X        "Automatically recomputing `=>' forms when necessary."
  1549. X          "Not recomputing `=>' forms automatically.")))
  1550. )
  1551. X
  1552. (defun calc-working (n)
  1553. X  (interactive "P")
  1554. X  (calc-wrapper
  1555. X   (cond ((consp n)
  1556. X      (calc-pop-push-record 0 "work"
  1557. X                (cond ((eq calc-display-working-message t) 1)
  1558. X                      (calc-display-working-message 2)
  1559. X                      (t 0))))
  1560. X     ((eq n 2) (calc-change-mode 'calc-display-working-message 'lots))
  1561. X     ((eq n 0) (calc-change-mode 'calc-display-working-message nil))
  1562. X     ((eq n 1) (calc-change-mode 'calc-display-working-message t)))
  1563. X   (cond ((eq calc-display-working-message t)
  1564. X      (message "\"Working...\" messages enabled."))
  1565. X     (calc-display-working-message
  1566. X      (message "Detailed \"Working...\" messages enabled."))
  1567. X     (t
  1568. X      (message "\"Working...\" messages disabled."))))
  1569. )
  1570. X
  1571. (defun calc-always-load-extensions ()
  1572. X  (interactive)
  1573. X  (calc-wrapper
  1574. X   (if (setq calc-always-load-extensions (not calc-always-load-extensions))
  1575. X       (message "Always loading extensions package.")
  1576. X     (message "Loading extensions package on demand only.")))
  1577. )
  1578. X
  1579. X
  1580. (defun calc-matrix-left-justify ()
  1581. X  (interactive)
  1582. X  (calc-wrapper
  1583. X   (calc-change-mode 'calc-matrix-just nil t)
  1584. X   (message "Matrix elements will be left-justified in columns."))
  1585. )
  1586. X
  1587. (defun calc-matrix-center-justify ()
  1588. X  (interactive)
  1589. X  (calc-wrapper
  1590. X   (calc-change-mode 'calc-matrix-just 'center t)
  1591. X   (message "Matrix elements will be centered in columns."))
  1592. )
  1593. X
  1594. (defun calc-matrix-right-justify ()
  1595. X  (interactive)
  1596. X  (calc-wrapper
  1597. X   (calc-change-mode 'calc-matrix-just 'right t)
  1598. X   (message "Matrix elements will be right-justified in columns."))
  1599. )
  1600. X
  1601. (defun calc-full-vectors (n)
  1602. X  (interactive "P")
  1603. X  (calc-wrapper
  1604. X   (message (if (calc-change-mode 'calc-full-vectors n t t)
  1605. X        "Displaying long vectors in full."
  1606. X          "Displaying long vectors in [a, b, c, ..., z] notation.")))
  1607. )
  1608. X
  1609. (defun calc-full-trail-vectors (n)
  1610. X  (interactive "P")
  1611. X  (calc-wrapper
  1612. X   (message (if (calc-change-mode 'calc-full-trail-vectors n nil t)
  1613. X        "Recording long vectors in full."
  1614. X          "Recording long vectors in [a, b, c, ..., z] notation.")))
  1615. )
  1616. X
  1617. (defun calc-break-vectors (n)
  1618. X  (interactive "P")
  1619. X  (calc-wrapper
  1620. X   (message (if (calc-change-mode 'calc-break-vectors n t t)
  1621. X        "Displaying vector elements one-per-line."
  1622. X          "Displaying vector elements all on one line.")))
  1623. )
  1624. X
  1625. (defun calc-vector-commas ()
  1626. X  (interactive)
  1627. X  (calc-wrapper
  1628. X   (if (calc-change-mode 'calc-vector-commas (if calc-vector-commas nil ",") t)
  1629. X       (message "Separating vector elements with \",\".")
  1630. X     (message "Separating vector elements with spaces.")))
  1631. )
  1632. X
  1633. (defun calc-vector-brackets ()
  1634. X  (interactive)
  1635. X  (calc-wrapper
  1636. X   (if (calc-change-mode 'calc-vector-brackets
  1637. X             (if (equal calc-vector-brackets "[]") nil "[]") t)
  1638. X       (message "Surrounding vectors with \"[]\".")
  1639. X     (message "Not surrounding vectors with brackets.")))
  1640. )
  1641. X
  1642. (defun calc-vector-braces ()
  1643. X  (interactive)
  1644. X  (calc-wrapper
  1645. X   (if (calc-change-mode 'calc-vector-brackets
  1646. X             (if (equal calc-vector-brackets "{}") nil "{}") t)
  1647. X       (message "Surrounding vectors with \"{}\".")
  1648. X     (message "Not surrounding vectors with brackets.")))
  1649. )
  1650. X
  1651. (defun calc-vector-parens ()
  1652. X  (interactive)
  1653. X  (calc-wrapper
  1654. X   (if (calc-change-mode 'calc-vector-brackets
  1655. X             (if (equal calc-vector-brackets "()") nil "()") t)
  1656. X       (message "Surrounding vectors with \"()\".")
  1657. X     (message "Not surrounding vectors with brackets.")))
  1658. )
  1659. X
  1660. (defun calc-matrix-brackets (arg)
  1661. X  (interactive "sCode letters (R, O, C, P): ")
  1662. X  (calc-wrapper
  1663. X   (let ((code (append (and (string-match "[rR]" arg) '(R))
  1664. X               (and (string-match "[oO]" arg) '(O))
  1665. X               (and (string-match "[cC]" arg) '(C))
  1666. X               (and (string-match "[pP]" arg) '(P))))
  1667. X     (bad (string-match "[^rRoOcCpP ]" arg)))
  1668. X     (if bad
  1669. X     (error "Unrecognized character: %c" (aref arg bad)))
  1670. X     (calc-change-mode 'calc-matrix-brackets code t)))
  1671. )
  1672. X
  1673. SHAR_EOF
  1674. chmod 0644 calc-mode.el ||
  1675. echo 'restore of calc-mode.el failed'
  1676. Wc_c="`wc -c < 'calc-mode.el'`"
  1677. test 19361 -eq "$Wc_c" ||
  1678.     echo 'calc-mode.el: original size 19361, current size' "$Wc_c"
  1679. rm -f _shar_wnt_.tmp
  1680. fi
  1681. # ============= calc-poly.el ==============
  1682. if test -f 'calc-poly.el' -a X"$1" != X"-c"; then
  1683.     echo 'x - skipping calc-poly.el (File already exists)'
  1684.     rm -f _shar_wnt_.tmp
  1685. else
  1686. > _shar_wnt_.tmp
  1687. echo 'x - extracting calc-poly.el (Text)'
  1688. sed 's/^X//' << 'SHAR_EOF' > 'calc-poly.el' &&
  1689. ;; Calculator for GNU Emacs, part II [calc-poly.el]
  1690. ;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  1691. ;; Written by Dave Gillespie, daveg@csvax.cs.caltech.edu.
  1692. X
  1693. ;; This file is part of GNU Emacs.
  1694. X
  1695. ;; GNU Emacs is distributed in the hope that it will be useful,
  1696. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  1697. ;; accepts responsibility to anyone for the consequences of using it
  1698. ;; or for whether it serves any particular purpose or works at all,
  1699. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  1700. ;; License for full details.
  1701. X
  1702. ;; Everyone is granted permission to copy, modify and redistribute
  1703. ;; GNU Emacs, but only under the conditions described in the
  1704. ;; GNU Emacs General Public License.   A copy of this license is
  1705. ;; supposed to have been given to you along with GNU Emacs so you
  1706. ;; can know your rights and responsibilities.  It should be in a
  1707. ;; file named COPYING.  Among other things, the copyright notice
  1708. ;; and this notice must be preserved on all copies.
  1709. X
  1710. X
  1711. X
  1712. ;; This file is autoloaded from calc-ext.el.
  1713. (require 'calc-ext)
  1714. X
  1715. (require 'calc-macs)
  1716. X
  1717. (defun calc-Need-calc-poly () nil)
  1718. X
  1719. X
  1720. (defun calcFunc-pcont (expr &optional var)
  1721. X  (cond ((Math-primp expr)
  1722. X     (cond ((Math-zerop expr) 1)
  1723. X           ((Math-messy-integerp expr) (math-trunc expr))
  1724. X           ((Math-objectp expr) expr)
  1725. X           ((or (equal expr var) (not var)) 1)
  1726. X           (t expr)))
  1727. X    ((eq (car expr) '*)
  1728. X     (math-mul (calcFunc-pcont (nth 1 expr) var)
  1729. X           (calcFunc-pcont (nth 2 expr) var)))
  1730. X    ((eq (car expr) '/)
  1731. X     (math-div (calcFunc-pcont (nth 1 expr) var)
  1732. X           (calcFunc-pcont (nth 2 expr) var)))
  1733. X    ((and (eq (car expr) '^) (Math-natnump (nth 2 expr)))
  1734. X     (math-pow (calcFunc-pcont (nth 1 expr) var) (nth 2 expr)))
  1735. X    ((memq (car expr) '(neg polar))
  1736. X     (calcFunc-pcont (nth 1 expr) var))
  1737. X    ((consp var)
  1738. X     (let ((p (math-is-polynomial expr var)))
  1739. X       (if p
  1740. X           (let ((lead (nth (1- (length p)) p))
  1741. X             (cont (math-poly-gcd-list p)))
  1742. X         (if (math-guess-if-neg lead)
  1743. X             (math-neg cont)
  1744. X           cont))
  1745. X         1)))
  1746. X    ((memq (car expr) '(+ - cplx sdev))
  1747. X     (let ((cont (calcFunc-pcont (nth 1 expr) var)))
  1748. X       (if (eq cont 1)
  1749. X           1
  1750. X         (let ((c2 (calcFunc-pcont (nth 2 expr) var)))
  1751. X           (if (and (math-negp cont)
  1752. X            (if (eq (car expr) '-) (math-posp c2) (math-negp c2)))
  1753. X           (math-neg (math-poly-gcd cont c2))
  1754. X         (math-poly-gcd cont c2))))))
  1755. X    (var expr)
  1756. X    (t 1))
  1757. )
  1758. X
  1759. (defun calcFunc-pprim (expr &optional var)
  1760. X  (let ((cont (calcFunc-pcont expr var)))
  1761. X    (if (math-equal-int cont 1)
  1762. X    expr
  1763. X      (math-poly-div-exact expr cont var)))
  1764. )
  1765. X
  1766. (defun math-div-poly-const (expr c)
  1767. X  (cond ((memq (car-safe expr) '(+ -))
  1768. X     (list (car expr)
  1769. X           (math-div-poly-const (nth 1 expr) c)
  1770. X           (math-div-poly-const (nth 2 expr) c)))
  1771. X    (t (math-div expr c)))
  1772. )
  1773. X
  1774. (defun calcFunc-pdeg (expr &optional var)
  1775. X  (if (Math-zerop expr)
  1776. X      '(neg (var inf var-inf))
  1777. X    (if var
  1778. X    (or (math-polynomial-p expr var)
  1779. X        (math-reject-arg expr "Expected a polynomial"))
  1780. X      (math-poly-degree expr)))
  1781. )
  1782. X
  1783. (defun math-poly-degree (expr)
  1784. X  (cond ((Math-primp expr)
  1785. X     (if (eq (car-safe expr) 'var) 1 0))
  1786. X    ((eq (car expr) 'neg)
  1787. X     (math-poly-degree (nth 1 expr)))
  1788. X    ((eq (car expr) '*)
  1789. X     (+ (math-poly-degree (nth 1 expr))
  1790. X        (math-poly-degree (nth 2 expr))))
  1791. X    ((eq (car expr) '/)
  1792. X     (- (math-poly-degree (nth 1 expr))
  1793. X        (math-poly-degree (nth 2 expr))))
  1794. X    ((and (eq (car expr) '^) (natnump (nth 2 expr)))
  1795. X     (* (math-poly-degree (nth 1 expr)) (nth 2 expr)))
  1796. X    ((memq (car expr) '(+ -))
  1797. X     (max (math-poly-degree (nth 1 expr))
  1798. X          (math-poly-degree (nth 2 expr))))
  1799. X    (t 1))
  1800. )
  1801. X
  1802. (defun calcFunc-plead (expr var)
  1803. X  (cond ((eq (car-safe expr) '*)
  1804. X     (math-mul (calcFunc-plead (nth 1 expr) var)
  1805. X           (calcFunc-plead (nth 2 expr) var)))
  1806. X    ((eq (car-safe expr) '/)
  1807. X     (math-div (calcFunc-plead (nth 1 expr) var)
  1808. X           (calcFunc-plead (nth 2 expr) var)))
  1809. X    ((and (eq (car-safe expr) '^) (math-natnump (nth 2 expr)))
  1810. X     (math-pow (calcFunc-plead (nth 1 expr) var) (nth 2 expr)))
  1811. X    ((Math-primp expr)
  1812. X     (if (equal expr var)
  1813. X         1
  1814. X       expr))
  1815. X    (t
  1816. X     (let ((p (math-is-polynomial expr var)))
  1817. X       (if (cdr p)
  1818. X           (nth (1- (length p)) p)
  1819. X         1))))
  1820. )
  1821. X
  1822. X
  1823. X
  1824. X
  1825. X
  1826. ;;; Polynomial quotient, remainder, and GCD.
  1827. ;;; Originally by Ove Ewerlid (ewerlid@mizar.DoCS.UU.SE).
  1828. ;;; Modifications and simplifications by daveg.
  1829. X
  1830. (setq math-poly-modulus 1)
  1831. X
  1832. ;;; Return gcd of two polynomials
  1833. (defun calcFunc-pgcd (pn pd)
  1834. X  (if (math-any-floats pn)
  1835. X      (math-reject-arg pn "Coefficients must be rational"))
  1836. X  (if (math-any-floats pd)
  1837. X      (math-reject-arg pd "Coefficients must be rational"))
  1838. X  (let ((calc-prefer-frac t)
  1839. X    (math-poly-modulus (math-poly-modulus pn pd)))
  1840. X    (math-poly-gcd pn pd))
  1841. )
  1842. X
  1843. ;;; Return only quotient to top of stack (nil if zero)
  1844. (defun calcFunc-pdiv (pn pd &optional base)
  1845. X  (let* ((calc-prefer-frac t)
  1846. X     (math-poly-modulus (math-poly-modulus pn pd))
  1847. X     (res (math-poly-div pn pd base)))
  1848. X    (setq calc-poly-div-remainder (cdr res))
  1849. X    (car res))
  1850. )
  1851. X
  1852. ;;; Return only remainder to top of stack
  1853. (defun calcFunc-prem (pn pd &optional base)
  1854. X  (let ((calc-prefer-frac t)
  1855. X    (math-poly-modulus (math-poly-modulus pn pd)))
  1856. X    (cdr (math-poly-div pn pd base)))
  1857. )
  1858. X
  1859. (defun calcFunc-pdivrem (pn pd &optional base)
  1860. X  (let* ((calc-prefer-frac t)
  1861. X     (math-poly-modulus (math-poly-modulus pn pd))
  1862. X     (res (math-poly-div pn pd base)))
  1863. X    (list 'vec (car res) (cdr res)))
  1864. )
  1865. X
  1866. (defun calcFunc-pdivide (pn pd &optional base)
  1867. X  (let* ((calc-prefer-frac t)
  1868. X     (math-poly-modulus (math-poly-modulus pn pd))
  1869. X     (res (math-poly-div pn pd base)))
  1870. X    (math-add (car res) (math-div (cdr res) pd)))
  1871. SHAR_EOF
  1872. true || echo 'restore of calc-poly.el failed'
  1873. fi
  1874. echo 'End of  part 22'
  1875. echo 'File calc-poly.el is continued in part 23'
  1876. echo 23 > _shar_seq_.tmp
  1877. exit 0
  1878. exit 0 # Just in case...
  1879. -- 
  1880. Kent Landfield                   INTERNET: kent@sparky.IMD.Sterling.COM
  1881. Sterling Software, IMD           UUCP:     uunet!sparky!kent
  1882. Phone:    (402) 291-8300         FAX:      (402) 291-4362
  1883. Please send comp.sources.misc-related mail to kent@uunet.uu.net.
  1884.