1 ;;; calc-prog.el --- user programmability functions for Calc
3 ;; Copyright (C) 1990-1993, 2001-2015 Free Software Foundation, Inc.
5 ;; Author: David Gillespie <daveg@synaptics.com>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 ;; This file is autoloaded from calc-ext.el.
30 (autoload 'edmacro-format-keys "edmacro")
31 (autoload 'edmacro-parse-keys "edmacro")
33 (defun calc-equal-to (arg)
36 (if (and (integerp arg) (> arg 2))
37 (calc-enter-result arg "eq" (cons 'calcFunc-eq (calc-top-list-n arg)))
38 (calc-binary-op "eq" 'calcFunc-eq arg))))
40 (defun calc-remove-equal (arg)
43 (calc-unary-op "rmeq" 'calcFunc-rmeq arg)))
45 (defun calc-not-equal-to (arg)
48 (if (and (integerp arg) (> arg 2))
49 (calc-enter-result arg "neq" (cons 'calcFunc-neq (calc-top-list-n arg)))
50 (calc-binary-op "neq" 'calcFunc-neq arg))))
52 (defun calc-less-than (arg)
55 (calc-binary-op "lt" 'calcFunc-lt arg)))
57 (defun calc-greater-than (arg)
60 (calc-binary-op "gt" 'calcFunc-gt arg)))
62 (defun calc-less-equal (arg)
65 (calc-binary-op "leq" 'calcFunc-leq arg)))
67 (defun calc-greater-equal (arg)
70 (calc-binary-op "geq" 'calcFunc-geq arg)))
72 (defun calc-in-set (arg)
75 (calc-binary-op "in" 'calcFunc-in arg)))
77 (defun calc-logical-and (arg)
80 (calc-binary-op "land" 'calcFunc-land arg 1)))
82 (defun calc-logical-or (arg)
85 (calc-binary-op "lor" 'calcFunc-lor arg 0)))
87 (defun calc-logical-not (arg)
90 (calc-unary-op "lnot" 'calcFunc-lnot arg)))
92 (defun calc-logical-if ()
95 (calc-enter-result 3 "if" (cons 'calcFunc-if (calc-top-list-n 3)))))
101 (defun calc-timing (n)
104 (calc-change-mode 'calc-timing n nil t)
105 (message (if calc-timing
106 "Reporting timing of slow commands in Trail"
107 "Not reporting timing of commands"))))
109 (defun calc-user-define ()
111 (message "Define user key: z-")
112 (let ((key (read-char)))
113 (if (= (calc-user-function-classify key) 0)
114 (error "Can't redefine \"?\" key"))
115 (let ((func (intern (completing-read (concat "Set key z "
123 (define-key calc-z-map (char-to-string key) func))))
125 (defun calc-user-undefine ()
127 (message "Undefine user key: z-")
128 (let ((key (read-char)))
129 (if (= (calc-user-function-classify key) 0)
130 (error "Can't undefine \"?\" key"))
131 (define-key calc-z-map
132 (or (lookup-key calc-z-map key)
133 (lookup-key calc-z-map (upcase key))
134 (lookup-key calc-z-map (downcase key))
135 (error "No such user key is defined"))
139 ;; math-integral-cache-state is originally declared in calcalg2.el,
140 ;; it is used in calc-user-define-variable.
141 (defvar math-integral-cache-state)
143 ;; calc-user-formula-alist is local to calc-user-define-formula,
144 ;; calc-user-define-composition and calc-finish-formula-edit,
145 ;; but is used by calc-fix-user-formula.
146 (defvar calc-user-formula-alist)
148 (defun calc-user-define-formula ()
151 (let* ((form (calc-top 1))
153 (is-lambda (and (eq (car-safe form) 'calcFunc-lambda)
154 (>= (length form) 2)))
155 odef key keyname cmd cmd-base cmd-base-default
156 func calc-user-formula-alist is-symb)
158 (setq math-arglist (mapcar (function (lambda (x) (nth 1 x)))
159 (nreverse (cdr (reverse (cdr form)))))
160 form (nth (1- (length form)) form))
161 (calc-default-formula-arglist form)
162 (setq math-arglist (sort math-arglist 'string-lessp)))
163 (message "Define user key: z-")
164 (setq key (read-char))
165 (if (= (calc-user-function-classify key) 0)
166 (error "Can't redefine \"?\" key"))
167 (setq key (and (not (memq key '(13 32))) key)
169 (if (or (and (<= ?0 key) (<= key ?9))
170 (and (<= ?a key) (<= key ?z))
171 (and (<= ?A key) (<= key ?Z)))
173 (format "%03d" key)))
174 odef (lookup-key calc-z-map key))
176 (setq keyname (format "%05d" (abs (% (random) 10000)))))
179 (setq cmd-base-default (concat "User-" keyname))
180 (setq cmd (completing-read
181 (concat "Define M-x command name (default calc-"
184 obarray 'commandp nil
185 (if (and odef (symbolp odef))
188 (if (or (string-equal cmd "")
189 (string-equal cmd "calc-"))
190 (setq cmd (concat "calc-User-" keyname)))
191 (setq cmd-base (and (string-match "\\`calc-\\(.+\\)\\'" cmd)
192 (math-match-substring cmd 1)))
193 (setq cmd (intern cmd))
199 (if (get cmd 'calc-user-defn)
200 (concat "Replace previous definition for "
201 (symbol-name cmd) "? ")
202 "That name conflicts with a built-in Emacs function. Replace this function? "))))))
205 (setq cmd-base-default
208 "\\`User-.+" cmd-base)
211 (substring cmd-base 5))
213 (concat "User" keyname)))
217 (concat "Define algebraic function name (default "
218 cmd-base-default "): ")
219 (mapcar (lambda (x) (substring x 9))
220 (all-completions "calcFunc-"
224 (intern (concat "calcFunc-" x))))
227 (if (string-equal func "calcFunc-")
228 (intern (concat "calcFunc-" cmd-base-default))
236 (if (get func 'calc-user-defn)
237 (concat "Replace previous definition for "
238 (symbol-name func) "? ")
239 "That name conflicts with a built-in Emacs function. Replace this function? "))))))
242 (setq func (intern (concat "calcFunc-User"
244 (and cmd (symbol-name cmd))
245 (format "%05d" (% (random) 10000)))))))
248 (setq calc-user-formula-alist math-arglist)
251 (setq calc-user-formula-alist
252 (read-from-minibuffer "Function argument list: "
254 (prin1-to-string math-arglist)
258 (and (not (calc-subsetp calc-user-formula-alist math-arglist))
260 "Okay for arguments that don't appear in formula to be ignored? "))))))
261 (setq is-symb (and calc-user-formula-alist
264 "Leave it symbolic for non-constant arguments? ")))
265 (setq calc-user-formula-alist
266 (mapcar (function (lambda (x)
267 (or (cdr (assq x '((nil . arg-nil)
269 x))) calc-user-formula-alist))
278 (list 'calc-enter-result
279 (length calc-user-formula-alist)
280 (let ((name (symbol-name (or func cmd))))
282 "\\([^-][^-]?[^-]?[^-]?\\)[^-]*\\'"
284 (math-match-substring name 1)))
287 (list 'calc-top-list-n
288 (length calc-user-formula-alist)))))))
289 (put cmd 'calc-user-defn t)))
290 (let ((body (list 'math-normalize (calc-fix-user-formula form))))
293 (list 'lambda calc-user-formula-alist)
295 (mapcar (function (lambda (v)
296 (list 'math-check-const v t)))
297 calc-user-formula-alist))
299 (put func 'calc-user-defn form)
300 (setq math-integral-cache-state nil)
302 (define-key calc-z-map (char-to-string key) cmd))))
304 (defvar math-arglist) ; dynamically bound in all callers
305 (defun calc-default-formula-arglist (form)
307 (if (eq (car form) 'var)
308 (if (or (memq (nth 1 form) math-arglist)
309 (math-const-var form))
311 (setq math-arglist (cons (nth 1 form) math-arglist)))
312 (calc-default-formula-arglist-step (cdr form)))))
314 (defun calc-default-formula-arglist-step (l)
317 (calc-default-formula-arglist (car l))
318 (calc-default-formula-arglist-step (cdr l)))))
320 (defun calc-subsetp (a b)
322 (and (memq (car a) b)
323 (calc-subsetp (cdr a) b))))
325 (defun calc-fix-user-formula (f)
328 (cond ((and (eq (car f) 'var)
329 (memq (setq temp (or (cdr (assq (nth 1 f) '((nil . arg-nil)
332 calc-user-formula-alist))
334 ((or (math-constp f) (eq (car f) 'var))
336 ((and (eq (car f) 'calcFunc-eval)
338 (list 'let '((calc-simplify-mode nil))
339 (list 'math-normalize (calc-fix-user-formula (nth 1 f)))))
340 ((and (eq (car f) 'calcFunc-evalsimp)
342 (list 'math-simplify (calc-fix-user-formula (nth 1 f))))
343 ((and (eq (car f) 'calcFunc-evalextsimp)
345 (list 'math-simplify-extended
346 (calc-fix-user-formula (nth 1 f))))
349 (cons (list 'quote (car f))
350 (mapcar 'calc-fix-user-formula (cdr f)))))))
353 (defun calc-user-define-composition ()
356 (if (eq calc-language 'unform)
357 (error "Can't define formats for unformatted mode"))
358 (let* ((comp (calc-top 1))
361 (completing-read "Define format for which function: "
362 (mapcar (lambda (x) (substring x 9))
363 (all-completions "calcFunc-"
367 (intern (concat "calcFunc-" x))))))))
368 (comps (get func 'math-compose-forms))
371 (calc-user-formula-alist nil))
372 (if (math-zerop comp)
373 (if (setq entry (assq calc-language comps))
374 (put func 'math-compose-forms (delq entry comps)))
375 (calc-default-formula-arglist comp)
376 (setq math-arglist (sort math-arglist 'string-lessp))
379 (setq calc-user-formula-alist
380 (read-from-minibuffer "Composition argument list: "
382 (prin1-to-string math-arglist)
386 (and (not (calc-subsetp calc-user-formula-alist math-arglist))
388 "Okay for arguments that don't appear in formula to be invisible? "))))
389 (or (setq entry (assq calc-language comps))
390 (put func 'math-compose-forms
391 (cons (setq entry (list calc-language)) comps)))
392 (or (setq entry2 (assq (length calc-user-formula-alist) (cdr entry)))
395 (list (length calc-user-formula-alist))) (cdr entry))))
397 (list 'lambda calc-user-formula-alist (calc-fix-user-formula comp))))
402 (defun calc-user-define-kbd-macro (arg)
405 (error "No keyboard macro defined"))
406 (message "Define last kbd macro on user key: z-")
407 (let ((key (read-char)))
408 (if (= (calc-user-function-classify key) 0)
409 (error "Can't redefine \"?\" key"))
410 (let ((cmd (intern (completing-read "Full name for new command: "
415 (if (or (and (>= key ?a)
422 (format "%03d" key)))))))
424 (not (let ((f (symbol-function cmd)))
427 (eq (car-safe (nth 3 f))
428 'calc-execute-kbd-macro)))))
429 (error "Function %s is already defined and not a keyboard macro"
431 (put cmd 'calc-user-defn t)
432 (fset cmd (if (< (prefix-numeric-value arg) 0)
437 (list 'calc-execute-kbd-macro
438 (vector (key-description last-kbd-macro)
441 (format "z%c" key)))))
443 (define-key calc-z-map (char-to-string key) cmd))))
445 (defun calc-edit-user-syntax ()
448 (let ((lang calc-language))
449 (calc-edit-mode (list 'calc-finish-user-syntax-edit (list 'quote lang))
451 (format "Editing %s-Mode Syntax Table. "
452 (cond ((null lang) "Normal")
453 ((eq lang 'tex) "TeX")
454 ((eq lang 'latex) "LaTeX")
455 (t (capitalize (symbol-name lang))))))
456 (calc-write-parse-table (cdr (assq lang calc-user-parse-tables))
458 (calc-show-edit-buffer))
460 (defvar calc-original-buffer)
462 (defun calc-finish-user-syntax-edit (lang)
463 (let ((tab (calc-read-parse-table calc-original-buffer lang))
464 (entry (assq lang calc-user-parse-tables)))
467 (car (setq calc-user-parse-tables
468 (cons (list lang) calc-user-parse-tables))))
471 (setq calc-user-parse-tables
472 (delq entry calc-user-parse-tables)))))
473 (switch-to-buffer calc-original-buffer))
475 ;; The variable calc-lang is local to calc-write-parse-table, but is
476 ;; used by calc-write-parse-table-part which is called by
477 ;; calc-write-parse-table. The variable is also local to
478 ;; calc-read-parse-table, but is used by calc-fix-token-name which
479 ;; is called (indirectly) by calc-read-parse-table.
482 (defun calc-write-parse-table (tab calc-lang)
485 (calc-write-parse-table-part (car (car p)))
487 (let ((math-format-hash-args t))
488 (math-format-flat-expr (cdr (car p)) 0))
492 (defun calc-write-parse-table-part (p)
494 (cond ((stringp (car p))
496 (if (and (string-match "\\`\\\\dots\\>" s)
497 (not (memq calc-lang '(tex latex))))
498 (setq s (concat ".." (substring s 5))))
499 (if (or (and (string-match
500 "[a-zA-Z0-9\"{}]\\|\\`:=\\'\\|\\`#\\|\\`%%" s)
501 (string-match "[^a-zA-Z0-9\\]" s))
502 (and (assoc s '((")") ("]") (">")))
504 (insert (prin1-to-string s) " ")
509 (insert "/" (int-to-string (car p))))
511 ((and (eq (car (car p)) '\?) (equal (car (nth 2 (car p))) "$$"))
512 (insert (car (nth 1 (car p))) " "))
515 (calc-write-parse-table-part (nth 1 (car p)))
516 (insert "}" (symbol-name (car (car p))))
518 (calc-write-parse-table-part (list (car (nth 2 (car p)))))
522 (defun calc-read-parse-table (calc-buf calc-lang)
525 (skip-chars-forward "\n\t ")
527 (if (looking-at "%%")
530 (p (calc-read-parse-table-part ":=[\n\t ]+" ":=")))
531 (or (stringp (car p))
532 (and (integerp (car p))
536 (error "Malformed syntax rule")))
539 (let* ((str (buffer-substring pos (point)))
540 (exp (with-current-buffer calc-buf
541 (let ((calc-user-parse-tables nil)
543 (math-expr-opers (math-standard-ops))
544 (calc-hashes-used 0))
546 (if (string-match ",[ \t]*\\'" str)
547 (substring str 0 (match-beginning 0))
549 (if (eq (car-safe exp) 'error)
551 (goto-char (+ pos (nth 1 exp)))
552 (error (nth 2 exp))))
553 (setq tab (nconc tab (list (cons p exp)))))))))
556 (defun calc-fix-token-name (name &optional unquoted)
557 (cond ((string-match "\\`\\.\\." name)
558 (concat "\\dots" (substring name 2)))
559 ((and (equal name "{") (memq calc-lang '(tex latex eqn)))
561 ((and (equal name "}") (memq calc-lang '(tex latex eqn)))
563 ((and (equal name "&") (memq calc-lang '(tex latex)))
566 (search-backward "#")
567 (error "Token `#' is reserved"))
568 ((and unquoted (string-match "#" name))
569 (error "Tokens containing `#' must be quoted"))
570 ((not (string-match "[^ ]" name))
571 (search-backward "\"" nil t)
572 (error "Blank tokens are not allowed"))
575 (defun calc-read-parse-table-part (term eterm)
579 (skip-chars-forward "\n\t ")
580 (if (eobp) (error "Expected `%s'" eterm))
581 (not (looking-at term)))
582 (cond ((looking-at "%%")
584 ((looking-at "{[\n\t ]")
586 (let ((p (calc-read-parse-table-part "}" "}")))
587 (or (looking-at "[+*?]")
588 (error "Expected `+', `*', or `?'"))
589 (let ((sym (intern (buffer-substring (point) (1+ (point))))))
591 (looking-at "[^\n\t ]*")
592 (let ((sep (buffer-substring (point) (match-end 0))))
593 (goto-char (match-end 0))
594 (and (eq sym '\?) (> (length sep) 0)
595 (not (equal sep "$")) (not (equal sep "."))
596 (error "Separator not allowed with { ... }?"))
597 (if (string-match "\\`\"" sep)
598 (setq sep (read-from-string sep)))
599 (if (> (length sep) 0)
600 (setq sep (calc-fix-token-name sep)))
601 (setq part (nconc part
603 (and (> (length sep) 0)
604 (cons sep p))))))))))
606 (error "Too many }'s"))
608 (setq quoted (calc-fix-token-name (read (current-buffer)))
609 part (nconc part (list quoted))))
610 ((looking-at "#\\(\\(/[0-9]+\\)?\\)[\n\t ]")
611 (setq part (nconc part (list (if (= (match-beginning 1)
616 (1+ (match-beginning 1))
618 (goto-char (match-end 0)))
619 ((looking-at ":=[\n\t ]")
620 (error "Misplaced `:='"))
622 (looking-at "[^\n\t ]*")
623 (let ((end (match-end 0)))
624 (setq part (nconc part (list (calc-fix-token-name
628 (goto-char (match-end 0))
629 (let ((len (length part)))
630 (while (and (> len 1)
631 (let ((last (nthcdr (setq len (1- len)) part)))
632 (and (assoc (car last) '((")") ("]") (">")))
633 (not (eq (car last) quoted))
635 (list '\? (list (car last)) '("$$"))))))))
638 (defun calc-user-define-invocation ()
641 (error "No keyboard macro defined"))
642 (setq calc-invocation-macro last-kbd-macro)
643 (message "Use `C-x * Z' to invoke this macro"))
645 (defun calc-user-define-edit ()
646 (interactive) ; but no calc-wrapper!
647 (message "Edit definition of command: z-")
650 (cmd (or (lookup-key calc-z-map key)
651 (lookup-key calc-z-map (upcase key))
652 (lookup-key calc-z-map (downcase key))
653 (error "No command defined for that key"))))
655 (setq cmdname (symbol-name cmd))
656 (setq cmd (symbol-function cmd)))
657 (cond ((or (stringp cmd)
659 (eq (car-safe (nth 3 cmd)) 'calc-execute-kbd-macro)))
660 (let* ((mac (elt (nth 1 (nth 3 cmd)) 1))
661 (str (edmacro-format-keys mac t))
662 (kys (nth 3 (nth 3 cmd))))
664 (list 'calc-edit-macro-finish-edit cmdname kys)
666 "Editing keyboard macro (%s, bound to %s).\n"
667 "Original keys: %s \n")
668 cmdname kys (elt (nth 1 (nth 3 cmd)) 0)))
670 (calc-edit-format-macro-buffer)
671 (calc-show-edit-buffer)))
672 (t (let* ((func (calc-stack-command-p cmd))
675 (get func 'calc-user-defn)))
676 (kys (concat "z" (char-to-string key)))
677 (intcmd (symbol-name func))
678 (algcmd (if func (substring (symbol-name func) 9) "")))
679 (if (and defn (calc-valid-formula-func func))
680 (let ((niceexpr (math-format-nice-expr defn (frame-width))))
683 (list 'calc-finish-formula-edit (list 'quote func))
686 "Editing formula (%s, %s, bound to %s).\n"
687 "Original formula: %s\n")
688 intcmd algcmd kys niceexpr))
689 (insert (math-showing-full-precision
692 (calc-show-edit-buffer))
693 (error "That command's definition cannot be edited")))))))
695 ;; Formatting the macro buffer
697 (defvar calc-edit-top)
699 (defun calc-edit-macro-repeats ()
700 (goto-char calc-edit-top)
702 (re-search-forward "^\\([0-9]+\\)\\*" nil t)
703 (let ((num (string-to-number (match-string 1)))
704 (line (buffer-substring (point) (line-end-position))))
705 (goto-char (line-beginning-position))
709 (setq num (1- num))))))
711 (defun calc-edit-macro-adjust-buffer ()
712 (calc-edit-macro-repeats)
713 (goto-char calc-edit-top)
714 (while (re-search-forward "^RET$" nil t)
716 (goto-char calc-edit-top)
717 (while (and (re-search-forward "^$" nil t)
718 (not (= (point) (point-max))))
721 (defun calc-edit-macro-command ()
722 "Return the command on the current line in a Calc macro editing buffer."
723 (let ((beg (line-beginning-position))
725 (if (search-forward ";;" (line-end-position) 1)
727 (skip-chars-backward " \t")
729 (buffer-substring beg end)))
731 (defun calc-edit-macro-command-type ()
732 "Return the type of command on the current line in a Calc macro editing buffer."
733 (let ((beg (save-excursion
734 (if (search-forward ";;" (line-end-position) t)
736 (skip-chars-forward " \t")
739 (goto-char (line-end-position))
740 (skip-chars-backward " \t")
743 (buffer-substring beg end)
746 (defun calc-edit-macro-combine-alg-ent ()
747 "Put an entire algebraic entry on a single line."
748 (let ((line (calc-edit-macro-command))
749 (type (calc-edit-macro-command-type))
752 (goto-char (line-beginning-position))
754 (setq curline (calc-edit-macro-command))
756 (not (string-equal "RET" curline))
757 (not (setq match (string-match "<return>" curline))))
758 (setq line (concat line curline))
760 (setq curline (calc-edit-macro-command)))
763 (setq line (concat line (substring curline 0 match))))
764 (setq line (replace-regexp-in-string "SPC" " SPC "
765 (replace-regexp-in-string " " "" line)))
766 (insert line "\t\t\t")
767 (if (> (current-column) 24)
769 (insert ";; " type "\n")
771 (insert "RET\t\t\t;; calc-enter\n"))))
773 (defun calc-edit-macro-combine-ext-command ()
774 "Put an entire extended command on a single line."
775 (let ((cmdbeg (calc-edit-macro-command))
777 (type (calc-edit-macro-command-type))
780 (goto-char (line-beginning-position))
782 (setq curline (calc-edit-macro-command))
784 (not (string-equal "RET" curline))
785 (not (setq match (string-match "<return>" curline))))
786 (setq line (concat line curline))
788 (setq curline (calc-edit-macro-command)))
791 (setq line (concat line (substring curline 0 match))))
792 (setq line (replace-regexp-in-string " " "" line))
793 (insert cmdbeg " " line "\t\t\t")
794 (if (> (current-column) 24)
796 (insert ";; " type "\n")
798 (insert "RET\t\t\t;; calc-enter\n"))))
800 (defun calc-edit-macro-combine-var-name ()
801 "Put an entire variable name on a single line."
802 (let ((line (calc-edit-macro-command))
805 (goto-char (line-beginning-position))
807 (if (member line '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
808 (insert line "\t\t\t;; calc quick variable\n")
809 (setq curline (calc-edit-macro-command))
811 (not (string-equal "RET" curline))
812 (not (setq match (string-match "<return>" curline))))
813 (setq line (concat line curline))
815 (setq curline (calc-edit-macro-command)))
818 (setq line (concat line (substring curline 0 match))))
819 (setq line (replace-regexp-in-string " " "" line))
820 (insert line "\t\t\t")
821 (if (> (current-column) 24)
823 (insert ";; calc variable\n")
825 (insert "RET\t\t\t;; calc-enter\n")))))
827 (defun calc-edit-macro-combine-digits ()
828 "Put an entire sequence of digits on a single line."
829 (let ((line (calc-edit-macro-command)))
830 (goto-char (line-beginning-position))
832 (while (string-equal (calc-edit-macro-command-type) "calcDigit-start")
833 (setq line (concat line (calc-edit-macro-command)))
835 (insert line "\t\t\t")
836 (if (> (current-column) 24)
838 (insert ";; calc digits\n")))
840 (defun calc-edit-format-macro-buffer ()
841 "Rewrite the Calc macro editing buffer."
842 (calc-edit-macro-adjust-buffer)
843 (goto-char calc-edit-top)
844 (let ((type (calc-edit-macro-command-type)))
845 (while (not (string-equal type ""))
848 (string-equal type "calc-algebraic-entry")
849 (string-equal type "calc-auto-algebraic-entry"))
850 (calc-edit-macro-combine-alg-ent))
851 ((string-equal type "calc-execute-extended-command")
852 (calc-edit-macro-combine-ext-command))
853 ((string-equal type "calcDigit-start")
854 (calc-edit-macro-combine-digits))
856 (string-equal type "calc-store")
857 (string-equal type "calc-store-into")
858 (string-equal type "calc-store-neg")
859 (string-equal type "calc-store-plus")
860 (string-equal type "calc-store-minus")
861 (string-equal type "calc-store-div")
862 (string-equal type "calc-store-times")
863 (string-equal type "calc-store-power")
864 (string-equal type "calc-store-concat")
865 (string-equal type "calc-store-inv")
866 (string-equal type "calc-store-dec")
867 (string-equal type "calc-store-incr")
868 (string-equal type "calc-store-exchange")
869 (string-equal type "calc-unstore")
870 (string-equal type "calc-recall")
871 (string-equal type "calc-let")
872 (string-equal type "calc-permanent-variable"))
874 (calc-edit-macro-combine-var-name))
876 (string-equal type "calc-copy-variable")
877 (string-equal type "calc-copy-special-constant")
878 (string-equal type "calc-declare-variable"))
880 (calc-edit-macro-combine-var-name)
881 (calc-edit-macro-combine-var-name))
882 (t (forward-line 1)))
883 (setq type (calc-edit-macro-command-type))))
884 (goto-char calc-edit-top))
886 ;; Finish editing the macro
888 (defun calc-edit-macro-pre-finish-edit ()
889 (goto-char calc-edit-top)
890 (while (re-search-forward "\\(^\\| \\)RET\\($\\|\t\\| \\)" nil t)
891 (search-backward "RET")
893 (insert "<return>")))
895 (defun calc-edit-macro-finish-edit (cmdname key)
896 "Finish editing a Calc macro.
897 Redefine the corresponding command."
899 (let ((cmd (intern cmdname)))
900 (calc-edit-macro-pre-finish-edit)
901 (let* ((str (buffer-substring calc-edit-top (point-max)))
902 (mac (edmacro-parse-keys str)))
903 (if (= (length mac) 0)
908 (list 'calc-execute-kbd-macro
909 (vector (key-description mac)
913 (defun calc-finish-formula-edit (func)
914 (let ((buf (current-buffer))
915 (str (buffer-substring calc-edit-top (point-max)))
917 (body (calc-valid-formula-func func)))
918 (set-buffer calc-original-buffer)
919 (let ((val (math-read-expr str)))
920 (if (eq (car-safe val) 'error)
923 (goto-char (+ start (nth 1 val)))
924 (error (nth 2 val))))
926 (let ((calc-user-formula-alist (nth 1 (symbol-function func))))
927 (calc-fix-user-formula val)))
928 (put func 'calc-user-defn val))))
930 (defun calc-valid-formula-func (func)
931 (let ((def (symbol-function func)))
933 (eq (car def) 'lambda)
935 (setq def (cdr (cdr def)))
937 (not (eq (car (car def)) 'math-normalize)))
938 (setq def (cdr def)))
942 (defun calc-get-user-defn ()
945 (message "Get definition of command: z-")
946 (let* ((key (read-char))
947 (cmd (or (lookup-key calc-z-map key)
948 (lookup-key calc-z-map (upcase key))
949 (lookup-key calc-z-map (downcase key))
950 (error "No command defined for that key"))))
952 (setq cmd (symbol-function cmd)))
954 (message "Keyboard macro: %s" cmd))
955 (t (let* ((func (calc-stack-command-p cmd))
958 (get func 'calc-user-defn))))
961 (and (calc-valid-formula-func func)
962 (setq defn (append '(calcFunc-lambda)
963 (mapcar 'math-build-var-name
964 (nth 1 (symbol-function
967 (calc-enter-result 0 "gdef" defn))
968 (error "That command is not defined by a formula"))))))))
971 (defun calc-user-define-permanent ()
974 (message "Record in %s the command: z-" calc-settings-file)
975 (let* ((key (read-char))
976 (cmd (or (lookup-key calc-z-map key)
977 (lookup-key calc-z-map (upcase key))
978 (lookup-key calc-z-map (downcase key))
984 (format "Record in %s the algebraic function: "
986 (mapcar (lambda (x) (substring x 9))
987 (all-completions "calcFunc-"
991 (intern (concat "calcFunc-" x))))
995 (intern (completing-read
996 (format "Record in %s the command: "
998 obarray 'fboundp nil "calc-"))))
999 (error "No command defined for that key"))))
1000 (set-buffer (find-file-noselect (substitute-in-file-name
1001 calc-settings-file)))
1002 (goto-char (point-max))
1003 (let* ((fcmd (and cmd (symbolp cmd) (symbol-function cmd)))
1005 ; (pt (point)) -- unused? --SY.
1009 (insert "\n;;; Definition stored by Calc on " (current-time-string)
1010 "\n(put 'calc-define '"
1011 (if (symbolp cmd) (symbol-name cmd) (format "key%d" key))
1014 (eq (car-safe fcmd) 'lambda)
1015 (get cmd 'calc-user-defn))
1017 (and (eq (car-safe (nth 3 fcmd)) 'calc-execute-kbd-macro)
1018 (vectorp (nth 1 (nth 3 fcmd)))
1019 (progn (fboundp 'edit-kbd-macro)
1020 (fboundp 'edmacro-parse-keys))
1022 (setcdr (nth 3 fcmd)
1023 (cons (edmacro-parse-keys
1024 (elt (nth 1 (nth 3 fcmd)) 0))
1025 (cddr (nth 3 fcmd)))))
1026 (insert (setq str (prin1-to-string
1027 (cons 'defun (cons cmd (cdr fcmd)))))
1029 (or (and (string-match "\"" str) (not q-ok))
1030 (fill-region pt (point)))
1031 (indent-rigidly pt (point) 2)
1032 (delete-region pt (1+ pt))
1033 (insert " (put '" (symbol-name cmd)
1034 " 'calc-user-defn '"
1035 (prin1-to-string (get cmd 'calc-user-defn))
1037 (setq func (calc-stack-command-p cmd))
1038 (let ((ffunc (and func (symbolp func) (symbol-function func)))
1041 (eq (car-safe ffunc) 'lambda)
1042 (get func 'calc-user-defn)
1044 (insert (setq str (prin1-to-string
1045 (cons 'defun (cons func
1048 (or (and (string-match "\"" str) (not q-ok))
1049 (fill-region pt (point)))
1050 (indent-rigidly pt (point) 2)
1051 (delete-region pt (1+ pt))
1053 (insert "(put '" (symbol-name func)
1054 " 'calc-user-defn '"
1055 (prin1-to-string (get func 'calc-user-defn))
1057 (fill-region pt (point))
1058 (indent-rigidly pt (point) 2)
1059 (delete-region pt (1+ pt))))))
1061 (insert " (fset '" (prin1-to-string cmd)
1062 " " (prin1-to-string fcmd) ")\n")))
1063 (or func (setq func (and cmd (symbolp cmd) (fboundp cmd) cmd)))
1064 (if (get func 'math-compose-forms)
1066 (insert "(put '" (symbol-name cmd)
1067 " 'math-compose-forms '"
1068 (prin1-to-string (get func 'math-compose-forms))
1070 (fill-region pt (point))
1071 (indent-rigidly pt (point) 2)
1072 (delete-region pt (1+ pt))))
1074 (insert " (define-key calc-mode-map "
1075 (prin1-to-string (concat "z" (char-to-string key)))
1077 (prin1-to-string cmd)
1082 (defun calc-stack-command-p (cmd)
1083 (if (and cmd (symbolp cmd))
1085 (calc-stack-command-p (symbol-function cmd)))
1087 (eq (car cmd) 'lambda)
1088 (setq cmd (or (assq 'calc-wrapper cmd)
1089 (assq 'calc-slow-wrapper cmd)))
1090 (setq cmd (assq 'calc-enter-result cmd))
1091 (memq (car (nth 3 cmd)) '(cons list))
1092 (eq (car (nth 1 (nth 3 cmd))) 'quote)
1093 (nth 1 (nth 1 (nth 3 cmd))))))
1096 (defun calc-call-last-kbd-macro (arg)
1098 (and defining-kbd-macro
1099 (error "Can't execute anonymous macro while defining one"))
1101 (error "No kbd macro has been defined"))
1102 (calc-execute-kbd-macro last-kbd-macro arg))
1104 (defun calc-execute-kbd-macro (mac arg &rest prefix)
1105 (if calc-keep-args-flag
1107 (if (and (vectorp mac) (> (length mac) 0) (stringp (aref mac 0)))
1108 (setq mac (or (aref mac 1)
1109 (aset mac 1 (progn (and (fboundp 'edit-kbd-macro)
1110 (edit-kbd-macro nil))
1111 (edmacro-parse-keys (aref mac 0)))))))
1112 (if (< (prefix-numeric-value arg) 0)
1113 (execute-kbd-macro mac (- (prefix-numeric-value arg)))
1114 (if calc-executing-macro
1115 (execute-kbd-macro mac arg)
1117 (let ((old-stack-whole (copy-sequence calc-stack))
1118 (old-stack-top calc-stack-top)
1119 (old-buffer-size (buffer-size))
1120 (old-refresh-count calc-refresh-count))
1122 (let ((calc-executing-macro mac))
1123 (execute-kbd-macro mac arg))
1124 (calc-select-buffer)
1125 (let ((new-stack (reverse calc-stack))
1126 (old-stack (reverse old-stack-whole)))
1127 (while (and new-stack old-stack
1128 (equal (car new-stack) (car old-stack)))
1129 (setq new-stack (cdr new-stack)
1130 old-stack (cdr old-stack)))
1131 (or (equal prefix '(nil))
1132 (calc-record-list (if (> (length new-stack) 1)
1133 (mapcar 'car new-stack)
1135 (or (car prefix) "kmac")))
1136 (calc-record-undo (list 'set 'saved-stack-top old-stack-top))
1138 (calc-record-undo (list 'pop 1 (mapcar 'car old-stack))))
1139 (let ((calc-stack old-stack-whole)
1141 (calc-cursor-stack-index (length old-stack)))
1142 (if (and (= old-buffer-size (buffer-size))
1143 (= old-refresh-count calc-refresh-count))
1144 (let ((buffer-read-only nil))
1145 (delete-region (point) (point-max))
1147 (calc-record-undo (list 'push 1))
1148 (insert (math-format-stack-value (car new-stack)) "\n")
1149 (setq new-stack (cdr new-stack)))
1150 (calc-renumber-stack))
1152 (calc-record-undo (list 'push 1))
1153 (setq new-stack (cdr new-stack)))
1155 (calc-record-undo (list 'set 'saved-stack-top 0)))))))))
1157 (defun calc-push-list-in-macro (vals m sels)
1158 (let ((entry (list (car vals) 1 (car sels)))
1159 (mm (+ (or m 1) calc-stack-top)))
1161 (setcdr (nthcdr (- mm 2) calc-stack)
1162 (cons entry (nthcdr (1- mm) calc-stack)))
1163 (setq calc-stack (cons entry calc-stack)))))
1165 (defun calc-pop-stack-in-macro (n mm)
1167 (setcdr (nthcdr (- mm 2) calc-stack)
1168 (nthcdr (+ n mm -1) calc-stack))
1169 (setq calc-stack (nthcdr n calc-stack))))
1172 (defun calc-kbd-if ()
1175 (let ((cond (calc-top-n 1)))
1177 (if (math-is-true cond)
1178 (if defining-kbd-macro
1179 (message "If true..."))
1180 (if defining-kbd-macro
1181 (message "Condition is false; skipping to Z: or Z] ..."))
1182 (calc-kbd-skip-to-else-if t)))))
1184 (defun calc-kbd-else-if ()
1188 (defun math-read-char ()
1189 (condition-case nil (read-char) (error nil)))
1191 (defun calc-kbd-skip-to-else-if (else-okay)
1195 (setq ch (math-read-char))
1197 (error "Unterminated Z[ in keyboard macro"))
1200 (setq ch (math-read-char))
1202 (setq count (1+ count)))
1204 (setq count (1- count)))
1210 (keyboard-quit))))))
1211 (and defining-kbd-macro
1214 (message "End-if...")))))
1216 (defun calc-kbd-end-if ()
1218 (if defining-kbd-macro
1219 (message "End-if...")))
1221 (defun calc-kbd-else ()
1223 (if defining-kbd-macro
1224 (message "Else; skipping to Z] ..."))
1225 (calc-kbd-skip-to-else-if nil))
1228 (defun calc-kbd-repeat ()
1232 (setq count (math-trunc (calc-top-n 1)))
1233 (or (Math-integerp count)
1234 (error "Count must be an integer"))
1235 (if (Math-integer-negp count)
1237 (or (integerp count)
1238 (setq count 1000000))
1240 (calc-kbd-loop count)))
1242 (defun calc-kbd-for (dir)
1246 (setq init (calc-top-n 2)
1247 final (calc-top-n 1))
1248 (or (and (math-anglep init) (math-anglep final))
1249 (error "Initial and final values must be real numbers"))
1251 (calc-kbd-loop nil init final (and dir (prefix-numeric-value dir)))))
1253 (defun calc-kbd-loop (rpt-count &optional initial final dir)
1255 (setq rpt-count (if rpt-count (prefix-numeric-value rpt-count) 1000000))
1259 (open last-command-char)
1262 (or executing-kbd-macro
1263 (message "Reading loop body..."))
1265 (setq ch (read-char))
1267 (error "Unterminated Z%c in keyboard macro" open))
1270 (setq ch (read-char)
1271 body (concat body "Z" (char-to-string ch)))
1272 (cond ((memq ch '(?\< ?\( ?\{))
1273 (setq count (1+ count)))
1274 ((memq ch '(?\> ?\) ?\}))
1275 (setq count (1- count)))
1278 (setq parts (nconc parts (list (concat (substring body 0 -2)
1283 (setq body (concat body (char-to-string ch)))))
1284 (if (/= ch (cdr (assq open '( (?\< . ?\>) (?\( . ?\)) (?\{ . ?\}) ))))
1285 (error "Mismatched Z%c and Z%c in keyboard macro" open ch))
1286 (or executing-kbd-macro
1287 (message "Looping..."))
1288 (setq body (concat (substring body 0 -2) "Z]"))
1289 (and (not executing-kbd-macro)
1290 (= rpt-count 1000000)
1294 (message "Warning: Infinite loop! Not executing.")
1295 (setq rpt-count 0)))
1296 (or (not initial) dir
1297 (setq dir (math-compare final initial)))
1299 (while (> rpt-count 0)
1302 (if (cond ((eq dir 0) (Math-equal final counter))
1303 ((eq dir 1) (Math-lessp final counter))
1304 ((eq dir -1) (Math-lessp counter final)))
1306 (calc-push counter)))
1307 (while (and part (> rpt-count 0))
1308 (execute-kbd-macro (car part))
1309 (if (math-is-true (calc-top-n 1))
1311 (setq part (cdr part)))
1315 (execute-kbd-macro body)
1317 (let ((step (calc-top-n 1)))
1319 (setq counter (calcFunc-add counter step)))
1320 (setq rpt-count (1- rpt-count))))))))
1321 (or executing-kbd-macro
1322 (message "Looping...done"))))
1324 (defun calc-kbd-end-repeat ()
1326 (error "Unbalanced Z> in keyboard macro"))
1328 (defun calc-kbd-end-for ()
1330 (error "Unbalanced Z) in keyboard macro"))
1332 (defun calc-kbd-end-loop ()
1334 (error "Unbalanced Z} in keyboard macro"))
1336 (defun calc-kbd-break ()
1339 (let ((cond (calc-top-n 1)))
1341 (if (math-is-true cond)
1342 (error "Keyboard macro aborted")))))
1345 (defvar calc-kbd-push-level 0)
1347 ;; The variables var-q0 through var-q9 are the "quick" variables.
1359 (defun calc-kbd-push (arg)
1362 (let* ((defs (and arg (> (prefix-numeric-value arg) 0)))
1373 (calc-internal-prec (if defs 12 calc-internal-prec))
1374 (calc-word-size (if defs 32 calc-word-size))
1375 (calc-angle-mode (if defs 'deg calc-angle-mode))
1376 (calc-simplify-mode (if defs nil calc-simplify-mode))
1377 (calc-algebraic-mode (if arg nil calc-algebraic-mode))
1378 (calc-incomplete-algebraic-mode (if arg nil
1379 calc-incomplete-algebraic-mode))
1380 (calc-symbolic-mode (if defs nil calc-symbolic-mode))
1381 (calc-matrix-mode (if defs nil calc-matrix-mode))
1382 (calc-prefer-frac (if defs nil calc-prefer-frac))
1383 (calc-complex-mode (if defs nil calc-complex-mode))
1384 (calc-infinite-mode (if defs nil calc-infinite-mode))
1388 (if (or executing-kbd-macro defining-kbd-macro)
1390 (if defining-kbd-macro
1391 (message "Reading body..."))
1393 (setq ch (read-char))
1395 (error "Unterminated Z` in keyboard macro"))
1398 (setq ch (read-char)
1399 body (concat body "Z" (char-to-string ch)))
1401 (setq count (1+ count)))
1403 (setq count (1- count)))
1406 (setq body (concat body (char-to-string ch)))))
1407 (if defining-kbd-macro
1408 (message "Reading body...done"))
1409 (let ((calc-kbd-push-level 0))
1410 (execute-kbd-macro (substring body 0 -2))))
1411 (let ((calc-kbd-push-level (1+ calc-kbd-push-level)))
1412 (message "%s" "Saving modes; type Z' to restore")
1413 (recursive-edit))))))
1415 (defun calc-kbd-pop ()
1417 (if (> calc-kbd-push-level 0)
1419 (message "Mode settings restored")
1420 (exit-recursive-edit))
1421 (error "%s" "Unbalanced Z' in keyboard macro")))
1423 (defun calc-kbd-query ()
1425 (let ((defining-kbd-macro nil)
1426 (executing-kbd-macro nil)
1428 (if (not (eq (car-safe msg) 'vec))
1429 (error "No prompt string provided")
1430 (setq msg (math-vector-to-string msg))
1433 (calc-alg-entry nil (and (not (equal msg "")) msg))))))
1435 ;;;; Logical operations.
1437 (defun calcFunc-eq (a b &rest more)
1439 (let* ((args (cons a (cons b (copy-sequence more))))
1443 (while (and (cdr p) (not (eq res 0)))
1445 (while (and (setq p2 (cdr p2)) (not (eq res 0)))
1446 (setq res (math-two-eq (car p) (car p2)))
1448 (setcdr p (delq (car p2) (cdr p)))))
1453 (cons 'calcFunc-eq args)
1455 (or (math-two-eq a b)
1456 (if (and (or (math-looks-negp a) (math-zerop a))
1457 (or (math-looks-negp b) (math-zerop b)))
1458 (list 'calcFunc-eq (math-neg a) (math-neg b))
1459 (list 'calcFunc-eq a b)))))
1461 (defun calcFunc-neq (a b &rest more)
1463 (let* ((args (cons a (cons b more)))
1468 (while (and (cdr p) (not (eq res 1)))
1470 (while (and (setq p2 (cdr p2)) (not (eq res 1)))
1471 (setq res (math-two-eq (car p) (car p2)))
1472 (or res (setq all nil)))
1478 (cons 'calcFunc-neq args))))
1479 (or (cdr (assq (math-two-eq a b) '((0 . 1) (1 . 0))))
1480 (if (and (or (math-looks-negp a) (math-zerop a))
1481 (or (math-looks-negp b) (math-zerop b)))
1482 (list 'calcFunc-neq (math-neg a) (math-neg b))
1483 (list 'calcFunc-neq a b)))))
1485 (defun math-two-eq (a b)
1486 (if (eq (car-safe a) 'vec)
1487 (if (eq (car-safe b) 'vec)
1488 (if (= (length a) (length b))
1490 (while (and (setq a (cdr a) b (cdr b)) (not (eq res 0)))
1492 (setq res (math-two-eq (car a) (car b)))
1493 (if (eq (math-two-eq (car a) (car b)) 0)
1497 (if (Math-objectp b)
1500 (if (eq (car-safe b) 'vec)
1501 (if (Math-objectp a)
1504 (let ((res (math-compare a b)))
1507 (if (and (= res 2) (not (and (Math-scalarp a) (Math-scalarp b))))
1511 (defun calcFunc-lt (a b)
1512 (let ((res (math-compare a b)))
1516 (if (and (or (math-looks-negp a) (math-zerop a))
1517 (or (math-looks-negp b) (math-zerop b)))
1518 (list 'calcFunc-gt (math-neg a) (math-neg b))
1519 (list 'calcFunc-lt a b))
1522 (defun calcFunc-gt (a b)
1523 (let ((res (math-compare a b)))
1527 (if (and (or (math-looks-negp a) (math-zerop a))
1528 (or (math-looks-negp b) (math-zerop b)))
1529 (list 'calcFunc-lt (math-neg a) (math-neg b))
1530 (list 'calcFunc-gt a b))
1533 (defun calcFunc-leq (a b)
1534 (let ((res (math-compare a b)))
1538 (if (and (or (math-looks-negp a) (math-zerop a))
1539 (or (math-looks-negp b) (math-zerop b)))
1540 (list 'calcFunc-geq (math-neg a) (math-neg b))
1541 (list 'calcFunc-leq a b))
1544 (defun calcFunc-geq (a b)
1545 (let ((res (math-compare a b)))
1549 (if (and (or (math-looks-negp a) (math-zerop a))
1550 (or (math-looks-negp b) (math-zerop b)))
1551 (list 'calcFunc-leq (math-neg a) (math-neg b))
1552 (list 'calcFunc-geq a b))
1555 (defun calcFunc-rmeq (a)
1556 (if (math-vectorp a)
1557 (math-map-vec 'calcFunc-rmeq a)
1558 (if (assq (car-safe a) calc-tweak-eqn-table)
1559 (if (and (eq (car-safe (nth 2 a)) 'var)
1560 (math-objectp (nth 1 a)))
1563 (if (eq (car-safe a) 'calcFunc-assign)
1565 (if (eq (car-safe a) 'calcFunc-evalto)
1567 (list 'calcFunc-rmeq a))))))
1569 (defun calcFunc-land (a b)
1570 (cond ((Math-zerop a)
1578 (t (list 'calcFunc-land a b))))
1580 (defun calcFunc-lor (a b)
1581 (cond ((Math-zerop a)
1589 (t (list 'calcFunc-lor a b))))
1591 (defun calcFunc-lnot (a)
1594 (if (math-is-true a)
1596 (let ((op (and (= (length a) 3)
1597 (assq (car a) calc-tweak-eqn-table))))
1599 (cons (nth 2 op) (cdr a))
1600 (list 'calcFunc-lnot a))))))
1602 (defun calcFunc-if (c e1 e2)
1605 (if (and (math-is-true c) (not (Math-vectorp c)))
1607 (or (and (Math-vectorp c)
1609 (let ((ee1 (if (Math-vectorp e1)
1610 (if (= (length c) (length e1))
1612 (calc-record-why "*Dimension error" e1))
1614 (ee2 (if (Math-vectorp e2)
1615 (if (= (length c) (length e2))
1617 (calc-record-why "*Dimension error" e2))
1620 (cons 'vec (math-if-vector (cdr c) ee1 ee2)))))
1621 (list 'calcFunc-if c e1 e2)))))
1623 (defun math-if-vector (c e1 e2)
1625 (cons (if (Math-zerop (car c)) (car e2) (car e1))
1626 (math-if-vector (cdr c)
1628 (or (cdr e2) e2)))))
1630 (defun math-normalize-logical-op (a)
1631 (or (and (eq (car a) 'calcFunc-if)
1633 (let ((a1 (math-normalize (nth 1 a))))
1635 (math-normalize (nth 3 a))
1636 (if (Math-numberp a1)
1637 (math-normalize (nth 2 a))
1638 (if (and (Math-vectorp (nth 1 a))
1639 (math-constp (nth 1 a)))
1640 (calcFunc-if (nth 1 a)
1641 (math-normalize (nth 2 a))
1642 (math-normalize (nth 3 a)))
1643 (let ((calc-simplify-mode 'none))
1644 (list 'calcFunc-if a1
1645 (math-normalize (nth 2 a))
1646 (math-normalize (nth 3 a)))))))))
1649 (defun calcFunc-in (a b)
1650 (or (and (eq (car-safe b) 'vec)
1652 (while (and (setq bb (cdr bb))
1653 (not (if (memq (car-safe (car bb)) '(vec intv))
1654 (eq (calcFunc-in a (car bb)) 1)
1655 (Math-equal a (car bb))))))
1656 (if bb 1 (and (math-constp a) (math-constp bb) 0))))
1657 (and (eq (car-safe b) 'intv)
1658 (let ((res (math-compare a (nth 2 b))) res2)
1662 (or (/= (nth 1 b) 2)
1663 (Math-lessp (nth 2 b) (nth 3 b))))
1664 (if (memq (nth 1 b) '(2 3)) 1 0))
1665 ((= (setq res2 (math-compare a (nth 3 b))) 1)
1668 (or (/= (nth 1 b) 1)
1669 (Math-lessp (nth 2 b) (nth 3 b))))
1670 (if (memq (nth 1 b) '(1 3)) 1 0))
1676 (and (Math-equal a b)
1678 (and (math-constp a) (math-constp b)
1680 (list 'calcFunc-in a b)))
1682 (defun calcFunc-typeof (a)
1683 (cond ((Math-integerp a) 1)
1684 ((eq (car a) 'frac) 2)
1685 ((eq (car a) 'float) 3)
1686 ((eq (car a) 'hms) 4)
1687 ((eq (car a) 'cplx) 5)
1688 ((eq (car a) 'polar) 6)
1689 ((eq (car a) 'sdev) 7)
1690 ((eq (car a) 'intv) 8)
1691 ((eq (car a) 'mod) 9)
1692 ((eq (car a) 'date) (if (Math-integerp (nth 1 a)) 10 11))
1694 (if (memq (nth 2 a) '(var-inf var-uinf var-nan)) 12 100))
1695 ((eq (car a) 'vec) (if (math-matrixp a) 102 101))
1696 (t (math-calcFunc-to-var (car a)))))
1698 (defun calcFunc-integer (a)
1699 (if (Math-integerp a)
1701 (if (Math-objvecp a)
1703 (list 'calcFunc-integer a))))
1705 (defun calcFunc-real (a)
1708 (if (Math-objvecp a)
1710 (list 'calcFunc-real a))))
1712 (defun calcFunc-constant (a)
1715 (if (Math-objvecp a)
1717 (list 'calcFunc-constant a))))
1719 (defun calcFunc-refers (a b)
1720 (if (math-expr-contains a b)
1722 (if (eq (car-safe a) 'var)
1723 (list 'calcFunc-refers a b)
1726 (defun calcFunc-negative (a)
1727 (if (math-looks-negp a)
1729 (if (or (math-zerop a)
1732 (list 'calcFunc-negative a))))
1734 (defun calcFunc-variable (a)
1735 (if (eq (car-safe a) 'var)
1737 (if (Math-objvecp a)
1739 (list 'calcFunc-variable a))))
1741 (defun calcFunc-nonvar (a)
1742 (if (eq (car-safe a) 'var)
1743 (list 'calcFunc-nonvar a)
1746 (defun calcFunc-istrue (a)
1747 (if (math-is-true a)
1753 ;;;; User-programmability.
1755 ;;; Compiling Lisp-like forms to use the math library.
1757 (defun math-do-defmath (func args body)
1758 (require 'calc-macs)
1759 (let* ((fname (intern (concat "calcFunc-" (symbol-name func))))
1760 (doc (if (stringp (car body))
1761 (prog1 (list (car body))
1762 (setq body (cdr body)))))
1763 (clargs (mapcar 'math-clean-arg args))
1764 (inter (if (and (consp (car body))
1765 (eq (car (car body)) 'interactive))
1767 (setq body (cdr body))))))
1768 (setq body (math-define-function-body body clargs))
1771 (if (or (> (length inter) 2)
1772 (integerp (nth 1 inter)))
1773 (let ((hasprefix nil) (hasmulti nil))
1774 (when (stringp (nth 1 inter))
1775 (cond ((equal (nth 1 inter) "p")
1777 ((equal (nth 1 inter) "m")
1780 "Can't handle interactive code string \"%s\""
1782 (setq inter (cdr inter)))
1783 (unless (integerp (nth 1 inter))
1784 (error "Expected an integer in interactive specification"))
1785 `(defun ,(intern (concat "calc-" (symbol-name func)))
1786 ,(if (or hasprefix hasmulti) '(&optional n) ())
1788 (interactive ,@(if (or hasprefix hasmulti) '("P")))
1792 (prefix-numeric-value n)
1795 ,(if hasmulti 'n (nth 1 inter))
1799 (calc-top-list-n ,(nth 1 inter))
1803 (prefix-numeric-value n)))))
1808 (nth 1 inter)))))))))
1809 `(defun ,(intern (concat "calc-" (symbol-name func))) ,clargs
1812 (calc-wrapper ,@body))))
1813 (defun ,fname ,clargs
1815 ,@(math-do-arg-list-check args nil nil)
1818 (defun math-clean-arg (arg)
1820 (math-clean-arg (nth 1 arg))
1823 (defun math-do-arg-check (arg var is-opt is-rest)
1825 (let ((chk (math-do-arg-check arg var nil nil)))
1832 (let* ((rest (math-do-arg-check (nth 1 arg) var is-opt is-rest))
1834 (qual-name (symbol-name qual))
1835 (chk (intern (concat "math-check-" qual-name))))
1839 `((setq ,var (mapcar ',chk ,var)))
1840 `((setq ,var (,chk ,var)))))
1841 (if (fboundp (setq chk (intern (concat "math-" qual-name))))
1844 `((mapcar #'(lambda (x)
1846 (math-reject-arg x ',qual)))
1849 (math-reject-arg ,var ',qual)))))
1850 (if (and (string-match "\\`not-\\(.*\\)\\'" qual-name)
1851 (fboundp (setq chk (intern
1853 (math-match-substring
1857 `((mapcar #'(lambda (x)
1859 (math-reject-arg x ',qual)))
1863 (math-reject-arg ,var ',qual)))))
1864 (error "Unknown qualifier `%s'" qual-name))))))))
1866 (defun math-do-arg-list-check (args is-opt is-rest)
1867 (cond ((null args) nil)
1869 (append (math-do-arg-check (car args)
1870 (math-clean-arg (car args))
1872 (math-do-arg-list-check (cdr args) is-opt is-rest)))
1873 ((eq (car args) '&optional)
1874 (math-do-arg-list-check (cdr args) t nil))
1875 ((eq (car args) '&rest)
1876 (math-do-arg-list-check (cdr args) nil t))
1877 (t (math-do-arg-list-check (cdr args) is-opt is-rest))))
1879 (defconst math-prim-funcs
1880 '( (~= . math-nearly-equal)
1882 (lsh . calcFunc-lsh)
1883 (ash . calcFunc-ash)
1884 (logand . calcFunc-and)
1885 (logandc2 . calcFunc-diff)
1886 (logior . calcFunc-or)
1887 (logxor . calcFunc-xor)
1888 (lognot . calcFunc-not)
1889 (equal . equal) ; need to leave these ones alone!
1897 (defconst math-prim-vars
1900 (&optional . &optional)
1903 (defun math-define-function-body (body env)
1904 (let ((body (math-define-body body env)))
1905 (if (math-body-refers-to body 'math-return)
1906 `((catch 'math-return ,@body))
1909 ;; The variable math-exp-env is local to math-define-body, but is
1910 ;; used by math-define-exp, which is called (indirectly) by
1911 ;; by math-define-body.
1912 (defvar math-exp-env)
1914 (defun math-define-body (body math-exp-env)
1915 (math-define-list body))
1917 (defun math-define-list (body &optional quote)
1920 ((and (eq (car body) ':)
1921 (stringp (nth 1 body)))
1922 (cons (let* ((math-read-expr-quotes t)
1923 (exp (math-read-plain-expr (nth 1 body) t)))
1924 (math-define-exp exp))
1925 (math-define-list (cdr (cdr body)))))
1927 (cons (cond ((consp (car body))
1928 (math-define-list (cdr body) t))
1931 (math-define-list (cdr body))))
1933 (cons (math-define-exp (car body))
1934 (math-define-list (cdr body))))))
1936 (defun math-define-exp (exp)
1938 (let ((func (car exp)))
1939 (cond ((memq func '(quote function))
1940 (if (and (consp (nth 1 exp))
1941 (eq (car (nth 1 exp)) 'lambda))
1943 (math-define-lambda (nth 1 exp) math-exp-env))
1945 ((memq func '(let let* for foreach))
1946 (let ((head (nth 1 exp))
1947 (body (cdr (cdr exp))))
1948 (if (memq func '(let let*))
1950 (setq func (cdr (assq func '((for . math-for)
1951 (foreach . math-foreach)))))
1952 (if (not (listp (car head)))
1953 (setq head (list head))))
1956 (cons (math-define-let head)
1957 (math-define-body body
1959 (math-define-let-env head)
1961 ((and (memq func '(setq setf))
1962 (math-complicated-lhs (cdr exp)))
1963 (if (> (length exp) 3)
1964 (cons 'progn (math-define-setf-list (cdr exp)))
1965 (math-define-setf (nth 1 exp) (nth 2 exp))))
1966 ((eq func 'condition-case)
1969 (math-define-body (cdr (cdr exp))
1974 (math-define-cond (cdr exp))))
1975 ((and (consp func) ; ('spam a b) == force use of plain spam
1976 (eq (car func) 'quote))
1977 (cons func (math-define-list (cdr exp))))
1979 (let ((args (math-define-list (cdr exp)))
1980 (prim (assq func math-prim-funcs)))
1982 (cons (cdr prim) args))
1984 (list 'eq (car args) '(quote float)))
1986 (math-define-binop 'math-add 0
1987 (car args) (cdr args)))
1989 (if (= (length args) 1)
1990 (cons 'math-neg args)
1991 (math-define-binop 'math-sub 0
1992 (car args) (cdr args))))
1994 (math-define-binop 'math-mul 1
1995 (car args) (cdr args)))
1997 (math-define-binop 'math-div 1
1998 (car args) (cdr args)))
2000 (math-define-binop 'math-min 0
2001 (car args) (cdr args)))
2003 (math-define-binop 'math-max 0
2004 (car args) (cdr args)))
2006 (if (and (math-numberp (nth 1 args))
2007 (math-zerop (nth 1 args)))
2008 (list 'math-negp (car args))
2009 (cons 'math-lessp args)))
2011 (if (and (math-numberp (nth 1 args))
2012 (math-zerop (nth 1 args)))
2013 (list 'math-posp (car args))
2014 (list 'math-lessp (nth 1 args) (nth 0 args))))
2017 (if (and (math-numberp (nth 1 args))
2018 (math-zerop (nth 1 args)))
2019 (list 'math-posp (car args))
2021 (nth 1 args) (nth 0 args)))))
2024 (if (and (math-numberp (nth 1 args))
2025 (math-zerop (nth 1 args)))
2026 (list 'math-negp (car args))
2027 (cons 'math-lessp args))))
2029 (if (and (math-numberp (nth 1 args))
2030 (math-zerop (nth 1 args)))
2031 (list 'math-zerop (nth 0 args))
2032 (if (and (integerp (nth 1 args))
2033 (/= (% (nth 1 args) 10) 0))
2034 (cons 'math-equal-int args)
2035 (cons 'math-equal args))))
2038 (if (and (math-numberp (nth 1 args))
2039 (math-zerop (nth 1 args)))
2040 (list 'math-zerop (nth 0 args))
2041 (if (and (integerp (nth 1 args))
2042 (/= (% (nth 1 args) 10) 0))
2043 (cons 'math-equal-int args)
2044 (cons 'math-equal args)))))
2046 (list 'math-add (car args) 1))
2048 (list 'math-add (car args) -1))
2049 ((eq func 'not) ; optimize (not (not x)) => x
2050 (if (eq (car-safe args) func)
2053 ((and (eq func 'elt) (cdr (cdr args)))
2054 (math-define-elt (car args) (cdr args)))
2057 (let* ((name (symbol-name func))
2058 (cfunc (intern (concat "calcFunc-" name)))
2059 (mfunc (intern (concat "math-" name))))
2060 (cond ((fboundp cfunc)
2065 (string-match "\\`calcFunc-.*" name))
2068 (cons cfunc args)))))))))
2069 (t (cons func (math-define-list (cdr exp))))))) ;;args
2071 (let ((prim (assq exp math-prim-vars))
2072 (name (symbol-name exp)))
2075 ((memq exp math-exp-env)
2077 ((string-match "-" name)
2080 (intern (concat "var-" name))))))
2082 (if (or (<= exp -1000000) (>= exp 1000000))
2083 (list 'quote (math-normalize exp))
2087 (defun math-define-cond (forms)
2089 (cons (math-define-list (car forms))
2090 (math-define-cond (cdr forms)))))
2092 (defun math-complicated-lhs (body)
2094 (or (not (symbolp (car body)))
2095 (math-complicated-lhs (cdr (cdr body))))))
2097 (defun math-define-setf-list (body)
2099 (cons (math-define-setf (nth 0 body) (nth 1 body))
2100 (math-define-setf-list (cdr (cdr body))))))
2102 (defun math-define-setf (place value)
2103 (setq place (math-define-exp place)
2104 value (math-define-exp value))
2105 (cond ((symbolp place)
2106 (list 'setq place value))
2107 ((eq (car-safe place) 'nth)
2108 (list 'setcar (list 'nthcdr (nth 1 place) (nth 2 place)) value))
2109 ((eq (car-safe place) 'elt)
2110 (list 'setcar (list 'nthcdr (nth 2 place) (nth 1 place)) value))
2111 ((eq (car-safe place) 'car)
2112 (list 'setcar (nth 1 place) value))
2113 ((eq (car-safe place) 'cdr)
2114 (list 'setcdr (nth 1 place) value))
2116 (error "Bad place form for setf: %s" place))))
2118 (defun math-define-binop (op ident arg1 rest)
2120 (math-define-binop op ident
2121 (list op arg1 (car rest))
2125 (defun math-define-let (vlist)
2127 (cons (if (consp (car vlist))
2128 (cons (car (car vlist))
2129 (math-define-list (cdr (car vlist))))
2131 (math-define-let (cdr vlist)))))
2133 (defun math-define-let-env (vlist)
2135 (cons (if (consp (car vlist))
2138 (math-define-let-env (cdr vlist)))))
2140 (defun math-define-lambda (exp exp-env)
2141 (nconc (list (nth 0 exp) ; 'lambda
2142 (nth 1 exp)) ; arg list
2143 (math-define-function-body (cdr (cdr exp))
2144 (append (nth 1 exp) exp-env))))
2146 (defun math-define-elt (seq idx)
2148 (math-define-elt (list 'elt seq (car idx)) (cdr idx))
2152 ;;; Useful programming macros.
2154 (defmacro math-while (head &rest body)
2155 (let ((body (cons 'while (cons head body))))
2156 (if (math-body-refers-to body 'math-break)
2157 (cons 'catch (cons '(quote math-break) (list body)))
2160 (defmacro math-for (head &rest body)
2161 (let ((body (if head
2162 (math-handle-for head body)
2163 (cons 'while (cons t body)))))
2164 (if (math-body-refers-to body 'math-break)
2165 (cons 'catch (cons '(quote math-break) (list body)))
2168 (defun math-handle-for (head body)
2169 (let* ((var (nth 0 (car head)))
2170 (init (nth 1 (car head)))
2171 (limit (nth 2 (car head)))
2172 (step (or (nth 3 (car head)) 1))
2173 (body (if (cdr head)
2174 (list (math-handle-for (cdr head) body))
2176 (all-ints (and (integerp init) (integerp limit) (integerp step)))
2177 (const-limit (or (integerp limit)
2178 (and (eq (car-safe limit) 'quote)
2179 (math-realp (nth 1 limit)))))
2180 (const-step (or (integerp step)
2181 (and (eq (car-safe step) 'quote)
2182 (math-realp (nth 1 step)))))
2183 (save-limit (if const-limit limit (make-symbol "<limit>")))
2184 (save-step (if const-step step (make-symbol "<step>"))))
2186 (cons (append (if const-limit nil (list (list save-limit limit)))
2187 (if const-step nil (list (list save-step step)))
2188 (list (list var init)))
2193 (list '<= var save-limit)
2194 (list '>= var save-limit))
2197 (if (or (math-posp step)
2222 save-step)))))))))))
2224 (defmacro math-foreach (head &rest body)
2225 (let ((body (math-handle-foreach head body)))
2226 (if (math-body-refers-to body 'math-break)
2227 (cons 'catch (cons '(quote math-break) (list body)))
2230 (defun math-handle-foreach (head body)
2231 (let ((var (nth 0 (car head)))
2232 (data (nth 1 (car head)))
2233 (body (if (cdr head)
2234 (list (math-handle-foreach (cdr head) body))
2237 (cons (list (list var data))
2244 (list 'cdr var)))))))))))
2247 (defun math-body-refers-to (body thing)
2248 (or (equal body thing)
2250 (or (math-body-refers-to (car body) thing)
2251 (math-body-refers-to (cdr body) thing)))))
2253 (defun math-break (&optional value)
2254 (throw 'math-break value))
2256 (defun math-return (&optional value)
2257 (throw 'math-return value))
2260 (defun math-composite-inequalities (x op)
2261 (if (memq (nth 1 op) '(calcFunc-eq calcFunc-neq))
2262 (if (eq (car x) (nth 1 op))
2263 (append x (list (math-read-expr-level (nth 3 op))))
2264 (throw 'syntax "Syntax error"))
2267 (if (memq (nth 1 op) '(calcFunc-lt calcFunc-leq))
2268 (if (memq (car x) '(calcFunc-lt calcFunc-leq))
2270 (+ (if (eq (car x) 'calcFunc-leq) 2 0)
2271 (if (eq (nth 1 op) 'calcFunc-leq) 1 0))
2272 (nth 1 x) (math-read-expr-level (nth 3 op)))
2273 (throw 'syntax "Syntax error"))
2274 (if (memq (car x) '(calcFunc-gt calcFunc-geq))
2276 (+ (if (eq (nth 1 op) 'calcFunc-geq) 2 0)
2277 (if (eq (car x) 'calcFunc-geq) 1 0))
2278 (math-read-expr-level (nth 3 op)) (nth 1 x))
2279 (throw 'syntax "Syntax error"))))))
2281 (provide 'calc-prog)
2283 ;;; calc-prog.el ends here