1 ;;; calc-prog.el --- user programmability functions for Calc
3 ;; Copyright (C) 1990-1993, 2001-2014 Free Software Foundation, Inc.
5 ;; Author: David Gillespie <daveg@synaptics.com>
6 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27 ;; This file is autoloaded from calc-ext.el.
32 ;; Declare functions which are defined elsewhere.
33 (declare-function edmacro-format-keys
"edmacro" (macro &optional verbose
))
34 (declare-function edmacro-parse-keys
"edmacro" (string &optional need-vector
))
35 (declare-function math-read-expr-level
"calc-aent" (exp-prec &optional exp-term
))
38 (defun calc-equal-to (arg)
41 (if (and (integerp arg
) (> arg
2))
42 (calc-enter-result arg
"eq" (cons 'calcFunc-eq
(calc-top-list-n arg
)))
43 (calc-binary-op "eq" 'calcFunc-eq arg
))))
45 (defun calc-remove-equal (arg)
48 (calc-unary-op "rmeq" 'calcFunc-rmeq arg
)))
50 (defun calc-not-equal-to (arg)
53 (if (and (integerp arg
) (> arg
2))
54 (calc-enter-result arg
"neq" (cons 'calcFunc-neq
(calc-top-list-n arg
)))
55 (calc-binary-op "neq" 'calcFunc-neq arg
))))
57 (defun calc-less-than (arg)
60 (calc-binary-op "lt" 'calcFunc-lt arg
)))
62 (defun calc-greater-than (arg)
65 (calc-binary-op "gt" 'calcFunc-gt arg
)))
67 (defun calc-less-equal (arg)
70 (calc-binary-op "leq" 'calcFunc-leq arg
)))
72 (defun calc-greater-equal (arg)
75 (calc-binary-op "geq" 'calcFunc-geq arg
)))
77 (defun calc-in-set (arg)
80 (calc-binary-op "in" 'calcFunc-in arg
)))
82 (defun calc-logical-and (arg)
85 (calc-binary-op "land" 'calcFunc-land arg
1)))
87 (defun calc-logical-or (arg)
90 (calc-binary-op "lor" 'calcFunc-lor arg
0)))
92 (defun calc-logical-not (arg)
95 (calc-unary-op "lnot" 'calcFunc-lnot arg
)))
97 (defun calc-logical-if ()
100 (calc-enter-result 3 "if" (cons 'calcFunc-if
(calc-top-list-n 3)))))
106 (defun calc-timing (n)
109 (calc-change-mode 'calc-timing n nil t
)
110 (message (if calc-timing
111 "Reporting timing of slow commands in Trail"
112 "Not reporting timing of commands"))))
114 (defun calc-pass-errors ()
116 ;; The following two cases are for the new, optimizing byte compiler
117 ;; or the standard 18.57 byte compiler, respectively.
119 (let ((place (aref (nth 2 (nth 2 (symbol-function 'calc-do
))) 15)))
120 (or (memq (car-safe (car-safe place
)) '(error xxxerror
))
121 (setq place
(aref (nth 2 (nth 2 (symbol-function 'calc-do
))) 27)))
122 (or (memq (car (car place
)) '(error xxxerror
))
124 (setcar (car place
) 'xxxerror
))
125 (error (error "The calc-do function has been modified; unable to patch"))))
127 (defun calc-user-define ()
129 (message "Define user key: z-")
130 (let ((key (read-char)))
131 (if (= (calc-user-function-classify key
) 0)
132 (error "Can't redefine \"?\" key"))
133 (let ((func (intern (completing-read (concat "Set key z "
140 (let* ((kmap (calc-user-key-map))
141 (old (assq key kmap
)))
142 ;; FIXME: Why not (define-key kmap (vector key) func)?
145 (setcdr kmap
(cons (cons key func
) (cdr kmap
))))))))
147 (defun calc-user-undefine ()
149 (message "Undefine user key: z-")
150 (let ((key (read-char)))
151 (if (= (calc-user-function-classify key
) 0)
152 (error "Can't undefine \"?\" key"))
153 (let* ((kmap (calc-user-key-map)))
154 (delq (or (assq key kmap
)
155 (assq (upcase key
) kmap
)
156 (assq (downcase key
) kmap
)
157 (error "No such user key is defined"))
161 ;; math-integral-cache-state is originally declared in calcalg2.el,
162 ;; it is used in calc-user-define-variable.
163 (defvar math-integral-cache-state
)
165 ;; calc-user-formula-alist is local to calc-user-define-formula,
166 ;; calc-user-define-composition and calc-finish-formula-edit,
167 ;; but is used by calc-fix-user-formula.
168 (defvar calc-user-formula-alist
)
170 (defun calc-user-define-formula ()
173 (let* ((form (calc-top 1))
175 (is-lambda (and (eq (car-safe form
) 'calcFunc-lambda
)
176 (>= (length form
) 2)))
177 odef key keyname cmd cmd-base cmd-base-default
178 func calc-user-formula-alist is-symb
)
180 (setq math-arglist
(mapcar (function (lambda (x) (nth 1 x
)))
181 (nreverse (cdr (reverse (cdr form
)))))
182 form
(nth (1- (length form
)) form
))
183 (calc-default-formula-arglist form
)
184 (setq math-arglist
(sort math-arglist
'string-lessp
)))
185 (message "Define user key: z-")
186 (setq key
(read-char))
187 (if (= (calc-user-function-classify key
) 0)
188 (error "Can't redefine \"?\" key"))
189 (setq key
(and (not (memq key
'(13 32))) key
)
191 (if (or (and (<= ?
0 key
) (<= key ?
9))
192 (and (<= ?a key
) (<= key ?z
))
193 (and (<= ?A key
) (<= key ?Z
)))
195 (format "%03d" key
)))
196 odef
(assq key
(calc-user-key-map)))
198 (setq keyname
(format "%05d" (abs (%
(random) 10000)))))
201 (setq cmd-base-default
(concat "User-" keyname
))
202 (setq cmd
(completing-read
203 (concat "Define M-x command name (default calc-"
206 obarray
'commandp nil
207 (if (and odef
(symbolp (cdr odef
)))
208 (symbol-name (cdr odef
))
210 (if (or (string-equal cmd
"")
211 (string-equal cmd
"calc-"))
212 (setq cmd
(concat "calc-User-" keyname
)))
213 (setq cmd-base
(and (string-match "\\`calc-\\(.+\\)\\'" cmd
)
214 (math-match-substring cmd
1)))
215 (setq cmd
(intern cmd
))
221 (if (get cmd
'calc-user-defn
)
222 (concat "Replace previous definition for "
223 (symbol-name cmd
) "? ")
224 "That name conflicts with a built-in Emacs function. Replace this function? "))))))
227 (setq cmd-base-default
230 "\\`User-.+" cmd-base
)
233 (substring cmd-base
5))
235 (concat "User" keyname
)))
239 (concat "Define algebraic function name (default "
240 cmd-base-default
"): ")
241 (mapcar (lambda (x) (substring x
9))
242 (all-completions "calcFunc-"
246 (intern (concat "calcFunc-" x
))))
249 (if (string-equal func
"calcFunc-")
250 (intern (concat "calcFunc-" cmd-base-default
))
258 (if (get func
'calc-user-defn
)
259 (concat "Replace previous definition for "
260 (symbol-name func
) "? ")
261 "That name conflicts with a built-in Emacs function. Replace this function? "))))))
264 (setq func
(intern (concat "calcFunc-User"
266 (and cmd
(symbol-name cmd
))
267 (format "%05d" (%
(random) 10000)))))))
270 (setq calc-user-formula-alist math-arglist
)
273 (setq calc-user-formula-alist
274 (read-from-minibuffer "Function argument list: "
276 (prin1-to-string math-arglist
)
280 (and (not (calc-subsetp calc-user-formula-alist math-arglist
))
282 "Okay for arguments that don't appear in formula to be ignored? "))))))
283 (setq is-symb
(and calc-user-formula-alist
286 "Leave it symbolic for non-constant arguments? ")))
287 (setq calc-user-formula-alist
288 (mapcar (function (lambda (x)
289 (or (cdr (assq x
'((nil . arg-nil
)
291 x
))) calc-user-formula-alist
))
300 (list 'calc-enter-result
301 (length calc-user-formula-alist
)
302 (let ((name (symbol-name (or func cmd
))))
304 "\\([^-][^-]?[^-]?[^-]?\\)[^-]*\\'"
306 (math-match-substring name
1)))
309 (list 'calc-top-list-n
310 (length calc-user-formula-alist
)))))))
311 (put cmd
'calc-user-defn t
)))
312 (let ((body (list 'math-normalize
(calc-fix-user-formula form
))))
315 (list 'lambda calc-user-formula-alist
)
317 (mapcar (function (lambda (v)
318 (list 'math-check-const v t
)))
319 calc-user-formula-alist
))
321 (put func
'calc-user-defn form
)
322 (setq math-integral-cache-state nil
)
324 (let* ((kmap (calc-user-key-map))
325 (old (assq key kmap
)))
326 ;; FIXME: Why not (define-key kmap (vector key) cmd)?
329 (setcdr kmap
(cons (cons key cmd
) (cdr kmap
)))))))
332 (defvar math-arglist
) ; dynamically bound in all callers
333 (defun calc-default-formula-arglist (form)
335 (if (eq (car form
) 'var
)
336 (if (or (memq (nth 1 form
) math-arglist
)
337 (math-const-var form
))
339 (setq math-arglist
(cons (nth 1 form
) math-arglist
)))
340 (calc-default-formula-arglist-step (cdr form
)))))
342 (defun calc-default-formula-arglist-step (l)
345 (calc-default-formula-arglist (car l
))
346 (calc-default-formula-arglist-step (cdr l
)))))
348 (defun calc-subsetp (a b
)
350 (and (memq (car a
) b
)
351 (calc-subsetp (cdr a
) b
))))
353 (defun calc-fix-user-formula (f)
356 (cond ((and (eq (car f
) 'var
)
357 (memq (setq temp
(or (cdr (assq (nth 1 f
) '((nil . arg-nil
)
360 calc-user-formula-alist
))
362 ((or (math-constp f
) (eq (car f
) 'var
))
364 ((and (eq (car f
) 'calcFunc-eval
)
366 (list 'let
'((calc-simplify-mode nil
))
367 (list 'math-normalize
(calc-fix-user-formula (nth 1 f
)))))
368 ((and (eq (car f
) 'calcFunc-evalsimp
)
370 (list 'math-simplify
(calc-fix-user-formula (nth 1 f
))))
371 ((and (eq (car f
) 'calcFunc-evalextsimp
)
373 (list 'math-simplify-extended
374 (calc-fix-user-formula (nth 1 f
))))
377 (cons (list 'quote
(car f
))
378 (mapcar 'calc-fix-user-formula
(cdr f
)))))))
381 (defun calc-user-define-composition ()
384 (if (eq calc-language
'unform
)
385 (error "Can't define formats for unformatted mode"))
386 (let* ((comp (calc-top 1))
389 (completing-read "Define format for which function: "
390 (mapcar (lambda (x) (substring x
9))
391 (all-completions "calcFunc-"
395 (intern (concat "calcFunc-" x
))))))))
396 (comps (get func
'math-compose-forms
))
399 (calc-user-formula-alist nil
))
400 (if (math-zerop comp
)
401 (if (setq entry
(assq calc-language comps
))
402 (put func
'math-compose-forms
(delq entry comps
)))
403 (calc-default-formula-arglist comp
)
404 (setq math-arglist
(sort math-arglist
'string-lessp
))
407 (setq calc-user-formula-alist
408 (read-from-minibuffer "Composition argument list: "
410 (prin1-to-string math-arglist
)
414 (and (not (calc-subsetp calc-user-formula-alist math-arglist
))
416 "Okay for arguments that don't appear in formula to be invisible? "))))
417 (or (setq entry
(assq calc-language comps
))
418 (put func
'math-compose-forms
419 (cons (setq entry
(list calc-language
)) comps
)))
420 (or (setq entry2
(assq (length calc-user-formula-alist
) (cdr entry
)))
423 (list (length calc-user-formula-alist
))) (cdr entry
))))
425 (list 'lambda calc-user-formula-alist
(calc-fix-user-formula comp
))))
430 (defun calc-user-define-kbd-macro (arg)
433 (error "No keyboard macro defined"))
434 (message "Define last kbd macro on user key: z-")
435 (let ((key (read-char)))
436 (if (= (calc-user-function-classify key
) 0)
437 (error "Can't redefine \"?\" key"))
438 (let ((cmd (intern (completing-read "Full name for new command: "
443 (if (or (and (>= key ?a
)
450 (format "%03d" key
)))))))
452 (not (let ((f (symbol-function cmd
)))
455 (eq (car-safe (nth 3 f
))
456 'calc-execute-kbd-macro
)))))
457 (error "Function %s is already defined and not a keyboard macro"
459 (put cmd
'calc-user-defn t
)
460 (fset cmd
(if (< (prefix-numeric-value arg
) 0)
465 (list 'calc-execute-kbd-macro
466 (vector (key-description last-kbd-macro
)
469 (format "z%c" key
)))))
470 (let* ((kmap (calc-user-key-map))
471 (old (assq key kmap
)))
472 ;; FIXME: Why not (define-key kmap (vector key) func)?
475 (setcdr kmap
(cons (cons key cmd
) (cdr kmap
))))))))
478 (defun calc-edit-user-syntax ()
481 (let ((lang calc-language
))
482 (calc-edit-mode (list 'calc-finish-user-syntax-edit
(list 'quote lang
))
484 (format "Editing %s-Mode Syntax Table. "
485 (cond ((null lang
) "Normal")
486 ((eq lang
'tex
) "TeX")
487 ((eq lang
'latex
) "LaTeX")
488 (t (capitalize (symbol-name lang
))))))
489 (calc-write-parse-table (cdr (assq lang calc-user-parse-tables
))
491 (calc-show-edit-buffer))
493 (defvar calc-original-buffer
)
495 (defun calc-finish-user-syntax-edit (lang)
496 (let ((tab (calc-read-parse-table calc-original-buffer lang
))
497 (entry (assq lang calc-user-parse-tables
)))
500 (car (setq calc-user-parse-tables
501 (cons (list lang
) calc-user-parse-tables
))))
504 (setq calc-user-parse-tables
505 (delq entry calc-user-parse-tables
)))))
506 (switch-to-buffer calc-original-buffer
))
508 ;; The variable calc-lang is local to calc-write-parse-table, but is
509 ;; used by calc-write-parse-table-part which is called by
510 ;; calc-write-parse-table. The variable is also local to
511 ;; calc-read-parse-table, but is used by calc-fix-token-name which
512 ;; is called (indirectly) by calc-read-parse-table.
515 (defun calc-write-parse-table (tab calc-lang
)
518 (calc-write-parse-table-part (car (car p
)))
520 (let ((math-format-hash-args t
))
521 (math-format-flat-expr (cdr (car p
)) 0))
525 (defun calc-write-parse-table-part (p)
527 (cond ((stringp (car p
))
529 (if (and (string-match "\\`\\\\dots\\>" s
)
530 (not (memq calc-lang
'(tex latex
))))
531 (setq s
(concat ".." (substring s
5))))
532 (if (or (and (string-match
533 "[a-zA-Z0-9\"{}]\\|\\`:=\\'\\|\\`#\\|\\`%%" s
)
534 (string-match "[^a-zA-Z0-9\\]" s
))
535 (and (assoc s
'((")") ("]") (">")))
537 (insert (prin1-to-string s
) " ")
542 (insert "/" (int-to-string (car p
))))
544 ((and (eq (car (car p
)) '\?) (equal (car (nth 2 (car p
))) "$$"))
545 (insert (car (nth 1 (car p
))) " "))
548 (calc-write-parse-table-part (nth 1 (car p
)))
549 (insert "}" (symbol-name (car (car p
))))
551 (calc-write-parse-table-part (list (car (nth 2 (car p
)))))
555 (defun calc-read-parse-table (calc-buf calc-lang
)
558 (skip-chars-forward "\n\t ")
560 (if (looking-at "%%")
563 (p (calc-read-parse-table-part ":=[\n\t ]+" ":=")))
564 (or (stringp (car p
))
565 (and (integerp (car p
))
569 (error "Malformed syntax rule")))
572 (let* ((str (buffer-substring pos
(point)))
573 (exp (with-current-buffer calc-buf
574 (let ((calc-user-parse-tables nil
)
576 (math-expr-opers (math-standard-ops))
577 (calc-hashes-used 0))
579 (if (string-match ",[ \t]*\\'" str
)
580 (substring str
0 (match-beginning 0))
582 (if (eq (car-safe exp
) 'error
)
584 (goto-char (+ pos
(nth 1 exp
)))
585 (error (nth 2 exp
))))
586 (setq tab
(nconc tab
(list (cons p exp
)))))))))
589 (defun calc-fix-token-name (name &optional unquoted
)
590 (cond ((string-match "\\`\\.\\." name
)
591 (concat "\\dots" (substring name
2)))
592 ((and (equal name
"{") (memq calc-lang
'(tex latex eqn
)))
594 ((and (equal name
"}") (memq calc-lang
'(tex latex eqn
)))
596 ((and (equal name
"&") (memq calc-lang
'(tex latex
)))
599 (search-backward "#")
600 (error "Token '#' is reserved"))
601 ((and unquoted
(string-match "#" name
))
602 (error "Tokens containing '#' must be quoted"))
603 ((not (string-match "[^ ]" name
))
604 (search-backward "\"" nil t
)
605 (error "Blank tokens are not allowed"))
608 (defun calc-read-parse-table-part (term eterm
)
612 (skip-chars-forward "\n\t ")
613 (if (eobp) (error "Expected '%s'" eterm
))
614 (not (looking-at term
)))
615 (cond ((looking-at "%%")
617 ((looking-at "{[\n\t ]")
619 (let ((p (calc-read-parse-table-part "}" "}")))
620 (or (looking-at "[+*?]")
621 (error "Expected '+', '*', or '?'"))
622 (let ((sym (intern (buffer-substring (point) (1+ (point))))))
624 (looking-at "[^\n\t ]*")
625 (let ((sep (buffer-substring (point) (match-end 0))))
626 (goto-char (match-end 0))
627 (and (eq sym
'\?) (> (length sep
) 0)
628 (not (equal sep
"$")) (not (equal sep
"."))
629 (error "Separator not allowed with { ... }?"))
630 (if (string-match "\\`\"" sep
)
631 (setq sep
(read-from-string sep
)))
632 (if (> (length sep
) 0)
633 (setq sep
(calc-fix-token-name sep
)))
634 (setq part
(nconc part
636 (and (> (length sep
) 0)
637 (cons sep p
))))))))))
639 (error "Too many }'s"))
641 (setq quoted
(calc-fix-token-name (read (current-buffer)))
642 part
(nconc part
(list quoted
))))
643 ((looking-at "#\\(\\(/[0-9]+\\)?\\)[\n\t ]")
644 (setq part
(nconc part
(list (if (= (match-beginning 1)
649 (1+ (match-beginning 1))
651 (goto-char (match-end 0)))
652 ((looking-at ":=[\n\t ]")
653 (error "Misplaced ':='"))
655 (looking-at "[^\n\t ]*")
656 (let ((end (match-end 0)))
657 (setq part
(nconc part
(list (calc-fix-token-name
661 (goto-char (match-end 0))
662 (let ((len (length part
)))
663 (while (and (> len
1)
664 (let ((last (nthcdr (setq len
(1- len
)) part
)))
665 (and (assoc (car last
) '((")") ("]") (">")))
666 (not (eq (car last
) quoted
))
668 (list '\? (list (car last
)) '("$$"))))))))
671 (defun calc-user-define-invocation ()
674 (error "No keyboard macro defined"))
675 (setq calc-invocation-macro last-kbd-macro
)
676 (message "Use `C-x * Z' to invoke this macro"))
678 (defun calc-user-define-edit ()
679 (interactive) ; but no calc-wrapper!
680 (message "Edit definition of command: z-")
683 (def (or (assq key
(calc-user-key-map))
684 (assq (upcase key
) (calc-user-key-map))
685 (assq (downcase key
) (calc-user-key-map))
686 (error "No command defined for that key")))
689 (setq cmdname
(symbol-name cmd
))
690 (setq cmd
(symbol-function cmd
)))
691 (cond ((or (stringp cmd
)
693 (eq (car-safe (nth 3 cmd
)) 'calc-execute-kbd-macro
)))
694 (let* ((mac (elt (nth 1 (nth 3 cmd
)) 1))
695 (str (edmacro-format-keys mac t
))
696 (kys (nth 3 (nth 3 cmd
))))
698 (list 'calc-edit-macro-finish-edit cmdname kys
)
700 "Editing keyboard macro (%s, bound to %s).\n"
701 "Original keys: %s \n")
702 cmdname kys
(elt (nth 1 (nth 3 cmd
)) 0)))
704 (calc-edit-format-macro-buffer)
705 (calc-show-edit-buffer)))
706 (t (let* ((func (calc-stack-command-p cmd
))
709 (get func
'calc-user-defn
)))
710 (kys (concat "z" (char-to-string (car def
))))
711 (intcmd (symbol-name (cdr def
)))
712 (algcmd (if func
(substring (symbol-name func
) 9) "")))
713 (if (and defn
(calc-valid-formula-func func
))
714 (let ((niceexpr (math-format-nice-expr defn
(frame-width))))
717 (list 'calc-finish-formula-edit
(list 'quote func
))
720 "Editing formula (%s, %s, bound to %s).\n"
721 "Original formula: %s\n")
722 intcmd algcmd kys niceexpr
))
723 (insert (math-showing-full-precision
726 (calc-show-edit-buffer))
727 (error "That command's definition cannot be edited")))))))
729 ;; Formatting the macro buffer
731 (defvar calc-edit-top
)
733 (defun calc-edit-macro-repeats ()
734 (goto-char calc-edit-top
)
736 (re-search-forward "^\\([0-9]+\\)\\*" nil t
)
737 (let ((num (string-to-number (match-string 1)))
738 (line (buffer-substring (point) (line-end-position))))
739 (goto-char (line-beginning-position))
743 (setq num
(1- num
))))))
745 (defun calc-edit-macro-adjust-buffer ()
746 (calc-edit-macro-repeats)
747 (goto-char calc-edit-top
)
748 (while (re-search-forward "^RET$" nil t
)
750 (goto-char calc-edit-top
)
751 (while (and (re-search-forward "^$" nil t
)
752 (not (= (point) (point-max))))
755 (defun calc-edit-macro-command ()
756 "Return the command on the current line in a Calc macro editing buffer."
757 (let ((beg (line-beginning-position))
759 (if (search-forward ";;" (line-end-position) 1)
761 (skip-chars-backward " \t")
763 (buffer-substring beg end
)))
765 (defun calc-edit-macro-command-type ()
766 "Return the type of command on the current line in a Calc macro editing buffer."
767 (let ((beg (save-excursion
768 (if (search-forward ";;" (line-end-position) t
)
770 (skip-chars-forward " \t")
773 (goto-char (line-end-position))
774 (skip-chars-backward " \t")
777 (buffer-substring beg end
)
780 (defun calc-edit-macro-combine-alg-ent ()
781 "Put an entire algebraic entry on a single line."
782 (let ((line (calc-edit-macro-command))
783 (type (calc-edit-macro-command-type))
786 (goto-char (line-beginning-position))
788 (setq curline
(calc-edit-macro-command))
790 (not (string-equal "RET" curline
))
791 (not (setq match
(string-match "<return>" curline
))))
792 (setq line
(concat line curline
))
794 (setq curline
(calc-edit-macro-command)))
797 (setq line
(concat line
(substring curline
0 match
))))
798 (setq line
(replace-regexp-in-string "SPC" " SPC "
799 (replace-regexp-in-string " " "" line
)))
800 (insert line
"\t\t\t")
801 (if (> (current-column) 24)
803 (insert ";; " type
"\n")
805 (insert "RET\t\t\t;; calc-enter\n"))))
807 (defun calc-edit-macro-combine-ext-command ()
808 "Put an entire extended command on a single line."
809 (let ((cmdbeg (calc-edit-macro-command))
811 (type (calc-edit-macro-command-type))
814 (goto-char (line-beginning-position))
816 (setq curline
(calc-edit-macro-command))
818 (not (string-equal "RET" curline
))
819 (not (setq match
(string-match "<return>" curline
))))
820 (setq line
(concat line curline
))
822 (setq curline
(calc-edit-macro-command)))
825 (setq line
(concat line
(substring curline
0 match
))))
826 (setq line
(replace-regexp-in-string " " "" line
))
827 (insert cmdbeg
" " line
"\t\t\t")
828 (if (> (current-column) 24)
830 (insert ";; " type
"\n")
832 (insert "RET\t\t\t;; calc-enter\n"))))
834 (defun calc-edit-macro-combine-var-name ()
835 "Put an entire variable name on a single line."
836 (let ((line (calc-edit-macro-command))
839 (goto-char (line-beginning-position))
841 (if (member line
'("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
842 (insert line
"\t\t\t;; calc quick variable\n")
843 (setq curline
(calc-edit-macro-command))
845 (not (string-equal "RET" curline
))
846 (not (setq match
(string-match "<return>" curline
))))
847 (setq line
(concat line curline
))
849 (setq curline
(calc-edit-macro-command)))
852 (setq line
(concat line
(substring curline
0 match
))))
853 (setq line
(replace-regexp-in-string " " "" line
))
854 (insert line
"\t\t\t")
855 (if (> (current-column) 24)
857 (insert ";; calc variable\n")
859 (insert "RET\t\t\t;; calc-enter\n")))))
861 (defun calc-edit-macro-combine-digits ()
862 "Put an entire sequence of digits on a single line."
863 (let ((line (calc-edit-macro-command))
865 (goto-char (line-beginning-position))
867 (while (string-equal (calc-edit-macro-command-type) "calcDigit-start")
868 (setq line
(concat line
(calc-edit-macro-command)))
870 (insert line
"\t\t\t")
871 (if (> (current-column) 24)
873 (insert ";; calc digits\n")))
875 (defun calc-edit-format-macro-buffer ()
876 "Rewrite the Calc macro editing buffer."
877 (calc-edit-macro-adjust-buffer)
878 (goto-char calc-edit-top
)
879 (let ((type (calc-edit-macro-command-type)))
880 (while (not (string-equal type
""))
883 (string-equal type
"calc-algebraic-entry")
884 (string-equal type
"calc-auto-algebraic-entry"))
885 (calc-edit-macro-combine-alg-ent))
886 ((string-equal type
"calc-execute-extended-command")
887 (calc-edit-macro-combine-ext-command))
888 ((string-equal type
"calcDigit-start")
889 (calc-edit-macro-combine-digits))
891 (string-equal type
"calc-store")
892 (string-equal type
"calc-store-into")
893 (string-equal type
"calc-store-neg")
894 (string-equal type
"calc-store-plus")
895 (string-equal type
"calc-store-minus")
896 (string-equal type
"calc-store-div")
897 (string-equal type
"calc-store-times")
898 (string-equal type
"calc-store-power")
899 (string-equal type
"calc-store-concat")
900 (string-equal type
"calc-store-inv")
901 (string-equal type
"calc-store-dec")
902 (string-equal type
"calc-store-incr")
903 (string-equal type
"calc-store-exchange")
904 (string-equal type
"calc-unstore")
905 (string-equal type
"calc-recall")
906 (string-equal type
"calc-let")
907 (string-equal type
"calc-permanent-variable"))
909 (calc-edit-macro-combine-var-name))
911 (string-equal type
"calc-copy-variable")
912 (string-equal type
"calc-copy-special-constant")
913 (string-equal type
"calc-declare-variable"))
915 (calc-edit-macro-combine-var-name)
916 (calc-edit-macro-combine-var-name))
917 (t (forward-line 1)))
918 (setq type
(calc-edit-macro-command-type))))
919 (goto-char calc-edit-top
))
921 ;; Finish editing the macro
923 (defun calc-edit-macro-pre-finish-edit ()
924 (goto-char calc-edit-top
)
925 (while (re-search-forward "\\(^\\| \\)RET\\($\\|\t\\| \\)" nil t
)
926 (search-backward "RET")
928 (insert "<return>")))
930 (defun calc-edit-macro-finish-edit (cmdname key
)
931 "Finish editing a Calc macro.
932 Redefine the corresponding command."
934 (let ((cmd (intern cmdname
)))
935 (calc-edit-macro-pre-finish-edit)
936 (let* ((str (buffer-substring calc-edit-top
(point-max)))
937 (mac (edmacro-parse-keys str t
)))
938 (if (= (length mac
) 0)
943 (list 'calc-execute-kbd-macro
944 (vector (key-description mac
)
948 (defun calc-finish-formula-edit (func)
949 (let ((buf (current-buffer))
950 (str (buffer-substring calc-edit-top
(point-max)))
952 (body (calc-valid-formula-func func
)))
953 (set-buffer calc-original-buffer
)
954 (let ((val (math-read-expr str
)))
955 (if (eq (car-safe val
) 'error
)
958 (goto-char (+ start
(nth 1 val
)))
959 (error (nth 2 val
))))
961 (let ((calc-user-formula-alist (nth 1 (symbol-function func
))))
962 (calc-fix-user-formula val
)))
963 (put func
'calc-user-defn val
))))
965 (defun calc-valid-formula-func (func)
966 (let ((def (symbol-function func
)))
968 (eq (car def
) 'lambda
)
970 (setq def
(cdr (cdr def
)))
972 (not (eq (car (car def
)) 'math-normalize
)))
973 (setq def
(cdr def
)))
977 (defun calc-get-user-defn ()
980 (message "Get definition of command: z-")
981 (let* ((key (read-char))
982 (def (or (assq key
(calc-user-key-map))
983 (assq (upcase key
) (calc-user-key-map))
984 (assq (downcase key
) (calc-user-key-map))
985 (error "No command defined for that key")))
988 (setq cmd
(symbol-function cmd
)))
990 (message "Keyboard macro: %s" cmd
))
991 (t (let* ((func (calc-stack-command-p cmd
))
994 (get func
'calc-user-defn
))))
997 (and (calc-valid-formula-func func
)
998 (setq defn
(append '(calcFunc-lambda)
999 (mapcar 'math-build-var-name
1000 (nth 1 (symbol-function
1003 (calc-enter-result 0 "gdef" defn
))
1004 (error "That command is not defined by a formula"))))))))
1007 (defun calc-user-define-permanent ()
1010 (message "Record in %s the command: z-" calc-settings-file
)
1011 (let* ((key (read-char))
1012 (def (or (assq key
(calc-user-key-map))
1013 (assq (upcase key
) (calc-user-key-map))
1014 (assq (downcase key
) (calc-user-key-map))
1020 (format "Record in %s the algebraic function: "
1022 (mapcar (lambda (x) (substring x
9))
1023 (all-completions "calcFunc-"
1027 (intern (concat "calcFunc-" x
))))
1031 (intern (completing-read
1032 (format "Record in %s the command: "
1034 obarray
'fboundp nil
"calc-"))))
1035 (error "No command defined for that key"))))
1036 (set-buffer (find-file-noselect (substitute-in-file-name
1037 calc-settings-file
)))
1038 (goto-char (point-max))
1039 (let* ((cmd (cdr def
))
1040 (fcmd (and cmd
(symbolp cmd
) (symbol-function cmd
)))
1046 (insert "\n;;; Definition stored by Calc on " (current-time-string)
1047 "\n(put 'calc-define '"
1048 (if (symbolp cmd
) (symbol-name cmd
) (format "key%d" key
))
1051 (eq (car-safe fcmd
) 'lambda
)
1052 (get cmd
'calc-user-defn
))
1054 (and (eq (car-safe (nth 3 fcmd
)) 'calc-execute-kbd-macro
)
1055 (vectorp (nth 1 (nth 3 fcmd
)))
1056 (progn (and (fboundp 'edit-kbd-macro
)
1057 (edit-kbd-macro nil
))
1058 (fboundp 'edmacro-parse-keys
))
1060 (aset (nth 1 (nth 3 fcmd
)) 1 nil
))
1061 (insert (setq str
(prin1-to-string
1062 (cons 'defun
(cons cmd
(cdr fcmd
)))))
1064 (or (and (string-match "\"" str
) (not q-ok
))
1065 (fill-region pt
(point)))
1066 (indent-rigidly pt
(point) 2)
1067 (delete-region pt
(1+ pt
))
1068 (insert " (put '" (symbol-name cmd
)
1069 " 'calc-user-defn '"
1070 (prin1-to-string (get cmd
'calc-user-defn
))
1072 (setq func
(calc-stack-command-p cmd
))
1073 (let ((ffunc (and func
(symbolp func
) (symbol-function func
)))
1076 (eq (car-safe ffunc
) 'lambda
)
1077 (get func
'calc-user-defn
)
1079 (insert (setq str
(prin1-to-string
1080 (cons 'defun
(cons func
1083 (or (and (string-match "\"" str
) (not q-ok
))
1084 (fill-region pt
(point)))
1085 (indent-rigidly pt
(point) 2)
1086 (delete-region pt
(1+ pt
))
1088 (insert "(put '" (symbol-name func
)
1089 " 'calc-user-defn '"
1090 (prin1-to-string (get func
'calc-user-defn
))
1092 (fill-region pt
(point))
1093 (indent-rigidly pt
(point) 2)
1094 (delete-region pt
(1+ pt
))))))
1096 (insert " (fset '" (prin1-to-string cmd
)
1097 " " (prin1-to-string fcmd
) ")\n")))
1098 (or func
(setq func
(and cmd
(symbolp cmd
) (fboundp cmd
) cmd
)))
1099 (if (get func
'math-compose-forms
)
1101 (insert "(put '" (symbol-name cmd
)
1102 " 'math-compose-forms '"
1103 (prin1-to-string (get func
'math-compose-forms
))
1105 (fill-region pt
(point))
1106 (indent-rigidly pt
(point) 2)
1107 (delete-region pt
(1+ pt
))))
1109 (insert " (define-key calc-mode-map "
1110 (prin1-to-string (concat "z" (char-to-string key
)))
1112 (prin1-to-string cmd
)
1117 (defun calc-stack-command-p (cmd)
1118 (if (and cmd
(symbolp cmd
))
1120 (calc-stack-command-p (symbol-function cmd
)))
1122 (eq (car cmd
) 'lambda
)
1123 (setq cmd
(or (assq 'calc-wrapper cmd
)
1124 (assq 'calc-slow-wrapper cmd
)))
1125 (setq cmd
(assq 'calc-enter-result cmd
))
1126 (memq (car (nth 3 cmd
)) '(cons list
))
1127 (eq (car (nth 1 (nth 3 cmd
))) 'quote
)
1128 (nth 1 (nth 1 (nth 3 cmd
))))))
1131 (defun calc-call-last-kbd-macro (arg)
1133 (and defining-kbd-macro
1134 (error "Can't execute anonymous macro while defining one"))
1136 (error "No kbd macro has been defined"))
1137 (calc-execute-kbd-macro last-kbd-macro arg
))
1139 (defun calc-execute-kbd-macro (mac arg
&rest prefix
)
1140 (if calc-keep-args-flag
1142 (if (and (vectorp mac
) (> (length mac
) 0) (stringp (aref mac
0)))
1143 (setq mac
(or (aref mac
1)
1144 (aset mac
1 (progn (and (fboundp 'edit-kbd-macro
)
1145 (edit-kbd-macro nil
))
1146 (edmacro-parse-keys (aref mac
0)))))))
1147 (if (< (prefix-numeric-value arg
) 0)
1148 (execute-kbd-macro mac
(- (prefix-numeric-value arg
)))
1149 (if calc-executing-macro
1150 (execute-kbd-macro mac arg
)
1152 (let ((old-stack-whole (copy-sequence calc-stack
))
1153 (old-stack-top calc-stack-top
)
1154 (old-buffer-size (buffer-size))
1155 (old-refresh-count calc-refresh-count
))
1157 (let ((calc-executing-macro mac
))
1158 (execute-kbd-macro mac arg
))
1159 (calc-select-buffer)
1160 (let ((new-stack (reverse calc-stack
))
1161 (old-stack (reverse old-stack-whole
)))
1162 (while (and new-stack old-stack
1163 (equal (car new-stack
) (car old-stack
)))
1164 (setq new-stack
(cdr new-stack
)
1165 old-stack
(cdr old-stack
)))
1166 (or (equal prefix
'(nil))
1167 (calc-record-list (if (> (length new-stack
) 1)
1168 (mapcar 'car new-stack
)
1170 (or (car prefix
) "kmac")))
1171 (calc-record-undo (list 'set
'saved-stack-top old-stack-top
))
1173 (calc-record-undo (list 'pop
1 (mapcar 'car old-stack
))))
1174 (let ((calc-stack old-stack-whole
)
1176 (calc-cursor-stack-index (length old-stack
)))
1177 (if (and (= old-buffer-size
(buffer-size))
1178 (= old-refresh-count calc-refresh-count
))
1179 (let ((buffer-read-only nil
))
1180 (delete-region (point) (point-max))
1182 (calc-record-undo (list 'push
1))
1183 (insert (math-format-stack-value (car new-stack
)) "\n")
1184 (setq new-stack
(cdr new-stack
)))
1185 (calc-renumber-stack))
1187 (calc-record-undo (list 'push
1))
1188 (setq new-stack
(cdr new-stack
)))
1190 (calc-record-undo (list 'set
'saved-stack-top
0)))))))))
1192 (defun calc-push-list-in-macro (vals m sels
)
1193 (let ((entry (list (car vals
) 1 (car sels
)))
1194 (mm (+ (or m
1) calc-stack-top
)))
1196 (setcdr (nthcdr (- mm
2) calc-stack
)
1197 (cons entry
(nthcdr (1- mm
) calc-stack
)))
1198 (setq calc-stack
(cons entry calc-stack
)))))
1200 (defun calc-pop-stack-in-macro (n mm
)
1202 (setcdr (nthcdr (- mm
2) calc-stack
)
1203 (nthcdr (+ n mm -
1) calc-stack
))
1204 (setq calc-stack
(nthcdr n calc-stack
))))
1207 (defun calc-kbd-if ()
1210 (let ((cond (calc-top-n 1)))
1212 (if (math-is-true cond
)
1213 (if defining-kbd-macro
1214 (message "If true..."))
1215 (if defining-kbd-macro
1216 (message "Condition is false; skipping to Z: or Z] ..."))
1217 (calc-kbd-skip-to-else-if t
)))))
1219 (defun calc-kbd-else-if ()
1223 (defun calc-kbd-skip-to-else-if (else-okay)
1227 (setq ch
(read-char))
1229 (error "Unterminated Z[ in keyboard macro"))
1232 (setq ch
(read-char))
1234 (setq count
(1+ count
)))
1236 (setq count
(1- count
)))
1242 (keyboard-quit))))))
1243 (and defining-kbd-macro
1246 (message "End-if...")))))
1248 (defun calc-kbd-end-if ()
1250 (if defining-kbd-macro
1251 (message "End-if...")))
1253 (defun calc-kbd-else ()
1255 (if defining-kbd-macro
1256 (message "Else; skipping to Z] ..."))
1257 (calc-kbd-skip-to-else-if nil
))
1260 (defun calc-kbd-repeat ()
1264 (setq count
(math-trunc (calc-top-n 1)))
1265 (or (Math-integerp count
)
1266 (error "Count must be an integer"))
1267 (if (Math-integer-negp count
)
1269 (or (integerp count
)
1270 (setq count
1000000))
1272 (calc-kbd-loop count
)))
1274 (defun calc-kbd-for (dir)
1278 (setq init
(calc-top-n 2)
1279 final
(calc-top-n 1))
1280 (or (and (math-anglep init
) (math-anglep final
))
1281 (error "Initial and final values must be real numbers"))
1283 (calc-kbd-loop nil init final
(and dir
(prefix-numeric-value dir
)))))
1285 (defun calc-kbd-loop (rpt-count &optional initial final dir
)
1287 (setq rpt-count
(if rpt-count
(prefix-numeric-value rpt-count
) 1000000))
1291 (open last-command-event
)
1294 (or executing-kbd-macro
1295 (message "Reading loop body..."))
1297 (setq ch
(read-char))
1299 (error "Unterminated Z%c in keyboard macro" open
))
1302 (setq ch
(read-char)
1303 body
(concat body
"Z" (char-to-string ch
)))
1304 (cond ((memq ch
'(?\
< ?\
( ?\
{))
1305 (setq count
(1+ count
)))
1306 ((memq ch
'(?\
> ?\
) ?\
}))
1307 (setq count
(1- count
)))
1310 (setq parts
(nconc parts
(list (concat (substring body
0 -
2)
1315 (setq body
(concat body
(char-to-string ch
)))))
1316 (if (/= ch
(cdr (assq open
'( (?\
< . ?\
>) (?\
( . ?\
)) (?\
{ . ?\
}) ))))
1317 (error "Mismatched Z%c and Z%c in keyboard macro" open ch
))
1318 (or executing-kbd-macro
1319 (message "Looping..."))
1320 (setq body
(concat (substring body
0 -
2) "Z]"))
1321 (and (not executing-kbd-macro
)
1322 (= rpt-count
1000000)
1326 (message "Warning: Infinite loop! Not executing")
1327 (setq rpt-count
0)))
1328 (or (not initial
) dir
1329 (setq dir
(math-compare final initial
)))
1331 (while (> rpt-count
0)
1334 (if (cond ((eq dir
0) (Math-equal final counter
))
1335 ((eq dir
1) (Math-lessp final counter
))
1336 ((eq dir -
1) (Math-lessp counter final
)))
1338 (calc-push counter
)))
1339 (while (and part
(> rpt-count
0))
1340 (execute-kbd-macro (car part
))
1341 (if (math-is-true (calc-top-n 1))
1343 (setq part
(cdr part
)))
1347 (execute-kbd-macro body
)
1349 (let ((step (calc-top-n 1)))
1351 (setq counter
(calcFunc-add counter step
)))
1352 (setq rpt-count
(1- rpt-count
))))))))
1353 (or executing-kbd-macro
1354 (message "Looping...done"))))
1356 (defun calc-kbd-end-repeat ()
1358 (error "Unbalanced Z> in keyboard macro"))
1360 (defun calc-kbd-end-for ()
1362 (error "Unbalanced Z) in keyboard macro"))
1364 (defun calc-kbd-end-loop ()
1366 (error "Unbalanced Z} in keyboard macro"))
1368 (defun calc-kbd-break ()
1371 (let ((cond (calc-top-n 1)))
1373 (if (math-is-true cond
)
1374 (error "Keyboard macro aborted")))))
1377 (defvar calc-kbd-push-level
0)
1379 ;; The variables var-q0 through var-q9 are the "quick" variables.
1391 (defun calc-kbd-push (arg)
1394 (let* ((defs (and arg
(> (prefix-numeric-value arg
) 0)))
1405 (calc-internal-prec (if defs
12 calc-internal-prec
))
1406 (calc-word-size (if defs
32 calc-word-size
))
1407 (calc-angle-mode (if defs
'deg calc-angle-mode
))
1408 (calc-simplify-mode (if defs nil calc-simplify-mode
))
1409 (calc-algebraic-mode (if arg nil calc-algebraic-mode
))
1410 (calc-incomplete-algebraic-mode (if arg nil
1411 calc-incomplete-algebraic-mode
))
1412 (calc-symbolic-mode (if defs nil calc-symbolic-mode
))
1413 (calc-matrix-mode (if defs nil calc-matrix-mode
))
1414 (calc-prefer-frac (if defs nil calc-prefer-frac
))
1415 (calc-complex-mode (if defs nil calc-complex-mode
))
1416 (calc-infinite-mode (if defs nil calc-infinite-mode
))
1420 (if (or executing-kbd-macro defining-kbd-macro
)
1422 (if defining-kbd-macro
1423 (message "Reading body..."))
1425 (setq ch
(read-char))
1427 (error "Unterminated Z` in keyboard macro"))
1430 (setq ch
(read-char)
1431 body
(concat body
"Z" (char-to-string ch
)))
1433 (setq count
(1+ count
)))
1435 (setq count
(1- count
)))
1438 (setq body
(concat body
(char-to-string ch
)))))
1439 (if defining-kbd-macro
1440 (message "Reading body...done"))
1441 (let ((calc-kbd-push-level 0))
1442 (execute-kbd-macro (substring body
0 -
2))))
1443 (let ((calc-kbd-push-level (1+ calc-kbd-push-level
)))
1444 (message "Saving modes; type Z' to restore")
1445 (recursive-edit))))))
1447 (defun calc-kbd-pop ()
1449 (if (> calc-kbd-push-level
0)
1451 (message "Mode settings restored")
1452 (exit-recursive-edit))
1453 (error "Unbalanced Z' in keyboard macro")))
1456 ;; (defun calc-kbd-report (msg)
1457 ;; (interactive "sMessage: ")
1459 ;; (math-working msg (calc-top-n 1))))
1461 (defun calc-kbd-query ()
1463 (let ((defining-kbd-macro nil
)
1464 (executing-kbd-macro nil
)
1466 (if (not (eq (car-safe msg
) 'vec
))
1467 (error "No prompt string provided")
1468 (setq msg
(math-vector-to-string msg
))
1471 (calc-alg-entry nil
(and (not (equal msg
"")) msg
))))))
1473 ;;;; Logical operations.
1475 (defun calcFunc-eq (a b
&rest more
)
1477 (let* ((args (cons a
(cons b
(copy-sequence more
))))
1481 (while (and (cdr p
) (not (eq res
0)))
1483 (while (and (setq p2
(cdr p2
)) (not (eq res
0)))
1484 (setq res
(math-two-eq (car p
) (car p2
)))
1486 (setcdr p
(delq (car p2
) (cdr p
)))))
1491 (cons 'calcFunc-eq args
)
1493 (or (math-two-eq a b
)
1494 (if (and (or (math-looks-negp a
) (math-zerop a
))
1495 (or (math-looks-negp b
) (math-zerop b
)))
1496 (list 'calcFunc-eq
(math-neg a
) (math-neg b
))
1497 (list 'calcFunc-eq a b
)))))
1499 (defun calcFunc-neq (a b
&rest more
)
1501 (let* ((args (cons a
(cons b more
)))
1506 (while (and (cdr p
) (not (eq res
1)))
1508 (while (and (setq p2
(cdr p2
)) (not (eq res
1)))
1509 (setq res
(math-two-eq (car p
) (car p2
)))
1510 (or res
(setq all nil
)))
1516 (cons 'calcFunc-neq args
))))
1517 (or (cdr (assq (math-two-eq a b
) '((0 .
1) (1 .
0))))
1518 (if (and (or (math-looks-negp a
) (math-zerop a
))
1519 (or (math-looks-negp b
) (math-zerop b
)))
1520 (list 'calcFunc-neq
(math-neg a
) (math-neg b
))
1521 (list 'calcFunc-neq a b
)))))
1523 (defun math-two-eq (a b
)
1524 (if (eq (car-safe a
) 'vec
)
1525 (if (eq (car-safe b
) 'vec
)
1526 (if (= (length a
) (length b
))
1528 (while (and (setq a
(cdr a
) b
(cdr b
)) (not (eq res
0)))
1530 (setq res
(math-two-eq (car a
) (car b
)))
1531 (if (eq (math-two-eq (car a
) (car b
)) 0)
1535 (if (Math-objectp b
)
1538 (if (eq (car-safe b
) 'vec
)
1539 (if (Math-objectp a
)
1542 (let ((res (math-compare a b
)))
1545 (if (and (= res
2) (not (and (Math-scalarp a
) (Math-scalarp b
))))
1549 (defun calcFunc-lt (a b
)
1550 (let ((res (math-compare a b
)))
1554 (if (and (or (math-looks-negp a
) (math-zerop a
))
1555 (or (math-looks-negp b
) (math-zerop b
)))
1556 (list 'calcFunc-gt
(math-neg a
) (math-neg b
))
1557 (list 'calcFunc-lt a b
))
1560 (defun calcFunc-gt (a b
)
1561 (let ((res (math-compare a b
)))
1565 (if (and (or (math-looks-negp a
) (math-zerop a
))
1566 (or (math-looks-negp b
) (math-zerop b
)))
1567 (list 'calcFunc-lt
(math-neg a
) (math-neg b
))
1568 (list 'calcFunc-gt a b
))
1571 (defun calcFunc-leq (a b
)
1572 (let ((res (math-compare a b
)))
1576 (if (and (or (math-looks-negp a
) (math-zerop a
))
1577 (or (math-looks-negp b
) (math-zerop b
)))
1578 (list 'calcFunc-geq
(math-neg a
) (math-neg b
))
1579 (list 'calcFunc-leq a b
))
1582 (defun calcFunc-geq (a b
)
1583 (let ((res (math-compare a b
)))
1587 (if (and (or (math-looks-negp a
) (math-zerop a
))
1588 (or (math-looks-negp b
) (math-zerop b
)))
1589 (list 'calcFunc-leq
(math-neg a
) (math-neg b
))
1590 (list 'calcFunc-geq a b
))
1593 (defun calcFunc-rmeq (a)
1594 (if (math-vectorp a
)
1595 (math-map-vec 'calcFunc-rmeq a
)
1596 (if (assq (car-safe a
) calc-tweak-eqn-table
)
1597 (if (and (eq (car-safe (nth 2 a
)) 'var
)
1598 (math-objectp (nth 1 a
)))
1601 (if (eq (car-safe a
) 'calcFunc-assign
)
1603 (if (eq (car-safe a
) 'calcFunc-evalto
)
1605 (list 'calcFunc-rmeq a
))))))
1607 (defun calcFunc-land (a b
)
1608 (cond ((Math-zerop a
)
1616 (t (list 'calcFunc-land a b
))))
1618 (defun calcFunc-lor (a b
)
1619 (cond ((Math-zerop a
)
1627 (t (list 'calcFunc-lor a b
))))
1629 (defun calcFunc-lnot (a)
1632 (if (math-is-true a
)
1634 (let ((op (and (= (length a
) 3)
1635 (assq (car a
) calc-tweak-eqn-table
))))
1637 (cons (nth 2 op
) (cdr a
))
1638 (list 'calcFunc-lnot a
))))))
1640 (defun calcFunc-if (c e1 e2
)
1643 (if (and (math-is-true c
) (not (Math-vectorp c
)))
1645 (or (and (Math-vectorp c
)
1647 (let ((ee1 (if (Math-vectorp e1
)
1648 (if (= (length c
) (length e1
))
1650 (calc-record-why "*Dimension error" e1
))
1652 (ee2 (if (Math-vectorp e2
)
1653 (if (= (length c
) (length e2
))
1655 (calc-record-why "*Dimension error" e2
))
1658 (cons 'vec
(math-if-vector (cdr c
) ee1 ee2
)))))
1659 (list 'calcFunc-if c e1 e2
)))))
1661 (defun math-if-vector (c e1 e2
)
1663 (cons (if (Math-zerop (car c
)) (car e2
) (car e1
))
1664 (math-if-vector (cdr c
)
1666 (or (cdr e2
) e2
)))))
1668 (defun math-normalize-logical-op (a)
1669 (or (and (eq (car a
) 'calcFunc-if
)
1671 (let ((a1 (math-normalize (nth 1 a
))))
1673 (math-normalize (nth 3 a
))
1674 (if (Math-numberp a1
)
1675 (math-normalize (nth 2 a
))
1676 (if (and (Math-vectorp (nth 1 a
))
1677 (math-constp (nth 1 a
)))
1678 (calcFunc-if (nth 1 a
)
1679 (math-normalize (nth 2 a
))
1680 (math-normalize (nth 3 a
)))
1681 (let ((calc-simplify-mode 'none
))
1682 (list 'calcFunc-if a1
1683 (math-normalize (nth 2 a
))
1684 (math-normalize (nth 3 a
)))))))))
1687 (defun calcFunc-in (a b
)
1688 (or (and (eq (car-safe b
) 'vec
)
1690 (while (and (setq bb
(cdr bb
))
1691 (not (if (memq (car-safe (car bb
)) '(vec intv
))
1692 (eq (calcFunc-in a
(car bb
)) 1)
1693 (Math-equal a
(car bb
))))))
1694 (if bb
1 (and (math-constp a
) (math-constp bb
) 0))))
1695 (and (eq (car-safe b
) 'intv
)
1696 (let ((res (math-compare a
(nth 2 b
))) res2
)
1700 (or (/= (nth 1 b
) 2)
1701 (Math-lessp (nth 2 b
) (nth 3 b
))))
1702 (if (memq (nth 1 b
) '(2 3)) 1 0))
1703 ((= (setq res2
(math-compare a
(nth 3 b
))) 1)
1706 (or (/= (nth 1 b
) 1)
1707 (Math-lessp (nth 2 b
) (nth 3 b
))))
1708 (if (memq (nth 1 b
) '(1 3)) 1 0))
1714 (and (Math-equal a b
)
1716 (and (math-constp a
) (math-constp b
)
1718 (list 'calcFunc-in a b
)))
1720 (defun calcFunc-typeof (a)
1721 (cond ((Math-integerp a
) 1)
1722 ((eq (car a
) 'frac
) 2)
1723 ((eq (car a
) 'float
) 3)
1724 ((eq (car a
) 'hms
) 4)
1725 ((eq (car a
) 'cplx
) 5)
1726 ((eq (car a
) 'polar
) 6)
1727 ((eq (car a
) 'sdev
) 7)
1728 ((eq (car a
) 'intv
) 8)
1729 ((eq (car a
) 'mod
) 9)
1730 ((eq (car a
) 'date
) (if (Math-integerp (nth 1 a
)) 10 11))
1732 (if (memq (nth 2 a
) '(var-inf var-uinf var-nan
)) 12 100))
1733 ((eq (car a
) 'vec
) (if (math-matrixp a
) 102 101))
1734 (t (math-calcFunc-to-var (car a
)))))
1736 (defun calcFunc-integer (a)
1737 (if (Math-integerp a
)
1739 (if (Math-objvecp a
)
1741 (list 'calcFunc-integer a
))))
1743 (defun calcFunc-real (a)
1746 (if (Math-objvecp a
)
1748 (list 'calcFunc-real a
))))
1750 (defun calcFunc-constant (a)
1753 (if (Math-objvecp a
)
1755 (list 'calcFunc-constant a
))))
1757 (defun calcFunc-refers (a b
)
1758 (if (math-expr-contains a b
)
1760 (if (eq (car-safe a
) 'var
)
1761 (list 'calcFunc-refers a b
)
1764 (defun calcFunc-negative (a)
1765 (if (math-looks-negp a
)
1767 (if (or (math-zerop a
)
1770 (list 'calcFunc-negative a
))))
1772 (defun calcFunc-variable (a)
1773 (if (eq (car-safe a
) 'var
)
1775 (if (Math-objvecp a
)
1777 (list 'calcFunc-variable a
))))
1779 (defun calcFunc-nonvar (a)
1780 (if (eq (car-safe a
) 'var
)
1781 (list 'calcFunc-nonvar a
)
1784 (defun calcFunc-istrue (a)
1785 (if (math-is-true a
)
1791 ;;;; User-programmability.
1793 ;;; Compiling Lisp-like forms to use the math library.
1795 (defun math-do-defmath (func args body
)
1796 (require 'calc-macs
)
1797 (let* ((fname (intern (concat "calcFunc-" (symbol-name func
))))
1798 (doc (if (stringp (car body
))
1799 (prog1 (list (car body
))
1800 (setq body
(cdr body
)))))
1801 (clargs (mapcar 'math-clean-arg args
))
1802 (inter (if (and (consp (car body
))
1803 (eq (car (car body
)) 'interactive
))
1805 (setq body
(cdr body
))))))
1806 (setq body
(math-define-function-body body clargs
))
1809 (if (or (> (length inter
) 2)
1810 (integerp (nth 1 inter
)))
1811 (let ((hasprefix nil
) (hasmulti nil
))
1812 (when (stringp (nth 1 inter
))
1813 (cond ((equal (nth 1 inter
) "p")
1815 ((equal (nth 1 inter
) "m")
1818 "Can't handle interactive code string \"%s\""
1820 (setq inter
(cdr inter
)))
1821 (unless (integerp (nth 1 inter
))
1822 (error "Expected an integer in interactive specification"))
1823 `(defun ,(intern (concat "calc-" (symbol-name func
)))
1824 ,(if (or hasprefix hasmulti
) '(&optional n
) ())
1826 (interactive ,@(if (or hasprefix hasmulti
) '("P")))
1830 (prefix-numeric-value n
)
1833 ,(if hasmulti
'n
(nth 1 inter
))
1837 (calc-top-list-n ,(nth 1 inter
))
1841 (prefix-numeric-value n
)))))
1846 (nth 1 inter
)))))))))
1847 `(defun ,(intern (concat "calc-" (symbol-name func
))) ,clargs
1850 (calc-wrapper ,@body
))))
1851 (defun ,fname
,clargs
1853 ,@(math-do-arg-list-check args nil nil
)
1856 (defun math-clean-arg (arg)
1858 (math-clean-arg (nth 1 arg
))
1861 (defun math-do-arg-check (arg var is-opt is-rest
)
1863 (let ((chk (math-do-arg-check arg var nil nil
)))
1870 (let* ((rest (math-do-arg-check (nth 1 arg
) var is-opt is-rest
))
1872 (qual-name (symbol-name qual
))
1873 (chk (intern (concat "math-check-" qual-name
))))
1877 `((setq ,var
(mapcar ',chk
,var
)))
1878 `((setq ,var
(,chk
,var
)))))
1879 (if (fboundp (setq chk
(intern (concat "math-" qual-name
))))
1882 `((mapcar #'(lambda (x)
1884 (math-reject-arg x
',qual
)))
1887 (math-reject-arg ,var
',qual
)))))
1888 (if (and (string-match "\\`not-\\(.*\\)\\'" qual-name
)
1889 (fboundp (setq chk
(intern
1891 (math-match-substring
1895 `((mapcar #'(lambda (x)
1897 (math-reject-arg x
',qual
)))
1901 (math-reject-arg ,var
',qual
)))))
1902 (error "Unknown qualifier `%s'" qual-name
))))))))
1904 (defun math-do-arg-list-check (args is-opt is-rest
)
1905 (cond ((null args
) nil
)
1907 (append (math-do-arg-check (car args
)
1908 (math-clean-arg (car args
))
1910 (math-do-arg-list-check (cdr args
) is-opt is-rest
)))
1911 ((eq (car args
) '&optional
)
1912 (math-do-arg-list-check (cdr args
) t nil
))
1913 ((eq (car args
) '&rest
)
1914 (math-do-arg-list-check (cdr args
) nil t
))
1915 (t (math-do-arg-list-check (cdr args
) is-opt is-rest
))))
1917 (defconst math-prim-funcs
1918 '( (~
= . math-nearly-equal
)
1920 (lsh . calcFunc-lsh
)
1921 (ash . calcFunc-ash
)
1922 (logand . calcFunc-and
)
1923 (logandc2 . calcFunc-diff
)
1924 (logior . calcFunc-or
)
1925 (logxor . calcFunc-xor
)
1926 (lognot . calcFunc-not
)
1927 (equal . equal
) ; need to leave these ones alone!
1936 (defconst math-prim-vars
1939 (&optional .
&optional
)
1943 (defun math-define-function-body (body env
)
1944 (let ((body (math-define-body body env
)))
1945 (if (math-body-refers-to body
'math-return
)
1946 `((catch 'math-return
,@body
))
1949 ;; The variable math-exp-env is local to math-define-body, but is
1950 ;; used by math-define-exp, which is called (indirectly) by
1951 ;; by math-define-body.
1952 (defvar math-exp-env
)
1954 (defun math-define-body (body math-exp-env
)
1955 (math-define-list body
))
1957 (defun math-define-list (body &optional quote
)
1960 ((and (eq (car body
) ':)
1961 (stringp (nth 1 body
)))
1962 (cons (let* ((math-read-expr-quotes t
)
1963 (exp (math-read-plain-expr (nth 1 body
) t
)))
1964 (math-define-exp exp
))
1965 (math-define-list (cdr (cdr body
)))))
1967 (cons (cond ((consp (car body
))
1968 (math-define-list (cdr body
) t
))
1971 (math-define-list (cdr body
))))
1973 (cons (math-define-exp (car body
))
1974 (math-define-list (cdr body
))))))
1976 (defun math-define-exp (exp)
1978 (let ((func (car exp
)))
1979 (cond ((memq func
'(quote function
))
1980 (if (and (consp (nth 1 exp
))
1981 (eq (car (nth 1 exp
)) 'lambda
))
1983 (math-define-lambda (nth 1 exp
) math-exp-env
))
1985 ((memq func
'(let let
* for foreach
))
1986 (let ((head (nth 1 exp
))
1987 (body (cdr (cdr exp
))))
1988 (if (memq func
'(let let
*))
1990 (setq func
(cdr (assq func
'((for . math-for
)
1991 (foreach . math-foreach
)))))
1992 (if (not (listp (car head
)))
1993 (setq head
(list head
))))
1996 (cons (math-define-let head
)
1997 (math-define-body body
1999 (math-define-let-env head
)
2001 ((and (memq func
'(setq setf
))
2002 (math-complicated-lhs (cdr exp
)))
2003 (if (> (length exp
) 3)
2004 (cons 'progn
(math-define-setf-list (cdr exp
)))
2005 (math-define-setf (nth 1 exp
) (nth 2 exp
))))
2006 ((eq func
'condition-case
)
2009 (math-define-body (cdr (cdr exp
))
2014 (math-define-cond (cdr exp
))))
2015 ((and (consp func
) ; ('spam a b) == force use of plain spam
2016 (eq (car func
) 'quote
))
2017 (cons func
(math-define-list (cdr exp
))))
2019 (let ((args (math-define-list (cdr exp
)))
2020 (prim (assq func math-prim-funcs
)))
2022 (cons (cdr prim
) args
))
2024 (list 'eq
(car args
) '(quote float
)))
2026 (math-define-binop 'math-add
0
2027 (car args
) (cdr args
)))
2029 (if (= (length args
) 1)
2030 (cons 'math-neg args
)
2031 (math-define-binop 'math-sub
0
2032 (car args
) (cdr args
))))
2034 (math-define-binop 'math-mul
1
2035 (car args
) (cdr args
)))
2037 (math-define-binop 'math-div
1
2038 (car args
) (cdr args
)))
2040 (math-define-binop 'math-min
0
2041 (car args
) (cdr args
)))
2043 (math-define-binop 'math-max
0
2044 (car args
) (cdr args
)))
2046 (if (and (math-numberp (nth 1 args
))
2047 (math-zerop (nth 1 args
)))
2048 (list 'math-negp
(car args
))
2049 (cons 'math-lessp args
)))
2051 (if (and (math-numberp (nth 1 args
))
2052 (math-zerop (nth 1 args
)))
2053 (list 'math-posp
(car args
))
2054 (list 'math-lessp
(nth 1 args
) (nth 0 args
))))
2057 (if (and (math-numberp (nth 1 args
))
2058 (math-zerop (nth 1 args
)))
2059 (list 'math-posp
(car args
))
2061 (nth 1 args
) (nth 0 args
)))))
2064 (if (and (math-numberp (nth 1 args
))
2065 (math-zerop (nth 1 args
)))
2066 (list 'math-negp
(car args
))
2067 (cons 'math-lessp args
))))
2069 (if (and (math-numberp (nth 1 args
))
2070 (math-zerop (nth 1 args
)))
2071 (list 'math-zerop
(nth 0 args
))
2072 (if (and (integerp (nth 1 args
))
2073 (/= (%
(nth 1 args
) 10) 0))
2074 (cons 'math-equal-int args
)
2075 (cons 'math-equal args
))))
2078 (if (and (math-numberp (nth 1 args
))
2079 (math-zerop (nth 1 args
)))
2080 (list 'math-zerop
(nth 0 args
))
2081 (if (and (integerp (nth 1 args
))
2082 (/= (%
(nth 1 args
) 10) 0))
2083 (cons 'math-equal-int args
)
2084 (cons 'math-equal args
)))))
2086 (list 'math-add
(car args
) 1))
2088 (list 'math-add
(car args
) -
1))
2089 ((eq func
'not
) ; optimize (not (not x)) => x
2090 (if (eq (car-safe args
) func
)
2093 ((and (eq func
'elt
) (cdr (cdr args
)))
2094 (math-define-elt (car args
) (cdr args
)))
2097 (let* ((name (symbol-name func
))
2098 (cfunc (intern (concat "calcFunc-" name
)))
2099 (mfunc (intern (concat "math-" name
))))
2100 (cond ((fboundp cfunc
)
2105 (string-match "\\`calcFunc-.*" name
))
2108 (cons cfunc args
)))))))))
2109 (t (cons func
(math-define-list (cdr exp
))))))) ;;args
2111 (let ((prim (assq exp math-prim-vars
))
2112 (name (symbol-name exp
)))
2115 ((memq exp math-exp-env
)
2117 ((string-match "-" name
)
2120 (intern (concat "var-" name
))))))
2122 (if (or (<= exp -
1000000) (>= exp
1000000))
2123 (list 'quote
(math-normalize exp
))
2127 (defun math-define-cond (forms)
2129 (cons (math-define-list (car forms
))
2130 (math-define-cond (cdr forms
)))))
2132 (defun math-complicated-lhs (body)
2134 (or (not (symbolp (car body
)))
2135 (math-complicated-lhs (cdr (cdr body
))))))
2137 (defun math-define-setf-list (body)
2139 (cons (math-define-setf (nth 0 body
) (nth 1 body
))
2140 (math-define-setf-list (cdr (cdr body
))))))
2142 (defun math-define-setf (place value
)
2143 (setq place
(math-define-exp place
)
2144 value
(math-define-exp value
))
2145 (cond ((symbolp place
)
2146 (list 'setq place value
))
2147 ((eq (car-safe place
) 'nth
)
2148 (list 'setcar
(list 'nthcdr
(nth 1 place
) (nth 2 place
)) value
))
2149 ((eq (car-safe place
) 'elt
)
2150 (list 'setcar
(list 'nthcdr
(nth 2 place
) (nth 1 place
)) value
))
2151 ((eq (car-safe place
) 'car
)
2152 (list 'setcar
(nth 1 place
) value
))
2153 ((eq (car-safe place
) 'cdr
)
2154 (list 'setcdr
(nth 1 place
) value
))
2156 (error "Bad place form for setf: %s" place
))))
2158 (defun math-define-binop (op ident arg1 rest
)
2160 (math-define-binop op ident
2161 (list op arg1
(car rest
))
2165 (defun math-define-let (vlist)
2167 (cons (if (consp (car vlist
))
2168 (cons (car (car vlist
))
2169 (math-define-list (cdr (car vlist
))))
2171 (math-define-let (cdr vlist
)))))
2173 (defun math-define-let-env (vlist)
2175 (cons (if (consp (car vlist
))
2178 (math-define-let-env (cdr vlist
)))))
2180 (defun math-define-lambda (exp exp-env
)
2181 (nconc (list (nth 0 exp
) ; 'lambda
2182 (nth 1 exp
)) ; arg list
2183 (math-define-function-body (cdr (cdr exp
))
2184 (append (nth 1 exp
) exp-env
))))
2186 (defun math-define-elt (seq idx
)
2188 (math-define-elt (list 'elt seq
(car idx
)) (cdr idx
))
2193 ;;; Useful programming macros.
2195 (defmacro math-while
(head &rest body
)
2196 (let ((body (cons 'while
(cons head body
))))
2197 (if (math-body-refers-to body
'math-break
)
2198 (cons 'catch
(cons '(quote math-break
) (list body
)))
2200 ;; (put 'math-while 'lisp-indent-hook 1)
2202 (defmacro math-for
(head &rest body
)
2203 (let ((body (if head
2204 (math-handle-for head body
)
2205 (cons 'while
(cons t body
)))))
2206 (if (math-body-refers-to body
'math-break
)
2207 (cons 'catch
(cons '(quote math-break
) (list body
)))
2209 ;; (put 'math-for 'lisp-indent-hook 1)
2211 (defun math-handle-for (head body
)
2212 (let* ((var (nth 0 (car head
)))
2213 (init (nth 1 (car head
)))
2214 (limit (nth 2 (car head
)))
2215 (step (or (nth 3 (car head
)) 1))
2216 (body (if (cdr head
)
2217 (list (math-handle-for (cdr head
) body
))
2219 (all-ints (and (integerp init
) (integerp limit
) (integerp step
)))
2220 (const-limit (or (integerp limit
)
2221 (and (eq (car-safe limit
) 'quote
)
2222 (math-realp (nth 1 limit
)))))
2223 (const-step (or (integerp step
)
2224 (and (eq (car-safe step
) 'quote
)
2225 (math-realp (nth 1 step
)))))
2226 (save-limit (if const-limit limit
(make-symbol "<limit>")))
2227 (save-step (if const-step step
(make-symbol "<step>"))))
2229 (cons (append (if const-limit nil
(list (list save-limit limit
)))
2230 (if const-step nil
(list (list save-step step
)))
2231 (list (list var init
)))
2236 (list '<= var save-limit
)
2237 (list '>= var save-limit
))
2240 (if (or (math-posp step
)
2265 save-step
)))))))))))
2267 (defmacro math-foreach
(head &rest body
)
2268 (let ((body (math-handle-foreach head body
)))
2269 (if (math-body-refers-to body
'math-break
)
2270 (cons 'catch
(cons '(quote math-break
) (list body
)))
2272 ;; (put 'math-foreach 'lisp-indent-hook 1)
2274 (defun math-handle-foreach (head body
)
2275 (let ((var (nth 0 (car head
)))
2276 (data (nth 1 (car head
)))
2277 (body (if (cdr head
)
2278 (list (math-handle-foreach (cdr head
) body
))
2281 (cons (list (list var data
))
2288 (list 'cdr var
)))))))))))
2291 (defun math-body-refers-to (body thing
)
2292 (or (equal body thing
)
2294 (or (math-body-refers-to (car body
) thing
)
2295 (math-body-refers-to (cdr body
) thing
)))))
2297 (defun math-break (&optional value
)
2298 (throw 'math-break value
))
2300 (defun math-return (&optional value
)
2301 (throw 'math-return value
))
2307 (defun math-composite-inequalities (x op
)
2308 (if (memq (nth 1 op
) '(calcFunc-eq calcFunc-neq
))
2309 (if (eq (car x
) (nth 1 op
))
2310 (append x
(list (math-read-expr-level (nth 3 op
))))
2311 (throw 'syntax
"Syntax error"))
2314 (if (memq (nth 1 op
) '(calcFunc-lt calcFunc-leq
))
2315 (if (memq (car x
) '(calcFunc-lt calcFunc-leq
))
2317 (+ (if (eq (car x
) 'calcFunc-leq
) 2 0)
2318 (if (eq (nth 1 op
) 'calcFunc-leq
) 1 0))
2319 (nth 1 x
) (math-read-expr-level (nth 3 op
)))
2320 (throw 'syntax
"Syntax error"))
2321 (if (memq (car x
) '(calcFunc-gt calcFunc-geq
))
2323 (+ (if (eq (nth 1 op
) 'calcFunc-geq
) 2 0)
2324 (if (eq (car x
) 'calcFunc-geq
) 1 0))
2325 (math-read-expr-level (nth 3 op
)) (nth 1 x
))
2326 (throw 'syntax
"Syntax error"))))))
2328 (provide 'calc-prog
)
2330 ;;; calc-prog.el ends here