[bpt/emacs.git] / lisp / calc / calc-stuff.el

;;; calc-stuff.el --- miscellaneous functions for Calc

;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.

;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainers: D. Goel <deego@gnufans.org>
;;              Colin Walters <walters@debian.org>

;; This file is part of GNU Emacs.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.

;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.

;;; Commentary:

;;; Code:

;; This file is autoloaded from calc-ext.el.
(require 'calc-ext)

(require 'calc-macs)

(defun calc-Need-calc-stuff () nil)


(defun calc-num-prefix (n)
  "Use the number at the top of stack as the numeric prefix for the next command.
With a prefix, push that prefix as a number onto the stack."
  (interactive "P")
  (calc-wrapper
   (if n
       (calc-enter-result 0 "" (prefix-numeric-value n))
     (let ((num (calc-top 1)))
       (if (math-messy-integerp num)
	   (setq num (math-trunc num)))
       (or (integerp num)
	   (error "Argument must be a small integer"))
       (calc-pop-stack 1)
       (setq prefix-arg num)
       (message "%d-" num)))))    ; a (lame) simulation of the real thing...


(defun calc-more-recursion-depth (n)
  (interactive "P")
  (calc-wrapper
   (if (calc-is-inverse)
       (calc-less-recursion-depth n)
     (let ((n (if n (prefix-numeric-value n) 2)))
       (if (> n 1)
	   (setq max-specpdl-size (* max-specpdl-size n)
		 max-lisp-eval-depth (* max-lisp-eval-depth n))))
     (message "max-lisp-eval-depth is now %d" max-lisp-eval-depth))))

(defun calc-less-recursion-depth (n)
  (interactive "P")
  (let ((n (if n (prefix-numeric-value n) 2)))
    (if (> n 1)
	(setq max-specpdl-size
	      (max (/ max-specpdl-size n) 600)
	      max-lisp-eval-depth
	      (max (/ max-lisp-eval-depth n) 200))))
  (message "max-lisp-eval-depth is now %d" max-lisp-eval-depth))


(defvar calc-which-why nil)
(defvar calc-last-why-command nil)
(defun calc-explain-why (why &optional more)
  (if (eq (car why) '*)
      (setq why (cdr why)))
  (let* ((pred (car why))
	 (arg (nth 1 why))
	 (msg (cond ((not pred) "Wrong type of argument")
		    ((stringp pred) pred)
		    ((eq pred 'integerp) "Integer expected")
		    ((eq pred 'natnump)
		     (if (and arg (Math-objvecp arg) (not (Math-integerp arg)))
			 "Integer expected"
		       "Nonnegative integer expected"))
		    ((eq pred 'posintp)
		     (if (and arg (Math-objvecp arg) (not (Math-integerp arg)))
			 "Integer expected"
		       "Positive integer expected"))
		    ((eq pred 'fixnump)
		     (if (and arg (Math-integerp arg))
			 "Small integer expected"
		       "Integer expected"))
		    ((eq pred 'fixnatnump)
		     (if (and arg (Math-natnump arg))
			 "Small integer expected"
		       (if (and arg (Math-objvecp arg)
				(not (Math-integerp arg)))
			   "Integer expected"
			 "Nonnegative integer expected")))
		    ((eq pred 'fixposintp)
		     (if (and arg (Math-integerp arg) (Math-posp arg))
			 "Small integer expected"
		       (if (and arg (Math-objvecp arg)
				(not (Math-integerp arg)))
			   "Integer expected"
			 "Positive integer expected")))
		    ((eq pred 'posp) "Positive number expected")
		    ((eq pred 'negp) "Negative number expected")
		    ((eq pred 'nonzerop) "Nonzero number expected")
		    ((eq pred 'realp) "Real number expected")
		    ((eq pred 'anglep) "Real number expected")
		    ((eq pred 'hmsp) "HMS form expected")
		    ((eq pred 'datep)
		     (if (and arg (Math-objectp arg)
			      (not (Math-realp arg)))
			 "Real number or date form expected"
		       "Date form expected"))
		    ((eq pred 'numberp) "Number expected")
		    ((eq pred 'scalarp) "Number expected")
		    ((eq pred 'vectorp) "Vector or matrix expected")
		    ((eq pred 'numvecp) "Number or vector expected")
		    ((eq pred 'matrixp) "Matrix expected")
		    ((eq pred 'square-matrixp)
		     (if (and arg (math-matrixp arg))
			 "Square matrix expected"
		       "Matrix expected"))
		    ((eq pred 'objectp) "Number expected")
		    ((eq pred 'constp) "Constant expected")
		    ((eq pred 'range) "Argument out of range")
		    (t (format "%s expected" pred))))
	 (punc ": ")
	 (calc-can-abbrev-vectors t))
    (while (setq why (cdr why))
      (and (car why)
	   (setq msg (concat msg punc (if (stringp (car why))
					  (car why)
					(math-format-flat-expr (car why) 0)))
		 punc ", ")))
    (message "%s%s" msg (if more "  [w=more]" ""))))

(defun calc-why ()
  (interactive)
  (if (not (eq this-command last-command))
      (if (eq last-command calc-last-why-command)
	  (setq calc-which-why (cdr calc-why))
	(setq calc-which-why calc-why)))
  (if calc-which-why
      (progn
	(calc-explain-why (car calc-which-why) (cdr calc-which-why))
	(setq calc-which-why (cdr calc-which-why)))
    (if calc-why
	(progn
	  (message "(No further explanations available)")
	  (setq calc-which-why calc-why))
      (message "No explanations available"))))


(defun calc-version ()
  (interactive)
  (message "Calc %s" calc-version))


(defun calc-flush-caches (&optional inhibit-msg)
  (interactive "P")
  (calc-wrapper
   (setq math-lud-cache nil
	 math-log2-cache nil
	 math-radix-digits-cache nil
	 math-radix-float-cache-tag nil
	 math-random-cache nil
	 math-max-digits-cache nil
	 math-checked-rewrites nil
	 math-integral-cache nil
	 math-units-table nil
	 math-decls-cache-tag nil
	 math-eval-rules-cache-tag t
	 math-graph-var-cache nil
	 math-graph-data-cache nil
	 math-format-date-cache nil
	 math-holidays-cache-tag t)
   (mapcar (function (lambda (x) (set x -100))) math-cache-list)
   (unless inhibit-msg
     (message "All internal calculator caches have been reset"))))


;;; Conversions.

(defun calc-clean (n)
  (interactive "P")
  (calc-slow-wrapper
   (calc-with-default-simplification
    (let ((func (if (calc-is-hyperbolic) 'calcFunc-clean 'calcFunc-pclean)))
      (calc-enter-result 1 "cln"
			 (if n
			     (let ((n (prefix-numeric-value n)))
			       (list func
				     (calc-top-n 1)
				     (if (<= n 0)
					 (+ n calc-internal-prec)
				       n)))
			   (list func (calc-top-n 1))))))))

(defun calc-clean-num (num)
  (interactive "P")
  (calc-clean (- (if num
		     (prefix-numeric-value num)
		   (if (and (>= last-command-char ?0)
			    (<= last-command-char ?9))
		       (- last-command-char ?0)
		     (error "Number required"))))))


(defvar math-chopping-small nil)
(defun calcFunc-clean (a &optional prec)   ; [X X S] [Public]
  (if prec
      (cond ((Math-messy-integerp prec)
	     (calcFunc-clean a (math-trunc prec)))
	    ((or (not (integerp prec))
		 (< prec 3))
	     (calc-record-why "*Precision must be an integer 3 or above")
	     (list 'calcFunc-clean a prec))
	    ((not (Math-objvecp a))
	     (list 'calcFunc-clean a prec))
	    (t (let ((calc-internal-prec prec)
		     (math-chopping-small t))
		 (calcFunc-clean (math-normalize a)))))
    (cond ((eq (car-safe a) 'polar)
	   (let ((theta (math-mod (nth 2 a)
				  (if (eq calc-angle-mode 'rad)
				      (math-two-pi)
				    360))))
	     (math-neg
	      (math-neg
	       (math-normalize
		(list 'polar
		      (calcFunc-clean (nth 1 a))
		      (calcFunc-clean theta)))))))
	  ((memq (car-safe a) '(vec date hms))
	   (cons (car a) (mapcar 'calcFunc-clean (cdr a))))
	  ((memq (car-safe a) '(cplx mod sdev intv))
	   (math-normalize (cons (car a) (mapcar 'calcFunc-clean (cdr a)))))
	  ((eq (car-safe a) 'float)
	   (if math-chopping-small
	       (if (or (> (nth 2 a) (- calc-internal-prec))
		       (Math-lessp (- calc-internal-prec) (calcFunc-xpon a)))
		   (if (and (math-num-integerp a)
			    (math-lessp (calcFunc-xpon a) calc-internal-prec))
		       (math-trunc a)
		     a)
		 0)
	     a))
	  ((Math-objectp a) a)
	  ((math-infinitep a) a)
	  (t (list 'calcFunc-clean a)))))

(defun calcFunc-pclean (a &optional prec)
  (math-map-over-constants (function (lambda (x) (calcFunc-clean x prec)))
			   a))

(defun calcFunc-pfloat (a)
  (math-map-over-constants 'math-float a))

(defun calcFunc-pfrac (a &optional tol)
  (math-map-over-constants (function (lambda (x) (calcFunc-frac x tol)))
			   a))

(defun math-map-over-constants (func expr)
  (math-map-over-constants-rec expr))

(defun math-map-over-constants-rec (expr)
  (cond ((or (Math-primp expr)
	     (memq (car expr) '(intv sdev)))
	 (or (and (Math-objectp expr)
		  (funcall func expr))
	     expr))
	((and (memq (car expr) '(^ calcFunc-subscr))
	      (eq func 'math-float)
	      (= (length expr) 3)
	      (Math-integerp (nth 2 expr)))
	 (list (car expr)
	       (math-map-over-constants-rec (nth 1 expr))
	       (nth 2 expr)))
	(t (cons (car expr) (mapcar 'math-map-over-constants-rec (cdr expr))))))

;;; arch-tag: 789332ef-a178-49d3-8fb7-5d7ed7e21f56
;;; calc-stuff.el ends here
Commit	Line	Data
3132f345 CW	1	;;; calc-stuff.el --- miscellaneous functions for Calc
3132f345 CW	2
bf77c646	3	;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
3132f345 CW	4
3132f345 CW	5	;; Author: David Gillespie <daveg@synaptics.com>
a1506d29	6	;; Maintainers: D. Goel <deego@gnufans.org>
6e1c888a	7	;; Colin Walters <walters@debian.org>
136211a9 EZ	8
	9	;; This file is part of GNU Emacs.
	10
	11	;; GNU Emacs is distributed in the hope that it will be useful,
	12	;; but WITHOUT ANY WARRANTY. No author or distributor
	13	;; accepts responsibility to anyone for the consequences of using it
	14	;; or for whether it serves any particular purpose or works at all,
	15	;; unless he says so in writing. Refer to the GNU Emacs General Public
	16	;; License for full details.
	17
	18	;; Everyone is granted permission to copy, modify and redistribute
	19	;; GNU Emacs, but only under the conditions described in the
	20	;; GNU Emacs General Public License. A copy of this license is
	21	;; supposed to have been given to you along with GNU Emacs so you
	22	;; can know your rights and responsibilities. It should be in a
	23	;; file named COPYING. Among other things, the copyright notice
	24	;; and this notice must be preserved on all copies.
	25
3132f345	26	;;; Commentary:
136211a9	27
3132f345	28	;;; Code:
136211a9 EZ	29
	30	;; This file is autoloaded from calc-ext.el.
	31	(require 'calc-ext)
	32
	33	(require 'calc-macs)
	34
	35	(defun calc-Need-calc-stuff () nil)
	36
	37
	38	(defun calc-num-prefix (n)
	39	"Use the number at the top of stack as the numeric prefix for the next command.
	40	With a prefix, push that prefix as a number onto the stack."
	41	(interactive "P")
	42	(calc-wrapper
	43	(if n
	44	(calc-enter-result 0 "" (prefix-numeric-value n))
	45	(let ((num (calc-top 1)))
	46	(if (math-messy-integerp num)
	47	(setq num (math-trunc num)))
	48	(or (integerp num)
	49	(error "Argument must be a small integer"))
	50	(calc-pop-stack 1)
	51	(setq prefix-arg num)
bf77c646	52	(message "%d-" num))))) ; a (lame) simulation of the real thing...
136211a9 EZ	53
	54
	55	(defun calc-more-recursion-depth (n)
	56	(interactive "P")
	57	(calc-wrapper
	58	(if (calc-is-inverse)
	59	(calc-less-recursion-depth n)
	60	(let ((n (if n (prefix-numeric-value n) 2)))
	61	(if (> n 1)
	62	(setq max-specpdl-size (* max-specpdl-size n)
	63	max-lisp-eval-depth (* max-lisp-eval-depth n))))
bf77c646	64	(message "max-lisp-eval-depth is now %d" max-lisp-eval-depth))))
136211a9 EZ	65
	66	(defun calc-less-recursion-depth (n)
	67	(interactive "P")
	68	(let ((n (if n (prefix-numeric-value n) 2)))
	69	(if (> n 1)
	70	(setq max-specpdl-size
	71	(max (/ max-specpdl-size n) 600)
	72	max-lisp-eval-depth
	73	(max (/ max-lisp-eval-depth n) 200))))
bf77c646	74	(message "max-lisp-eval-depth is now %d" max-lisp-eval-depth))
136211a9 EZ	75
136211a9 EZ	76
3132f345 CW	77	(defvar calc-which-why nil)
3132f345 CW	78	(defvar calc-last-why-command nil)
136211a9 EZ	79	(defun calc-explain-why (why &optional more)
	80	(if (eq (car why) '*)
	81	(setq why (cdr why)))
	82	(let* ((pred (car why))
	83	(arg (nth 1 why))
	84	(msg (cond ((not pred) "Wrong type of argument")
	85	((stringp pred) pred)
	86	((eq pred 'integerp) "Integer expected")
	87	((eq pred 'natnump)
	88	(if (and arg (Math-objvecp arg) (not (Math-integerp arg)))
	89	"Integer expected"
	90	"Nonnegative integer expected"))
	91	((eq pred 'posintp)
	92	(if (and arg (Math-objvecp arg) (not (Math-integerp arg)))
	93	"Integer expected"
	94	"Positive integer expected"))
	95	((eq pred 'fixnump)
	96	(if (and arg (Math-integerp arg))
	97	"Small integer expected"
	98	"Integer expected"))
	99	((eq pred 'fixnatnump)
	100	(if (and arg (Math-natnump arg))
	101	"Small integer expected"
	102	(if (and arg (Math-objvecp arg)
	103	(not (Math-integerp arg)))
	104	"Integer expected"
	105	"Nonnegative integer expected")))
	106	((eq pred 'fixposintp)
	107	(if (and arg (Math-integerp arg) (Math-posp arg))
	108	"Small integer expected"
	109	(if (and arg (Math-objvecp arg)
	110	(not (Math-integerp arg)))
	111	"Integer expected"
	112	"Positive integer expected")))
	113	((eq pred 'posp) "Positive number expected")
	114	((eq pred 'negp) "Negative number expected")
	115	((eq pred 'nonzerop) "Nonzero number expected")
	116	((eq pred 'realp) "Real number expected")
	117	((eq pred 'anglep) "Real number expected")
	118	((eq pred 'hmsp) "HMS form expected")
	119	((eq pred 'datep)
	120	(if (and arg (Math-objectp arg)
	121	(not (Math-realp arg)))
	122	"Real number or date form expected"
	123	"Date form expected"))
	124	((eq pred 'numberp) "Number expected")
	125	((eq pred 'scalarp) "Number expected")
	126	((eq pred 'vectorp) "Vector or matrix expected")
	127	((eq pred 'numvecp) "Number or vector expected")
	128	((eq pred 'matrixp) "Matrix expected")
	129	((eq pred 'square-matrixp)
	130	(if (and arg (math-matrixp arg))
	131	"Square matrix expected"
	132	"Matrix expected"))
	133	((eq pred 'objectp) "Number expected")
	134	((eq pred 'constp) "Constant expected")
	135	((eq pred 'range) "Argument out of range")
	136	(t (format "%s expected" pred))))
	137	(punc ": ")
	138	(calc-can-abbrev-vectors t))
	139	(while (setq why (cdr why))
	140	(and (car why)
	141	(setq msg (concat msg punc (if (stringp (car why))
	142	(car why)
143	(math-format-flat-expr (car why) 0)))
144	punc ", ")))
bf77c646	145	(message "%s%s" msg (if more " [w=more]" ""))))
136211a9 EZ	146
	147	(defun calc-why ()
	148	(interactive)
	149	(if (not (eq this-command last-command))
	150	(if (eq last-command calc-last-why-command)
	151	(setq calc-which-why (cdr calc-why))
	152	(setq calc-which-why calc-why)))
	153	(if calc-which-why
	154	(progn
	155	(calc-explain-why (car calc-which-why) (cdr calc-which-why))
	156	(setq calc-which-why (cdr calc-which-why)))
	157	(if calc-why
	158	(progn
	159	(message "(No further explanations available)")
	160	(setq calc-which-why calc-why))
bf77c646	161	(message "No explanations available"))))
136211a9 EZ	162
	163
	164	(defun calc-version ()
	165	(interactive)
3132f345	166	(message "Calc %s" calc-version))
136211a9 EZ	167
136211a9 EZ	168
9b08ce78 CW	169	(defun calc-flush-caches (&optional inhibit-msg)
9b08ce78 CW	170	(interactive "P")
136211a9 EZ	171	(calc-wrapper
	172	(setq math-lud-cache nil
	173	math-log2-cache nil
	174	math-radix-digits-cache nil
	175	math-radix-float-cache-tag nil
	176	math-random-cache nil
	177	math-max-digits-cache nil
	178	math-checked-rewrites nil
	179	math-integral-cache nil
	180	math-units-table nil
	181	math-decls-cache-tag nil
	182	math-eval-rules-cache-tag t
	183	math-graph-var-cache nil
	184	math-graph-data-cache nil
	185	math-format-date-cache nil
	186	math-holidays-cache-tag t)
	187	(mapcar (function (lambda (x) (set x -100))) math-cache-list)
9b08ce78 CW	188	(unless inhibit-msg
9b08ce78 CW	189	(message "All internal calculator caches have been reset"))))
136211a9 EZ	190
	191
	192	;;; Conversions.
	193
	194	(defun calc-clean (n)
	195	(interactive "P")
	196	(calc-slow-wrapper
	197	(calc-with-default-simplification
	198	(let ((func (if (calc-is-hyperbolic) 'calcFunc-clean 'calcFunc-pclean)))
	199	(calc-enter-result 1 "cln"
	200	(if n
	201	(let ((n (prefix-numeric-value n)))
	202	(list func
	203	(calc-top-n 1)
	204	(if (<= n 0)
	205	(+ n calc-internal-prec)
	206	n)))
bf77c646	207	(list func (calc-top-n 1))))))))
136211a9 EZ	208
	209	(defun calc-clean-num (num)
	210	(interactive "P")
	211	(calc-clean (- (if num
a1506d29	212	(prefix-numeric-value num)
136211a9 EZ	213	(if (and (>= last-command-char ?0)
	214	(<= last-command-char ?9))
	215	(- last-command-char ?0)
bf77c646	216	(error "Number required"))))))
136211a9 EZ	217
136211a9 EZ	218
3132f345	219	(defvar math-chopping-small nil)
136211a9 EZ	220	(defun calcFunc-clean (a &optional prec) ; [X X S] [Public]
	221	(if prec
	222	(cond ((Math-messy-integerp prec)
	223	(calcFunc-clean a (math-trunc prec)))
	224	((or (not (integerp prec))
	225	(< prec 3))
	226	(calc-record-why "*Precision must be an integer 3 or above")
	227	(list 'calcFunc-clean a prec))
	228	((not (Math-objvecp a))
	229	(list 'calcFunc-clean a prec))
	230	(t (let ((calc-internal-prec prec)
	231	(math-chopping-small t))
	232	(calcFunc-clean (math-normalize a)))))
	233	(cond ((eq (car-safe a) 'polar)
	234	(let ((theta (math-mod (nth 2 a)
	235	(if (eq calc-angle-mode 'rad)
	236	(math-two-pi)
	237	360))))
	238	(math-neg
	239	(math-neg
	240	(math-normalize
	241	(list 'polar
	242	(calcFunc-clean (nth 1 a))
	243	(calcFunc-clean theta)))))))
	244	((memq (car-safe a) '(vec date hms))
	245	(cons (car a) (mapcar 'calcFunc-clean (cdr a))))
	246	((memq (car-safe a) '(cplx mod sdev intv))
	247	(math-normalize (cons (car a) (mapcar 'calcFunc-clean (cdr a)))))
	248	((eq (car-safe a) 'float)
	249	(if math-chopping-small
	250	(if (or (> (nth 2 a) (- calc-internal-prec))
	251	(Math-lessp (- calc-internal-prec) (calcFunc-xpon a)))
	252	(if (and (math-num-integerp a)
	253	(math-lessp (calcFunc-xpon a) calc-internal-prec))
	254	(math-trunc a)
	255	a)
	256	0)
	257	a))
	258	((Math-objectp a) a)
	259	((math-infinitep a) a)
bf77c646	260	(t (list 'calcFunc-clean a)))))
136211a9 EZ	261
	262	(defun calcFunc-pclean (a &optional prec)
	263	(math-map-over-constants (function (lambda (x) (calcFunc-clean x prec)))
bf77c646	264	a))
136211a9 EZ	265
136211a9 EZ	266	(defun calcFunc-pfloat (a)
bf77c646	267	(math-map-over-constants 'math-float a))
136211a9 EZ	268
	269	(defun calcFunc-pfrac (a &optional tol)
	270	(math-map-over-constants (function (lambda (x) (calcFunc-frac x tol)))
bf77c646	271	a))
136211a9 EZ	272
136211a9 EZ	273	(defun math-map-over-constants (func expr)
bf77c646	274	(math-map-over-constants-rec expr))
136211a9 EZ	275
	276	(defun math-map-over-constants-rec (expr)
	277	(cond ((or (Math-primp expr)
	278	(memq (car expr) '(intv sdev)))
	279	(or (and (Math-objectp expr)
	280	(funcall func expr))
	281	expr))
	282	((and (memq (car expr) '(^ calcFunc-subscr))
	283	(eq func 'math-float)
	284	(= (length expr) 3)
	285	(Math-integerp (nth 2 expr)))
	286	(list (car expr)
	287	(math-map-over-constants-rec (nth 1 expr))
	288	(nth 2 expr)))
bf77c646	289	(t (cons (car expr) (mapcar 'math-map-over-constants-rec (cdr expr))))))
136211a9	290
6b61353c	291	;;; arch-tag: 789332ef-a178-49d3-8fb7-5d7ed7e21f56
bf77c646	292	;;; calc-stuff.el ends here