1 ;;; calc-prog.el --- user programmability functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
5 ;; Author: David Gillespie <daveg@synaptics.com>
6 ;; Maintainers: D. Goel <deego@gnufans.org>
7 ;; Colin Walters <walters@debian.org>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is distributed in the hope that it will be useful,
12 ;; but WITHOUT ANY WARRANTY. No author or distributor
13 ;; accepts responsibility to anyone for the consequences of using it
14 ;; or for whether it serves any particular purpose or works at all,
15 ;; unless he says so in writing. Refer to the GNU Emacs General Public
16 ;; License for full details.
18 ;; Everyone is granted permission to copy, modify and redistribute
19 ;; GNU Emacs, but only under the conditions described in the
20 ;; GNU Emacs General Public License. A copy of this license is
21 ;; supposed to have been given to you along with GNU Emacs so you
22 ;; can know your rights and responsibilities. It should be in a
23 ;; file named COPYING. Among other things, the copyright notice
24 ;; and this notice must be preserved on all copies.
31 ;; This file is autoloaded from calc-ext.el.
36 (defun calc-Need-calc-prog () nil)
39 (defun calc-equal-to (arg)
42 (if (and (integerp arg) (> arg 2))
43 (calc-enter-result arg "eq" (cons 'calcFunc-eq (calc-top-list-n arg)))
44 (calc-binary-op "eq" 'calcFunc-eq arg))))
46 (defun calc-remove-equal (arg)
49 (calc-unary-op "rmeq" 'calcFunc-rmeq arg)))
51 (defun calc-not-equal-to (arg)
54 (if (and (integerp arg) (> arg 2))
55 (calc-enter-result arg "neq" (cons 'calcFunc-neq (calc-top-list-n arg)))
56 (calc-binary-op "neq" 'calcFunc-neq arg))))
58 (defun calc-less-than (arg)
61 (calc-binary-op "lt" 'calcFunc-lt arg)))
63 (defun calc-greater-than (arg)
66 (calc-binary-op "gt" 'calcFunc-gt arg)))
68 (defun calc-less-equal (arg)
71 (calc-binary-op "leq" 'calcFunc-leq arg)))
73 (defun calc-greater-equal (arg)
76 (calc-binary-op "geq" 'calcFunc-geq arg)))
78 (defun calc-in-set (arg)
81 (calc-binary-op "in" 'calcFunc-in arg)))
83 (defun calc-logical-and (arg)
86 (calc-binary-op "land" 'calcFunc-land arg 1)))
88 (defun calc-logical-or (arg)
91 (calc-binary-op "lor" 'calcFunc-lor arg 0)))
93 (defun calc-logical-not (arg)
96 (calc-unary-op "lnot" 'calcFunc-lnot arg)))
98 (defun calc-logical-if ()
101 (calc-enter-result 3 "if" (cons 'calcFunc-if (calc-top-list-n 3)))))
107 (defun calc-timing (n)
110 (calc-change-mode 'calc-timing n nil t)
111 (message (if calc-timing
112 "Reporting timing of slow commands in Trail"
113 "Not reporting timing of commands"))))
115 (defun calc-pass-errors ()
117 ;; The following two cases are for the new, optimizing byte compiler
118 ;; or the standard 18.57 byte compiler, respectively.
120 (let ((place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 15)))
121 (or (memq (car-safe (car-safe place)) '(error xxxerror))
122 (setq place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 27)))
123 (or (memq (car (car place)) '(error xxxerror))
125 (setcar (car place) 'xxxerror))
126 (error (error "The calc-do function has been modified; unable to patch"))))
128 (defun calc-user-define ()
130 (message "Define user key: z-")
131 (let ((key (read-char)))
132 (if (= (calc-user-function-classify key) 0)
133 (error "Can't redefine \"?\" key"))
134 (let ((func (intern (completing-read (concat "Set key z "
141 (let* ((kmap (calc-user-key-map))
142 (old (assq key kmap)))
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"))
160 (defun calc-user-define-formula ()
163 (let* ((form (calc-top 1))
165 (is-lambda (and (eq (car-safe form) 'calcFunc-lambda)
166 (>= (length form) 2)))
167 odef key keyname cmd cmd-base func alist is-symb)
169 (setq arglist (mapcar (function (lambda (x) (nth 1 x)))
170 (nreverse (cdr (reverse (cdr form)))))
171 form (nth (1- (length form)) form))
172 (calc-default-formula-arglist form)
173 (setq arglist (sort arglist 'string-lessp)))
174 (message "Define user key: z-")
175 (setq key (read-char))
176 (if (= (calc-user-function-classify key) 0)
177 (error "Can't redefine \"?\" key"))
178 (setq key (and (not (memq key '(13 32))) key)
180 (if (or (and (<= ?0 key) (<= key ?9))
181 (and (<= ?a key) (<= key ?z))
182 (and (<= ?A key) (<= key ?Z)))
184 (format "%03d" key)))
185 odef (assq key (calc-user-key-map)))
188 (setq cmd (completing-read "Define M-x command name: "
189 obarray 'commandp nil
190 (if (and odef (symbolp (cdr odef)))
191 (symbol-name (cdr odef))
193 cmd-base (and (string-match "\\`calc-\\(.+\\)\\'" cmd)
194 (math-match-substring cmd 1))
195 cmd (and (not (or (string-equal cmd "")
196 (string-equal cmd "calc-")))
203 (if (get cmd 'calc-user-defn)
204 (concat "Replace previous definition for "
205 (symbol-name cmd) "? ")
206 "That name conflicts with a built-in Emacs function. Replace this function? "))))))
207 (if (and key (not cmd))
208 (setq cmd (intern (concat "calc-User-" keyname))))
211 (setq func (completing-read "Define algebraic function name: "
216 "\\`User-.+" cmd-base)
219 (substring cmd-base 5))
222 func (and (not (or (string-equal func "")
223 (string-equal func "calcFunc-")))
231 (if (get func 'calc-user-defn)
232 (concat "Replace previous definition for "
233 (symbol-name func) "? ")
234 "That name conflicts with a built-in Emacs function. Replace this function? "))))))
236 (setq func (intern (concat "calcFunc-User"
238 (and cmd (symbol-name cmd))
239 (format "%05d" (% (random) 10000)))))))
244 (setq alist (read-from-minibuffer "Function argument list: "
246 (prin1-to-string arglist)
250 (and (not (calc-subsetp alist arglist))
252 "Okay for arguments that don't appear in formula to be ignored? "))))))
253 (setq is-symb (and alist
256 "Leave it symbolic for non-constant arguments? ")))
257 (setq alist (mapcar (function (lambda (x)
258 (or (cdr (assq x '((nil . arg-nil)
269 (list 'calc-enter-result
271 (let ((name (symbol-name (or func cmd))))
273 "\\([^-][^-]?[^-]?[^-]?\\)[^-]*\\'"
275 (math-match-substring name 1)))
278 (list 'calc-top-list-n
280 (put cmd 'calc-user-defn t)))
281 (let ((body (list 'math-normalize (calc-fix-user-formula form))))
286 (mapcar (function (lambda (v)
287 (list 'math-check-const v t)))
290 (put func 'calc-user-defn form)
291 (setq math-integral-cache-state nil)
293 (let* ((kmap (calc-user-key-map))
294 (old (assq key kmap)))
297 (setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
300 (defun calc-default-formula-arglist (form)
302 (if (eq (car form) 'var)
303 (if (or (memq (nth 1 form) arglist)
304 (math-const-var form))
306 (setq arglist (cons (nth 1 form) arglist)))
307 (calc-default-formula-arglist-step (cdr form)))))
309 (defun calc-default-formula-arglist-step (l)
312 (calc-default-formula-arglist (car l))
313 (calc-default-formula-arglist-step (cdr l)))))
315 (defun calc-subsetp (a b)
317 (and (memq (car a) b)
318 (calc-subsetp (cdr a) b))))
320 (defun calc-fix-user-formula (f)
323 (cond ((and (eq (car f) 'var)
324 (memq (setq temp (or (cdr (assq (nth 1 f) '((nil . arg-nil)
329 ((or (math-constp f) (eq (car f) 'var))
331 ((and (eq (car f) 'calcFunc-eval)
333 (list 'let '((calc-simplify-mode nil))
334 (list 'math-normalize (calc-fix-user-formula (nth 1 f)))))
335 ((and (eq (car f) 'calcFunc-evalsimp)
337 (list 'math-simplify (calc-fix-user-formula (nth 1 f))))
338 ((and (eq (car f) 'calcFunc-evalextsimp)
340 (list 'math-simplify-extended
341 (calc-fix-user-formula (nth 1 f))))
344 (cons (list 'quote (car f))
345 (mapcar 'calc-fix-user-formula (cdr f)))))))
348 (defun calc-user-define-composition ()
351 (if (eq calc-language 'unform)
352 (error "Can't define formats for unformatted mode"))
353 (let* ((comp (calc-top 1))
354 (func (intern (completing-read "Define format for which function: "
355 obarray 'fboundp nil "calcFunc-")))
356 (comps (get func 'math-compose-forms))
360 (if (math-zerop comp)
361 (if (setq entry (assq calc-language comps))
362 (put func 'math-compose-forms (delq entry comps)))
363 (calc-default-formula-arglist comp)
364 (setq arglist (sort arglist 'string-lessp))
367 (setq alist (read-from-minibuffer "Composition argument list: "
369 (prin1-to-string arglist)
373 (and (not (calc-subsetp alist arglist))
375 "Okay for arguments that don't appear in formula to be invisible? "))))
376 (or (setq entry (assq calc-language comps))
377 (put func 'math-compose-forms
378 (cons (setq entry (list calc-language)) comps)))
379 (or (setq entry2 (assq (length alist) (cdr entry)))
381 (cons (setq entry2 (list (length alist))) (cdr entry))))
382 (setcdr entry2 (list 'lambda alist (calc-fix-user-formula comp))))
387 (defun calc-user-define-kbd-macro (arg)
390 (error "No keyboard macro defined"))
391 (message "Define last kbd macro on user key: z-")
392 (let ((key (read-char)))
393 (if (= (calc-user-function-classify key) 0)
394 (error "Can't redefine \"?\" key"))
395 (let ((cmd (intern (completing-read "Full name for new command: "
400 (if (or (and (>= key ?a)
407 (format "%03d" key)))))))
409 (not (let ((f (symbol-function cmd)))
412 (eq (car-safe (nth 3 f))
413 'calc-execute-kbd-macro)))))
414 (error "Function %s is already defined and not a keyboard macro"
416 (put cmd 'calc-user-defn t)
417 (fset cmd (if (< (prefix-numeric-value arg) 0)
422 (list 'calc-execute-kbd-macro
423 (vector (key-description last-kbd-macro)
426 (format "z%c" key)))))
427 (let* ((kmap (calc-user-key-map))
428 (old (assq key kmap)))
431 (setcdr kmap (cons (cons key cmd) (cdr kmap))))))))
434 (defun calc-edit-user-syntax ()
437 (let ((lang calc-language))
438 (calc-edit-mode (list 'calc-finish-user-syntax-edit (list 'quote lang))
440 (format "Editing %s-Mode Syntax Table"
441 (cond ((null lang) "Normal")
442 ((eq lang 'tex) "TeX")
443 (t (capitalize (symbol-name lang))))))
444 (calc-write-parse-table (cdr (assq lang calc-user-parse-tables))
446 (calc-show-edit-buffer))
448 (defun calc-finish-user-syntax-edit (lang)
449 (let ((tab (calc-read-parse-table calc-original-buffer lang))
450 (entry (assq lang calc-user-parse-tables)))
453 (car (setq calc-user-parse-tables
454 (cons (list lang) calc-user-parse-tables))))
457 (setq calc-user-parse-tables
458 (delq entry calc-user-parse-tables)))))
459 (switch-to-buffer calc-original-buffer))
461 (defun calc-write-parse-table (tab calc-lang)
464 (calc-write-parse-table-part (car (car p)))
466 (let ((math-format-hash-args t))
467 (math-format-flat-expr (cdr (car p)) 0))
471 (defun calc-write-parse-table-part (p)
473 (cond ((stringp (car p))
475 (if (and (string-match "\\`\\\\dots\\>" s)
476 (not (eq calc-lang 'tex)))
477 (setq s (concat ".." (substring s 5))))
478 (if (or (and (string-match
479 "[a-zA-Z0-9\"{}]\\|\\`:=\\'\\|\\`#\\|\\`%%" s)
480 (string-match "[^a-zA-Z0-9\\]" s))
481 (and (assoc s '((")") ("]") (">")))
483 (insert (prin1-to-string s) " ")
488 (insert "/" (int-to-string (car p))))
490 ((and (eq (car (car p)) '\?) (equal (car (nth 2 (car p))) "$$"))
491 (insert (car (nth 1 (car p))) " "))
494 (calc-write-parse-table-part (nth 1 (car p)))
495 (insert "}" (symbol-name (car (car p))))
497 (calc-write-parse-table-part (list (car (nth 2 (car p)))))
501 (defun calc-read-parse-table (calc-buf calc-lang)
504 (skip-chars-forward "\n\t ")
506 (if (looking-at "%%")
509 (p (calc-read-parse-table-part ":=[\n\t ]+" ":=")))
510 (or (stringp (car p))
511 (and (integerp (car p))
515 (error "Malformed syntax rule")))
518 (let* ((str (buffer-substring pos (point)))
520 (set-buffer calc-buf)
521 (let ((calc-user-parse-tables nil)
523 (math-expr-opers math-standard-opers)
524 (calc-hashes-used 0))
526 (if (string-match ",[ \t]*\\'" str)
527 (substring str 0 (match-beginning 0))
529 (if (eq (car-safe exp) 'error)
531 (goto-char (+ pos (nth 1 exp)))
532 (error (nth 2 exp))))
533 (setq tab (nconc tab (list (cons p exp)))))))))
536 (defun calc-fix-token-name (name &optional unquoted)
537 (cond ((string-match "\\`\\.\\." name)
538 (concat "\\dots" (substring name 2)))
539 ((and (equal name "{") (memq calc-lang '(tex eqn)))
541 ((and (equal name "}") (memq calc-lang '(tex eqn)))
543 ((and (equal name "&") (eq calc-lang 'tex))
546 (search-backward "#")
547 (error "Token '#' is reserved"))
548 ((and unquoted (string-match "#" name))
549 (error "Tokens containing '#' must be quoted"))
550 ((not (string-match "[^ ]" name))
551 (search-backward "\"" nil t)
552 (error "Blank tokens are not allowed"))
555 (defun calc-read-parse-table-part (term eterm)
559 (skip-chars-forward "\n\t ")
560 (if (eobp) (error "Expected '%s'" eterm))
561 (not (looking-at term)))
562 (cond ((looking-at "%%")
564 ((looking-at "{[\n\t ]")
566 (let ((p (calc-read-parse-table-part "}" "}")))
567 (or (looking-at "[+*?]")
568 (error "Expected '+', '*', or '?'"))
569 (let ((sym (intern (buffer-substring (point) (1+ (point))))))
571 (looking-at "[^\n\t ]*")
572 (let ((sep (buffer-substring (point) (match-end 0))))
573 (goto-char (match-end 0))
574 (and (eq sym '\?) (> (length sep) 0)
575 (not (equal sep "$")) (not (equal sep "."))
576 (error "Separator not allowed with { ... }?"))
577 (if (string-match "\\`\"" sep)
578 (setq sep (read-from-string sep)))
579 (setq sep (calc-fix-token-name sep))
580 (setq part (nconc part
582 (and (> (length sep) 0)
583 (cons sep p))))))))))
585 (error "Too many }'s"))
587 (setq quoted (calc-fix-token-name (read (current-buffer)))
588 part (nconc part (list quoted))))
589 ((looking-at "#\\(\\(/[0-9]+\\)?\\)[\n\t ]")
590 (setq part (nconc part (list (if (= (match-beginning 1)
595 (1+ (match-beginning 1))
597 (goto-char (match-end 0)))
598 ((looking-at ":=[\n\t ]")
599 (error "Misplaced ':='"))
601 (looking-at "[^\n\t ]*")
602 (let ((end (match-end 0)))
603 (setq part (nconc part (list (calc-fix-token-name
607 (goto-char (match-end 0))
608 (let ((len (length part)))
609 (while (and (> len 1)
610 (let ((last (nthcdr (setq len (1- len)) part)))
611 (and (assoc (car last) '((")") ("]") (">")))
612 (not (eq (car last) quoted))
614 (list '\? (list (car last)) '("$$"))))))))
618 (defun calc-user-define-invocation ()
621 (error "No keyboard macro defined"))
622 (setq calc-invocation-macro last-kbd-macro)
623 (message "Use `M-# Z' to invoke this macro"))
626 (defun calc-user-define-edit (prefix)
627 (interactive "P") ; but no calc-wrapper!
628 (message "Edit definition of command: z-")
629 (let* ((key (read-char))
630 (def (or (assq key (calc-user-key-map))
631 (assq (upcase key) (calc-user-key-map))
632 (assq (downcase key) (calc-user-key-map))
633 (error "No command defined for that key")))
636 (setq cmd (symbol-function cmd)))
637 (cond ((or (stringp cmd)
639 (eq (car-safe (nth 3 cmd)) 'calc-execute-kbd-macro)))
640 (if (and (>= (prefix-numeric-value prefix) 0)
641 (fboundp 'edit-kbd-macro)
643 (eq major-mode 'calc-mode))
645 (if (and (< (window-width) (frame-width))
647 (let ((win (get-buffer-window (calc-trail-buffer))))
649 (delete-window win))))
650 (edit-kbd-macro (cdr def) prefix nil
653 (and calc-display-trail
655 (calc-trail-display 1 t)))))
658 (if (stringp (symbol-function cmd))
659 (symbol-function cmd)
660 (let ((mac (nth 1 (nth 3 (symbol-function
667 (if (stringp (symbol-function cmd))
669 (let ((mac (cdr (nth 3 (symbol-function
671 (if (vectorp (car mac))
674 (key-description new))
675 (aset (car mac) 1 new))
676 (setcar mac new))))))))
677 (let ((keys (progn (and (fboundp 'edit-kbd-macro)
678 (edit-kbd-macro nil))
679 (fboundp 'MacEdit-parse-keys))))
681 (calc-edit-mode (list 'calc-finish-macro-edit
689 (insert "Notations: RET, SPC, TAB, DEL, LFD, NUL"
690 ", C-xxx, M-xxx.\n\n")
692 (insert (if (stringp cmd)
693 (key-description cmd)
694 (if (vectorp (nth 1 (nth 3 cmd)))
695 (aref (nth 1 (nth 3 cmd)) 0)
696 (key-description (nth 1 (nth 3 cmd)))))
698 (if (>= (prog2 (forward-char -1)
702 (fill-region top (point))))
703 (insert "Press C-q to quote control characters like RET"
707 (if (vectorp (nth 1 (nth 3 cmd)))
708 (aref (nth 1 (nth 3 cmd)) 1)
709 (nth 1 (nth 3 cmd)))))))
710 (calc-show-edit-buffer)
711 (forward-line (if keys 2 1)))))
712 (t (let* ((func (calc-stack-command-p cmd))
715 (get func 'calc-user-defn))))
716 (if (and defn (calc-valid-formula-func func))
719 (calc-edit-mode (list 'calc-finish-formula-edit
721 (insert (math-showing-full-precision
722 (math-format-nice-expr defn (frame-width)))
724 (calc-show-edit-buffer))
725 (error "That command's definition cannot be edited")))))))
727 (defun calc-finish-macro-edit (def keys)
729 (if (and keys (looking-at "\n")) (forward-line 1))
730 (let* ((true-str (buffer-substring (point) (point-max)))
732 (if keys (setq str (MacEdit-parse-keys str)))
733 (if (symbolp (cdr def))
734 (if (stringp (symbol-function (cdr def)))
736 (let ((mac (cdr (nth 3 (symbol-function (cdr def))))))
737 (if (vectorp (car mac))
739 (aset (car mac) 0 (if keys true-str (key-description str)))
740 (aset (car mac) 1 str))
744 ;;; The following are hooks into the MacEdit package from macedit.el.
745 (put 'calc-execute-extended-command 'MacEdit-print
747 (setq macro-str (concat "\excalc-" macro-str)))))
749 (put 'calcDigit-start 'MacEdit-print
751 (if calc-algebraic-mode
752 (calc-macro-edit-algebraic)
753 (MacEdit-unread-chars key-last)
757 (while (and (setq ch (MacEdit-read-char))
758 (or (and (>= ch ?0) (<= ch ?9))
759 (memq ch '(?\. ?e ?\_ ?n ?\: ?\# ?M
761 (and (memq ch '(?\' ?m ?s))
762 (string-match "[@oh]" str))
763 (and (or (and (>= ch ?a) (<= ch ?z))
764 (and (>= ch ?A) (<= ch ?Z)))
766 "^[-+]?\\(1[1-9]\\|[2-9][0-9]\\)#"
768 (and (memq ch '(?\177 ?\C-h))
770 (and (memq ch '(?+ ?-))
772 (eq (aref str (1- (length str)))
774 (if (or (and (>= ch ?0) (<= ch ?9))
775 (and (or (not (memq ch '(?\177 ?\C-h)))
776 (<= (length str) min-bsp))
777 (setq min-bsp (1+ (length str)))))
778 (setq str (concat str (char-to-string ch)))
779 (setq str (substring str 0 -1))))
780 (if (memq ch '(32 10 13))
781 (setq str (concat str (char-to-string ch)))
782 (MacEdit-unread-chars ch))
784 (MacEdit-insert-string str)
787 (defun calc-macro-edit-algebraic ()
788 (MacEdit-unread-chars key-last)
792 (MacEdit-lookup-key calc-alg-ent-map)
793 (or (and (memq key-symbol '(self-insert-command
797 '(backward-delete-char
799 backward-delete-char-untabify))
801 (setq macro-str (substring macro-str (length key-str)))
802 (if (or (eq key-symbol 'self-insert-command)
803 (and (or (not (memq key-symbol '(backward-delete-char
805 backward-delete-char-untabify)))
806 (<= (length str) min-bsp))
807 (setq min-bsp (+ (length str) (length key-str)))))
808 (setq str (concat str key-str))
809 (setq str (substring str 0 -1))))
810 (if (memq key-last '(10 13))
811 (setq str (concat str key-str)
812 macro-str (substring macro-str (length key-str))))
813 (if (> (length str) 0)
816 (MacEdit-insert-string str)
818 (put 'calc-algebraic-entry 'MacEdit-print 'calc-macro-edit-algebraic)
819 (put 'calc-auto-algebraic-entry 'MacEdit-print 'calc-macro-edit-algebraic)
821 (defun calc-macro-edit-variable (&optional no-cmd)
823 (or no-cmd (insert (symbol-name key-symbol) "\n"))
824 (if (memq (MacEdit-peek-char) '(?\+ ?\- ?\* ?\/ ?^ ?\|))
825 (setq str (char-to-string (MacEdit-read-char))))
826 (if (and (setq ch (MacEdit-peek-char))
827 (>= ch ?0) (<= ch ?9))
828 (insert "type \"" str
829 (char-to-string (MacEdit-read-char)) "\"\n")
830 (if (> (length str) 0)
831 (insert "type \"" str "\"\n"))
832 (MacEdit-read-argument))))
833 (put 'calc-store 'MacEdit-print 'calc-macro-edit-variable)
834 (put 'calc-store-into 'MacEdit-print 'calc-macro-edit-variable)
835 (put 'calc-store-neg 'MacEdit-print 'calc-macro-edit-variable)
836 (put 'calc-store-plus 'MacEdit-print 'calc-macro-edit-variable)
837 (put 'calc-store-minus 'MacEdit-print 'calc-macro-edit-variable)
838 (put 'calc-store-times 'MacEdit-print 'calc-macro-edit-variable)
839 (put 'calc-store-div 'MacEdit-print 'calc-macro-edit-variable)
840 (put 'calc-store-power 'MacEdit-print 'calc-macro-edit-variable)
841 (put 'calc-store-concat 'MacEdit-print 'calc-macro-edit-variable)
842 (put 'calc-store-inv 'MacEdit-print 'calc-macro-edit-variable)
843 (put 'calc-store-decr 'MacEdit-print 'calc-macro-edit-variable)
844 (put 'calc-store-incr 'MacEdit-print 'calc-macro-edit-variable)
845 (put 'calc-store-exchange 'MacEdit-print 'calc-macro-edit-variable)
846 (put 'calc-unstore 'MacEdit-print 'calc-macro-edit-variable)
847 (put 'calc-recall 'MacEdit-print 'calc-macro-edit-variable)
848 (put 'calc-let 'MacEdit-print 'calc-macro-edit-variable)
849 (put 'calc-permanent-variable 'MacEdit-print 'calc-macro-edit-variable)
851 (defun calc-macro-edit-variable-2 ()
852 (calc-macro-edit-variable)
853 (calc-macro-edit-variable t))
854 (put 'calc-copy-variable 'MacEdit-print 'calc-macro-edit-variable-2)
855 (put 'calc-declare-variable 'MacEdit-print 'calc-macro-edit-variable-2)
857 (defun calc-macro-edit-quick-digit ()
858 (insert "type \"" key-str "\" # " (symbol-name key-symbol) "\n"))
859 (put 'calc-store-quick 'MacEdit-print 'calc-macro-edit-quick-digit)
860 (put 'calc-store-into-quick 'MacEdit-print 'calc-macro-edit-quick-digit)
861 (put 'calc-recall-quick 'MacEdit-print 'calc-macro-edit-quick-digit)
862 (put 'calc-select-part 'MacEdit-print 'calc-macro-edit-quick-digit)
863 (put 'calc-clean-num 'MacEdit-print 'calc-macro-edit-quick-digit)
866 (defun calc-finish-formula-edit (func)
867 (let ((buf (current-buffer))
868 (str (buffer-substring (point) (point-max)))
870 (body (calc-valid-formula-func func)))
871 (set-buffer calc-original-buffer)
872 (let ((val (math-read-expr str)))
873 (if (eq (car-safe val) 'error)
876 (goto-char (+ start (nth 1 val)))
877 (error (nth 2 val))))
879 (let ((alist (nth 1 (symbol-function func))))
880 (calc-fix-user-formula val)))
881 (put func 'calc-user-defn val))))
883 (defun calc-valid-formula-func (func)
884 (let ((def (symbol-function func)))
886 (eq (car def) 'lambda)
888 (setq def (cdr (cdr def)))
890 (not (eq (car (car def)) 'math-normalize)))
891 (setq def (cdr def)))
895 (defun calc-get-user-defn ()
898 (message "Get definition of command: z-")
899 (let* ((key (read-char))
900 (def (or (assq key (calc-user-key-map))
901 (assq (upcase key) (calc-user-key-map))
902 (assq (downcase key) (calc-user-key-map))
903 (error "No command defined for that key")))
906 (setq cmd (symbol-function cmd)))
908 (message "Keyboard macro: %s" cmd))
909 (t (let* ((func (calc-stack-command-p cmd))
912 (get func 'calc-user-defn))))
915 (and (calc-valid-formula-func func)
916 (setq defn (append '(calcFunc-lambda)
917 (mapcar 'math-build-var-name
918 (nth 1 (symbol-function
921 (calc-enter-result 0 "gdef" defn))
922 (error "That command is not defined by a formula"))))))))
925 (defun calc-user-define-permanent ()
928 (message "Record in %s the command: z-" calc-settings-file)
929 (let* ((key (read-char))
930 (def (or (assq key (calc-user-key-map))
931 (assq (upcase key) (calc-user-key-map))
932 (assq (downcase key) (calc-user-key-map))
935 (intern (completing-read
936 (format "Record in %s the function: "
938 obarray 'fboundp nil "calcFunc-"))))
939 (error "No command defined for that key"))))
940 (set-buffer (find-file-noselect (substitute-in-file-name
941 calc-settings-file)))
942 (goto-char (point-max))
943 (let* ((cmd (cdr def))
944 (fcmd (and cmd (symbolp cmd) (symbol-function cmd)))
950 (insert "\n;;; Definition stored by Calc on " (current-time-string)
951 "\n(put 'calc-define '"
952 (if (symbolp cmd) (symbol-name cmd) (format "key%d" key))
955 (eq (car-safe fcmd) 'lambda)
956 (get cmd 'calc-user-defn))
958 (and (eq (car-safe (nth 3 fcmd)) 'calc-execute-kbd-macro)
959 (vectorp (nth 1 (nth 3 fcmd)))
960 (progn (and (fboundp 'edit-kbd-macro)
961 (edit-kbd-macro nil))
962 (fboundp 'MacEdit-parse-keys))
964 (aset (nth 1 (nth 3 fcmd)) 1 nil))
965 (insert (setq str (prin1-to-string
966 (cons 'defun (cons cmd (cdr fcmd)))))
968 (or (and (string-match "\"" str) (not q-ok))
969 (fill-region pt (point)))
970 (indent-rigidly pt (point) 2)
971 (delete-region pt (1+ pt))
972 (insert " (put '" (symbol-name cmd)
974 (prin1-to-string (get cmd 'calc-user-defn))
976 (setq func (calc-stack-command-p cmd))
977 (let ((ffunc (and func (symbolp func) (symbol-function func)))
980 (eq (car-safe ffunc) 'lambda)
981 (get func 'calc-user-defn)
983 (insert (setq str (prin1-to-string
984 (cons 'defun (cons func
987 (or (and (string-match "\"" str) (not q-ok))
988 (fill-region pt (point)))
989 (indent-rigidly pt (point) 2)
990 (delete-region pt (1+ pt))
992 (insert "(put '" (symbol-name func)
994 (prin1-to-string (get func 'calc-user-defn))
996 (fill-region pt (point))
997 (indent-rigidly pt (point) 2)
998 (delete-region pt (1+ pt))))))
1000 (insert " (fset '" (prin1-to-string cmd)
1001 " " (prin1-to-string fcmd) ")\n")))
1002 (or func (setq func (and cmd (symbolp cmd) (fboundp cmd) cmd)))
1003 (if (get func 'math-compose-forms)
1005 (insert "(put '" (symbol-name cmd)
1006 " 'math-compose-forms '"
1007 (prin1-to-string (get func 'math-compose-forms))
1009 (fill-region pt (point))
1010 (indent-rigidly pt (point) 2)
1011 (delete-region pt (1+ pt))))
1013 (insert " (define-key calc-mode-map "
1014 (prin1-to-string (concat "z" (char-to-string key)))
1016 (prin1-to-string cmd)
1021 (defun calc-stack-command-p (cmd)
1022 (if (and cmd (symbolp cmd))
1024 (calc-stack-command-p (symbol-function cmd)))
1026 (eq (car cmd) 'lambda)
1027 (setq cmd (or (assq 'calc-wrapper cmd)
1028 (assq 'calc-slow-wrapper cmd)))
1029 (setq cmd (assq 'calc-enter-result cmd))
1030 (memq (car (nth 3 cmd)) '(cons list))
1031 (eq (car (nth 1 (nth 3 cmd))) 'quote)
1032 (nth 1 (nth 1 (nth 3 cmd))))))
1035 (defun calc-call-last-kbd-macro (arg)
1037 (and defining-kbd-macro
1038 (error "Can't execute anonymous macro while defining one"))
1040 (error "No kbd macro has been defined"))
1041 (calc-execute-kbd-macro last-kbd-macro arg))
1043 (defun calc-execute-kbd-macro (mac arg &rest prefix)
1044 (if (and (vectorp mac) (> (length mac) 0) (stringp (aref mac 0)))
1045 (setq mac (or (aref mac 1)
1046 (aset mac 1 (progn (and (fboundp 'edit-kbd-macro)
1047 (edit-kbd-macro nil))
1048 (MacEdit-parse-keys (aref mac 0)))))))
1049 (if (< (prefix-numeric-value arg) 0)
1050 (execute-kbd-macro mac (- (prefix-numeric-value arg)))
1051 (if calc-executing-macro
1052 (execute-kbd-macro mac arg)
1054 (let ((old-stack-whole (copy-sequence calc-stack))
1055 (old-stack-top calc-stack-top)
1056 (old-buffer-size (buffer-size))
1057 (old-refresh-count calc-refresh-count))
1059 (let ((calc-executing-macro mac))
1060 (execute-kbd-macro mac arg))
1061 (calc-select-buffer)
1062 (let ((new-stack (reverse calc-stack))
1063 (old-stack (reverse old-stack-whole)))
1064 (while (and new-stack old-stack
1065 (equal (car new-stack) (car old-stack)))
1066 (setq new-stack (cdr new-stack)
1067 old-stack (cdr old-stack)))
1068 (or (equal prefix '(nil))
1069 (calc-record-list (if (> (length new-stack) 1)
1070 (mapcar 'car new-stack)
1072 (or (car prefix) "kmac")))
1073 (calc-record-undo (list 'set 'saved-stack-top old-stack-top))
1075 (calc-record-undo (list 'pop 1 (mapcar 'car old-stack))))
1076 (let ((calc-stack old-stack-whole)
1078 (calc-cursor-stack-index (length old-stack)))
1079 (if (and (= old-buffer-size (buffer-size))
1080 (= old-refresh-count calc-refresh-count))
1081 (let ((buffer-read-only nil))
1082 (delete-region (point) (point-max))
1084 (calc-record-undo (list 'push 1))
1085 (insert (math-format-stack-value (car new-stack)) "\n")
1086 (setq new-stack (cdr new-stack)))
1087 (calc-renumber-stack))
1089 (calc-record-undo (list 'push 1))
1090 (setq new-stack (cdr new-stack)))
1092 (calc-record-undo (list 'set 'saved-stack-top 0)))))))))
1094 (defun calc-push-list-in-macro (vals m sels)
1095 (let ((entry (list (car vals) 1 (car sels)))
1096 (mm (+ (or m 1) calc-stack-top)))
1098 (setcdr (nthcdr (- mm 2) calc-stack)
1099 (cons entry (nthcdr (1- mm) calc-stack)))
1100 (setq calc-stack (cons entry calc-stack)))))
1102 (defun calc-pop-stack-in-macro (n mm)
1104 (setcdr (nthcdr (- mm 2) calc-stack)
1105 (nthcdr (+ n mm -1) calc-stack))
1106 (setq calc-stack (nthcdr n calc-stack))))
1109 (defun calc-kbd-if ()
1112 (let ((cond (calc-top-n 1)))
1114 (if (math-is-true cond)
1115 (if defining-kbd-macro
1116 (message "If true.."))
1117 (if defining-kbd-macro
1118 (message "Condition is false; skipping to Z: or Z] ..."))
1119 (calc-kbd-skip-to-else-if t)))))
1121 (defun calc-kbd-else-if ()
1125 (defun calc-kbd-skip-to-else-if (else-okay)
1129 (setq ch (read-char))
1131 (error "Unterminated Z[ in keyboard macro"))
1134 (setq ch (read-char))
1136 (setq count (1+ count)))
1138 (setq count (1- count)))
1144 (keyboard-quit))))))
1145 (and defining-kbd-macro
1148 (message "End-if...")))))
1150 (defun calc-kbd-end-if ()
1152 (if defining-kbd-macro
1153 (message "End-if...")))
1155 (defun calc-kbd-else ()
1157 (if defining-kbd-macro
1158 (message "Else; skipping to Z] ..."))
1159 (calc-kbd-skip-to-else-if nil))
1162 (defun calc-kbd-repeat ()
1166 (setq count (math-trunc (calc-top-n 1)))
1167 (or (Math-integerp count)
1168 (error "Count must be an integer"))
1169 (if (Math-integer-negp count)
1171 (or (integerp count)
1172 (setq count 1000000))
1174 (calc-kbd-loop count)))
1176 (defun calc-kbd-for (dir)
1180 (setq init (calc-top-n 2)
1181 final (calc-top-n 1))
1182 (or (and (math-anglep init) (math-anglep final))
1183 (error "Initial and final values must be real numbers"))
1185 (calc-kbd-loop nil init final (and dir (prefix-numeric-value dir)))))
1187 (defun calc-kbd-loop (rpt-count &optional initial final dir)
1189 (setq rpt-count (if rpt-count (prefix-numeric-value rpt-count) 1000000))
1193 (open last-command-char)
1196 (or executing-kbd-macro
1197 (message "Reading loop body..."))
1199 (setq ch (read-char))
1201 (error "Unterminated Z%c in keyboard macro" open))
1204 (setq ch (read-char)
1205 body (concat body "Z" (char-to-string ch)))
1206 (cond ((memq ch '(?\< ?\( ?\{))
1207 (setq count (1+ count)))
1208 ((memq ch '(?\> ?\) ?\}))
1209 (setq count (1- count)))
1212 (setq parts (nconc parts (list (concat (substring body 0 -2)
1217 (setq body (concat body (char-to-string ch)))))
1218 (if (/= ch (cdr (assq open '( (?\< . ?\>) (?\( . ?\)) (?\{ . ?\}) ))))
1219 (error "Mismatched Z%c and Z%c in keyboard macro" open ch))
1220 (or executing-kbd-macro
1221 (message "Looping..."))
1222 (setq body (concat (substring body 0 -2) "Z]"))
1223 (and (not executing-kbd-macro)
1224 (= rpt-count 1000000)
1228 (message "Warning: Infinite loop! Not executing")
1229 (setq rpt-count 0)))
1230 (or (not initial) dir
1231 (setq dir (math-compare final initial)))
1233 (while (> rpt-count 0)
1236 (if (cond ((eq dir 0) (Math-equal final counter))
1237 ((eq dir 1) (Math-lessp final counter))
1238 ((eq dir -1) (Math-lessp counter final)))
1240 (calc-push counter)))
1241 (while (and part (> rpt-count 0))
1242 (execute-kbd-macro (car part))
1243 (if (math-is-true (calc-top-n 1))
1245 (setq part (cdr part)))
1249 (execute-kbd-macro body)
1251 (let ((step (calc-top-n 1)))
1253 (setq counter (calcFunc-add counter step)))
1254 (setq rpt-count (1- rpt-count))))))))
1255 (or executing-kbd-macro
1256 (message "Looping...done"))))
1258 (defun calc-kbd-end-repeat ()
1260 (error "Unbalanced Z> in keyboard macro"))
1262 (defun calc-kbd-end-for ()
1264 (error "Unbalanced Z) in keyboard macro"))
1266 (defun calc-kbd-end-loop ()
1268 (error "Unbalanced Z} in keyboard macro"))
1270 (defun calc-kbd-break ()
1273 (let ((cond (calc-top-n 1)))
1275 (if (math-is-true cond)
1276 (error "Keyboard macro aborted")))))
1279 (defvar calc-kbd-push-level 0)
1280 (defun calc-kbd-push (arg)
1283 (let* ((defs (and arg (> (prefix-numeric-value arg) 0)))
1284 (var-q0 (and (boundp 'var-q0) var-q0))
1285 (var-q1 (and (boundp 'var-q1) var-q1))
1286 (var-q2 (and (boundp 'var-q2) var-q2))
1287 (var-q3 (and (boundp 'var-q3) var-q3))
1288 (var-q4 (and (boundp 'var-q4) var-q4))
1289 (var-q5 (and (boundp 'var-q5) var-q5))
1290 (var-q6 (and (boundp 'var-q6) var-q6))
1291 (var-q7 (and (boundp 'var-q7) var-q7))
1292 (var-q8 (and (boundp 'var-q8) var-q8))
1293 (var-q9 (and (boundp 'var-q9) var-q9))
1294 (calc-internal-prec (if defs 12 calc-internal-prec))
1295 (calc-word-size (if defs 32 calc-word-size))
1296 (calc-angle-mode (if defs 'deg calc-angle-mode))
1297 (calc-simplify-mode (if defs nil calc-simplify-mode))
1298 (calc-algebraic-mode (if arg nil calc-algebraic-mode))
1299 (calc-incomplete-algebraic-mode (if arg nil
1300 calc-incomplete-algebraic-mode))
1301 (calc-symbolic-mode (if defs nil calc-symbolic-mode))
1302 (calc-matrix-mode (if defs nil calc-matrix-mode))
1303 (calc-prefer-frac (if defs nil calc-prefer-frac))
1304 (calc-complex-mode (if defs nil calc-complex-mode))
1305 (calc-infinite-mode (if defs nil calc-infinite-mode))
1309 (if (or executing-kbd-macro defining-kbd-macro)
1311 (if defining-kbd-macro
1312 (message "Reading body..."))
1314 (setq ch (read-char))
1316 (error "Unterminated Z` in keyboard macro"))
1319 (setq ch (read-char)
1320 body (concat body "Z" (char-to-string ch)))
1322 (setq count (1+ count)))
1324 (setq count (1- count)))
1327 (setq body (concat body (char-to-string ch)))))
1328 (if defining-kbd-macro
1329 (message "Reading body...done"))
1330 (let ((calc-kbd-push-level 0))
1331 (execute-kbd-macro (substring body 0 -2))))
1332 (let ((calc-kbd-push-level (1+ calc-kbd-push-level)))
1333 (message "Saving modes; type Z' to restore")
1334 (recursive-edit))))))
1336 (defun calc-kbd-pop ()
1338 (if (> calc-kbd-push-level 0)
1340 (message "Mode settings restored")
1341 (exit-recursive-edit))
1342 (error "Unbalanced Z' in keyboard macro")))
1345 (defun calc-kbd-report (msg)
1346 (interactive "sMessage: ")
1348 (math-working msg (calc-top-n 1))))
1350 (defun calc-kbd-query (msg)
1351 (interactive "sPrompt: ")
1353 (calc-alg-entry nil (and (not (equal msg "")) msg))))
1355 ;;;; Logical operations.
1357 (defun calcFunc-eq (a b &rest more)
1359 (let* ((args (cons a (cons b (copy-sequence more))))
1363 (while (and (cdr p) (not (eq res 0)))
1365 (while (and (setq p2 (cdr p2)) (not (eq res 0)))
1366 (setq res (math-two-eq (car p) (car p2)))
1368 (setcdr p (delq (car p2) (cdr p)))))
1373 (cons 'calcFunc-eq args)
1375 (or (math-two-eq a b)
1376 (if (and (or (math-looks-negp a) (math-zerop a))
1377 (or (math-looks-negp b) (math-zerop b)))
1378 (list 'calcFunc-eq (math-neg a) (math-neg b))
1379 (list 'calcFunc-eq a b)))))
1381 (defun calcFunc-neq (a b &rest more)
1383 (let* ((args (cons a (cons b more)))
1388 (while (and (cdr p) (not (eq res 1)))
1390 (while (and (setq p2 (cdr p2)) (not (eq res 1)))
1391 (setq res (math-two-eq (car p) (car p2)))
1392 (or res (setq all nil)))
1398 (cons 'calcFunc-neq args))))
1399 (or (cdr (assq (math-two-eq a b) '((0 . 1) (1 . 0))))
1400 (if (and (or (math-looks-negp a) (math-zerop a))
1401 (or (math-looks-negp b) (math-zerop b)))
1402 (list 'calcFunc-neq (math-neg a) (math-neg b))
1403 (list 'calcFunc-neq a b)))))
1405 (defun math-two-eq (a b)
1406 (if (eq (car-safe a) 'vec)
1407 (if (eq (car-safe b) 'vec)
1408 (if (= (length a) (length b))
1410 (while (and (setq a (cdr a) b (cdr b)) (not (eq res 0)))
1412 (setq res (math-two-eq (car a) (car b)))
1413 (if (eq (math-two-eq (car a) (car b)) 0)
1417 (if (Math-objectp b)
1420 (if (eq (car-safe b) 'vec)
1421 (if (Math-objectp a)
1424 (let ((res (math-compare a b)))
1427 (if (and (= res 2) (not (and (Math-scalarp a) (Math-scalarp b))))
1431 (defun calcFunc-lt (a b)
1432 (let ((res (math-compare a b)))
1436 (if (and (or (math-looks-negp a) (math-zerop a))
1437 (or (math-looks-negp b) (math-zerop b)))
1438 (list 'calcFunc-gt (math-neg a) (math-neg b))
1439 (list 'calcFunc-lt a b))
1442 (defun calcFunc-gt (a b)
1443 (let ((res (math-compare a b)))
1447 (if (and (or (math-looks-negp a) (math-zerop a))
1448 (or (math-looks-negp b) (math-zerop b)))
1449 (list 'calcFunc-lt (math-neg a) (math-neg b))
1450 (list 'calcFunc-gt a b))
1453 (defun calcFunc-leq (a b)
1454 (let ((res (math-compare a b)))
1458 (if (and (or (math-looks-negp a) (math-zerop a))
1459 (or (math-looks-negp b) (math-zerop b)))
1460 (list 'calcFunc-geq (math-neg a) (math-neg b))
1461 (list 'calcFunc-leq a b))
1464 (defun calcFunc-geq (a b)
1465 (let ((res (math-compare a b)))
1469 (if (and (or (math-looks-negp a) (math-zerop a))
1470 (or (math-looks-negp b) (math-zerop b)))
1471 (list 'calcFunc-leq (math-neg a) (math-neg b))
1472 (list 'calcFunc-geq a b))
1475 (defun calcFunc-rmeq (a)
1476 (if (math-vectorp a)
1477 (math-map-vec 'calcFunc-rmeq a)
1478 (if (assq (car-safe a) calc-tweak-eqn-table)
1479 (if (and (eq (car-safe (nth 2 a)) 'var)
1480 (math-objectp (nth 1 a)))
1483 (if (eq (car-safe a) 'calcFunc-assign)
1485 (if (eq (car-safe a) 'calcFunc-evalto)
1487 (list 'calcFunc-rmeq a))))))
1489 (defun calcFunc-land (a b)
1490 (cond ((Math-zerop a)
1498 (t (list 'calcFunc-land a b))))
1500 (defun calcFunc-lor (a b)
1501 (cond ((Math-zerop a)
1509 (t (list 'calcFunc-lor a b))))
1511 (defun calcFunc-lnot (a)
1514 (if (math-is-true a)
1516 (let ((op (and (= (length a) 3)
1517 (assq (car a) calc-tweak-eqn-table))))
1519 (cons (nth 2 op) (cdr a))
1520 (list 'calcFunc-lnot a))))))
1522 (defun calcFunc-if (c e1 e2)
1525 (if (and (math-is-true c) (not (Math-vectorp c)))
1527 (or (and (Math-vectorp c)
1529 (let ((ee1 (if (Math-vectorp e1)
1530 (if (= (length c) (length e1))
1532 (calc-record-why "*Dimension error" e1))
1534 (ee2 (if (Math-vectorp e2)
1535 (if (= (length c) (length e2))
1537 (calc-record-why "*Dimension error" e2))
1540 (cons 'vec (math-if-vector (cdr c) ee1 ee2)))))
1541 (list 'calcFunc-if c e1 e2)))))
1543 (defun math-if-vector (c e1 e2)
1545 (cons (if (Math-zerop (car c)) (car e2) (car e1))
1546 (math-if-vector (cdr c)
1548 (or (cdr e2) e2)))))
1550 (defun math-normalize-logical-op (a)
1551 (or (and (eq (car a) 'calcFunc-if)
1553 (let ((a1 (math-normalize (nth 1 a))))
1555 (math-normalize (nth 3 a))
1556 (if (Math-numberp a1)
1557 (math-normalize (nth 2 a))
1558 (if (and (Math-vectorp (nth 1 a))
1559 (math-constp (nth 1 a)))
1560 (calcFunc-if (nth 1 a)
1561 (math-normalize (nth 2 a))
1562 (math-normalize (nth 3 a)))
1563 (let ((calc-simplify-mode 'none))
1564 (list 'calcFunc-if a1
1565 (math-normalize (nth 2 a))
1566 (math-normalize (nth 3 a)))))))))
1569 (defun calcFunc-in (a b)
1570 (or (and (eq (car-safe b) 'vec)
1572 (while (and (setq bb (cdr bb))
1573 (not (if (memq (car-safe (car bb)) '(vec intv))
1574 (eq (calcFunc-in a (car bb)) 1)
1575 (Math-equal a (car bb))))))
1576 (if bb 1 (and (math-constp a) (math-constp bb) 0))))
1577 (and (eq (car-safe b) 'intv)
1578 (let ((res (math-compare a (nth 2 b))) res2)
1582 (or (/= (nth 1 b) 2)
1583 (Math-lessp (nth 2 b) (nth 3 b))))
1584 (if (memq (nth 1 b) '(2 3)) 1 0))
1585 ((= (setq res2 (math-compare a (nth 3 b))) 1)
1588 (or (/= (nth 1 b) 1)
1589 (Math-lessp (nth 2 b) (nth 3 b))))
1590 (if (memq (nth 1 b) '(1 3)) 1 0))
1596 (and (Math-equal a b)
1598 (and (math-constp a) (math-constp b)
1600 (list 'calcFunc-in a b)))
1602 (defun calcFunc-typeof (a)
1603 (cond ((Math-integerp a) 1)
1604 ((eq (car a) 'frac) 2)
1605 ((eq (car a) 'float) 3)
1606 ((eq (car a) 'hms) 4)
1607 ((eq (car a) 'cplx) 5)
1608 ((eq (car a) 'polar) 6)
1609 ((eq (car a) 'sdev) 7)
1610 ((eq (car a) 'intv) 8)
1611 ((eq (car a) 'mod) 9)
1612 ((eq (car a) 'date) (if (Math-integerp (nth 1 a)) 10 11))
1614 (if (memq (nth 2 a) '(var-inf var-uinf var-nan)) 12 100))
1615 ((eq (car a) 'vec) (if (math-matrixp a) 102 101))
1616 (t (math-calcFunc-to-var func))))
1618 (defun calcFunc-integer (a)
1619 (if (Math-integerp a)
1621 (if (Math-objvecp a)
1623 (list 'calcFunc-integer a))))
1625 (defun calcFunc-real (a)
1628 (if (Math-objvecp a)
1630 (list 'calcFunc-real a))))
1632 (defun calcFunc-constant (a)
1635 (if (Math-objvecp a)
1637 (list 'calcFunc-constant a))))
1639 (defun calcFunc-refers (a b)
1640 (if (math-expr-contains a b)
1642 (if (eq (car-safe a) 'var)
1643 (list 'calcFunc-refers a b)
1646 (defun calcFunc-negative (a)
1647 (if (math-looks-negp a)
1649 (if (or (math-zerop a)
1652 (list 'calcFunc-negative a))))
1654 (defun calcFunc-variable (a)
1655 (if (eq (car-safe a) 'var)
1657 (if (Math-objvecp a)
1659 (list 'calcFunc-variable a))))
1661 (defun calcFunc-nonvar (a)
1662 (if (eq (car-safe a) 'var)
1663 (list 'calcFunc-nonvar a)
1666 (defun calcFunc-istrue (a)
1667 (if (math-is-true a)
1673 ;;;; User-programmability.
1675 ;;; Compiling Lisp-like forms to use the math library.
1677 (defun math-do-defmath (func args body)
1679 (let* ((fname (intern (concat "calcFunc-" (symbol-name func))))
1680 (doc (if (stringp (car body)) (list (car body))))
1681 (clargs (mapcar 'math-clean-arg args))
1682 (body (math-define-function-body
1683 (if (stringp (car body)) (cdr body) body)
1686 (if (and (consp (car body))
1687 (eq (car (car body)) 'interactive))
1688 (let ((inter (car body)))
1689 (setq body (cdr body))
1690 (if (or (> (length inter) 2)
1691 (integerp (nth 1 inter)))
1692 (let ((hasprefix nil) (hasmulti nil))
1693 (if (stringp (nth 1 inter))
1695 (cond ((equal (nth 1 inter) "p")
1697 ((equal (nth 1 inter) "m")
1700 "Can't handle interactive code string \"%s\""
1702 (setq inter (cdr inter))))
1703 (if (not (integerp (nth 1 inter)))
1705 "Expected an integer in interactive specification"))
1706 (append (list 'defun
1707 (intern (concat "calc-"
1708 (symbol-name func)))
1709 (if (or hasprefix hasmulti)
1713 (if (or hasprefix hasmulti)
1714 '((interactive "P"))
1718 '(calc-slow-wrapper)
1725 (list 'prefix-numeric-value
1729 (list 'calc-enter-result
1730 (if hasmulti 'n (nth 1 inter))
1734 (list 'quote (list fname))
1735 (list 'calc-top-list-n
1744 'prefix-numeric-value
1748 (list 'calc-top-list-n
1751 (nth 1 inter)))))))))))
1752 (append (list 'defun
1753 (intern (concat "calc-" (symbol-name func)))
1758 (cons 'calc-wrapper body))))))
1759 (append (list 'defun fname clargs)
1761 (math-do-arg-list-check args nil nil)
1764 (defun math-clean-arg (arg)
1766 (math-clean-arg (nth 1 arg))
1769 (defun math-do-arg-check (arg var is-opt is-rest)
1771 (let ((chk (math-do-arg-check arg var nil nil)))
1775 (setq chk (list (cons 'progn chk)))
1778 (let* ((rest (math-do-arg-check (nth 1 arg) var is-opt is-rest))
1780 (qqual (list 'quote qual))
1781 (qual-name (symbol-name qual))
1782 (chk (intern (concat "math-check-" qual-name))))
1788 (list 'mapcar (list 'quote chk) var))
1789 (list 'setq var (list chk var)))))
1790 (if (fboundp (setq chk (intern (concat "math-" qual-name))))
1799 (list 'math-reject-arg
1804 (list 'math-reject-arg var qqual)))))
1805 (if (and (string-match "\\`not-\\(.*\\)\\'" qual-name)
1806 (fboundp (setq chk (intern
1808 (math-match-substring
1818 (list 'math-reject-arg
1823 (list 'math-reject-arg var qqual)))))
1824 (error "Unknown qualifier `%s'" qual-name))))))))
1826 (defun math-do-arg-list-check (args is-opt is-rest)
1827 (cond ((null args) nil)
1829 (append (math-do-arg-check (car args)
1830 (math-clean-arg (car args))
1832 (math-do-arg-list-check (cdr args) is-opt is-rest)))
1833 ((eq (car args) '&optional)
1834 (math-do-arg-list-check (cdr args) t nil))
1835 ((eq (car args) '&rest)
1836 (math-do-arg-list-check (cdr args) nil t))
1837 (t (math-do-arg-list-check (cdr args) is-opt is-rest))))
1839 (defconst math-prim-funcs
1840 '( (~= . math-nearly-equal)
1842 (lsh . calcFunc-lsh)
1843 (ash . calcFunc-ash)
1844 (logand . calcFunc-and)
1845 (logandc2 . calcFunc-diff)
1846 (logior . calcFunc-or)
1847 (logxor . calcFunc-xor)
1848 (lognot . calcFunc-not)
1849 (equal . equal) ; need to leave these ones alone!
1858 (defconst math-prim-vars
1861 (&optional . &optional)
1865 (defun math-define-function-body (body env)
1866 (let ((body (math-define-body body env)))
1867 (if (math-body-refers-to body 'math-return)
1868 (list (cons 'catch (cons '(quote math-return) body)))
1871 (defun math-define-body (body exp-env)
1872 (math-define-list body))
1874 (defun math-define-list (body &optional quote)
1877 ((and (eq (car body) ':)
1878 (stringp (nth 1 body)))
1879 (cons (let* ((math-read-expr-quotes t)
1880 (exp (math-read-plain-expr (nth 1 body) t)))
1881 (math-define-exp exp))
1882 (math-define-list (cdr (cdr body)))))
1884 (cons (cond ((consp (car body))
1885 (math-define-list (cdr body) t))
1888 (math-define-list (cdr body))))
1890 (cons (math-define-exp (car body))
1891 (math-define-list (cdr body))))))
1893 (defun math-define-exp (exp)
1895 (let ((func (car exp)))
1896 (cond ((memq func '(quote function))
1897 (if (and (consp (nth 1 exp))
1898 (eq (car (nth 1 exp)) 'lambda))
1900 (math-define-lambda (nth 1 exp) exp-env))
1902 ((memq func '(let let* for foreach))
1903 (let ((head (nth 1 exp))
1904 (body (cdr (cdr exp))))
1905 (if (memq func '(let let*))
1907 (setq func (cdr (assq func '((for . math-for)
1908 (foreach . math-foreach)))))
1909 (if (not (listp (car head)))
1910 (setq head (list head))))
1913 (cons (math-define-let head)
1914 (math-define-body body
1916 (math-define-let-env head)
1918 ((and (memq func '(setq setf))
1919 (math-complicated-lhs (cdr exp)))
1920 (if (> (length exp) 3)
1921 (cons 'progn (math-define-setf-list (cdr exp)))
1922 (math-define-setf (nth 1 exp) (nth 2 exp))))
1923 ((eq func 'condition-case)
1926 (math-define-body (cdr (cdr exp))
1931 (math-define-cond (cdr exp))))
1932 ((and (consp func) ; ('spam a b) == force use of plain spam
1933 (eq (car func) 'quote))
1934 (cons func (math-define-list (cdr exp))))
1936 (let ((args (math-define-list (cdr exp)))
1937 (prim (assq func math-prim-funcs)))
1939 (cons (cdr prim) args))
1941 (list 'eq (car args) '(quote float)))
1943 (math-define-binop 'math-add 0
1944 (car args) (cdr args)))
1946 (if (= (length args) 1)
1947 (cons 'math-neg args)
1948 (math-define-binop 'math-sub 0
1949 (car args) (cdr args))))
1951 (math-define-binop 'math-mul 1
1952 (car args) (cdr args)))
1954 (math-define-binop 'math-div 1
1955 (car args) (cdr args)))
1957 (math-define-binop 'math-min 0
1958 (car args) (cdr args)))
1960 (math-define-binop 'math-max 0
1961 (car args) (cdr args)))
1963 (if (and (math-numberp (nth 1 args))
1964 (math-zerop (nth 1 args)))
1965 (list 'math-negp (car args))
1966 (cons 'math-lessp args)))
1968 (if (and (math-numberp (nth 1 args))
1969 (math-zerop (nth 1 args)))
1970 (list 'math-posp (car args))
1971 (list 'math-lessp (nth 1 args) (nth 0 args))))
1974 (if (and (math-numberp (nth 1 args))
1975 (math-zerop (nth 1 args)))
1976 (list 'math-posp (car args))
1978 (nth 1 args) (nth 0 args)))))
1981 (if (and (math-numberp (nth 1 args))
1982 (math-zerop (nth 1 args)))
1983 (list 'math-negp (car args))
1984 (cons 'math-lessp args))))
1986 (if (and (math-numberp (nth 1 args))
1987 (math-zerop (nth 1 args)))
1988 (list 'math-zerop (nth 0 args))
1989 (if (and (integerp (nth 1 args))
1990 (/= (% (nth 1 args) 10) 0))
1991 (cons 'math-equal-int args)
1992 (cons 'math-equal args))))
1995 (if (and (math-numberp (nth 1 args))
1996 (math-zerop (nth 1 args)))
1997 (list 'math-zerop (nth 0 args))
1998 (if (and (integerp (nth 1 args))
1999 (/= (% (nth 1 args) 10) 0))
2000 (cons 'math-equal-int args)
2001 (cons 'math-equal args)))))
2003 (list 'math-add (car args) 1))
2005 (list 'math-add (car args) -1))
2006 ((eq func 'not) ; optimize (not (not x)) => x
2007 (if (eq (car-safe args) func)
2010 ((and (eq func 'elt) (cdr (cdr args)))
2011 (math-define-elt (car args) (cdr args)))
2014 (let* ((name (symbol-name func))
2015 (cfunc (intern (concat "calcFunc-" name)))
2016 (mfunc (intern (concat "math-" name))))
2017 (cond ((fboundp cfunc)
2022 (string-match "\\`calcFunc-.*" name))
2025 (cons cfunc args)))))))))
2026 (t (cons func args)))))
2028 (let ((prim (assq exp math-prim-vars))
2029 (name (symbol-name exp)))
2034 ((string-match "-" name)
2037 (intern (concat "var-" name))))))
2039 (if (or (<= exp -1000000) (>= exp 1000000))
2040 (list 'quote (math-normalize exp))
2044 (defun math-define-cond (forms)
2046 (cons (math-define-list (car forms))
2047 (math-define-cond (cdr forms)))))
2049 (defun math-complicated-lhs (body)
2051 (or (not (symbolp (car body)))
2052 (math-complicated-lhs (cdr (cdr body))))))
2054 (defun math-define-setf-list (body)
2056 (cons (math-define-setf (nth 0 body) (nth 1 body))
2057 (math-define-setf-list (cdr (cdr body))))))
2059 (defun math-define-setf (place value)
2060 (setq place (math-define-exp place)
2061 value (math-define-exp value))
2062 (cond ((symbolp place)
2063 (list 'setq place value))
2064 ((eq (car-safe place) 'nth)
2065 (list 'setcar (list 'nthcdr (nth 1 place) (nth 2 place)) value))
2066 ((eq (car-safe place) 'elt)
2067 (list 'setcar (list 'nthcdr (nth 2 place) (nth 1 place)) value))
2068 ((eq (car-safe place) 'car)
2069 (list 'setcar (nth 1 place) value))
2070 ((eq (car-safe place) 'cdr)
2071 (list 'setcdr (nth 1 place) value))
2073 (error "Bad place form for setf: %s" place))))
2075 (defun math-define-binop (op ident arg1 rest)
2077 (math-define-binop op ident
2078 (list op arg1 (car rest))
2082 (defun math-define-let (vlist)
2084 (cons (if (consp (car vlist))
2085 (cons (car (car vlist))
2086 (math-define-list (cdr (car vlist))))
2088 (math-define-let (cdr vlist)))))
2090 (defun math-define-let-env (vlist)
2092 (cons (if (consp (car vlist))
2095 (math-define-let-env (cdr vlist)))))
2097 (defun math-define-lambda (exp exp-env)
2098 (nconc (list (nth 0 exp) ; 'lambda
2099 (nth 1 exp)) ; arg list
2100 (math-define-function-body (cdr (cdr exp))
2101 (append (nth 1 exp) exp-env))))
2103 (defun math-define-elt (seq idx)
2105 (math-define-elt (list 'elt seq (car idx)) (cdr idx))
2110 ;;; Useful programming macros.
2112 (defmacro math-while (head &rest body)
2113 (let ((body (cons 'while (cons head body))))
2114 (if (math-body-refers-to body 'math-break)
2115 (cons 'catch (cons '(quote math-break) (list body)))
2117 ;; (put 'math-while 'lisp-indent-hook 1)
2119 (defmacro math-for (head &rest body)
2120 (let ((body (if head
2121 (math-handle-for head body)
2122 (cons 'while (cons t body)))))
2123 (if (math-body-refers-to body 'math-break)
2124 (cons 'catch (cons '(quote math-break) (list body)))
2126 ;; (put 'math-for 'lisp-indent-hook 1)
2128 (defun math-handle-for (head body)
2129 (let* ((var (nth 0 (car head)))
2130 (init (nth 1 (car head)))
2131 (limit (nth 2 (car head)))
2132 (step (or (nth 3 (car head)) 1))
2133 (body (if (cdr head)
2134 (list (math-handle-for (cdr head) body))
2136 (all-ints (and (integerp init) (integerp limit) (integerp step)))
2137 (const-limit (or (integerp limit)
2138 (and (eq (car-safe limit) 'quote)
2139 (math-realp (nth 1 limit)))))
2140 (const-step (or (integerp step)
2141 (and (eq (car-safe step) 'quote)
2142 (math-realp (nth 1 step)))))
2143 (save-limit (if const-limit limit (make-symbol "<limit>")))
2144 (save-step (if const-step step (make-symbol "<step>"))))
2146 (cons (append (if const-limit nil (list (list save-limit limit)))
2147 (if const-step nil (list (list save-step step)))
2148 (list (list var init)))
2153 (list '<= var save-limit)
2154 (list '>= var save-limit))
2157 (if (or (math-posp step)
2182 save-step)))))))))))
2184 (defmacro math-foreach (head &rest body)
2185 (let ((body (math-handle-foreach head body)))
2186 (if (math-body-refers-to body 'math-break)
2187 (cons 'catch (cons '(quote math-break) (list body)))
2189 ;; (put 'math-foreach 'lisp-indent-hook 1)
2191 (defun math-handle-foreach (head body)
2192 (let ((var (nth 0 (car head)))
2193 (data (nth 1 (car head)))
2194 (body (if (cdr head)
2195 (list (math-handle-foreach (cdr head) body))
2198 (cons (list (list var data))
2205 (list 'cdr var)))))))))))
2208 (defun math-body-refers-to (body thing)
2209 (or (equal body thing)
2211 (or (math-body-refers-to (car body) thing)
2212 (math-body-refers-to (cdr body) thing)))))
2214 (defun math-break (&optional value)
2215 (throw 'math-break value))
2217 (defun math-return (&optional value)
2218 (throw 'math-return value))
2224 (defun math-composite-inequalities (x op)
2225 (if (memq (nth 1 op) '(calcFunc-eq calcFunc-neq))
2226 (if (eq (car x) (nth 1 op))
2227 (append x (list (math-read-expr-level (nth 3 op))))
2228 (throw 'syntax "Syntax error"))
2231 (if (memq (nth 1 op) '(calcFunc-lt calcFunc-leq))
2232 (if (memq (car x) '(calcFunc-lt calcFunc-leq))
2234 (+ (if (eq (car x) 'calcFunc-leq) 2 0)
2235 (if (eq (nth 1 op) 'calcFunc-leq) 1 0))
2236 (nth 1 x) (math-read-expr-level (nth 3 op)))
2237 (throw 'syntax "Syntax error"))
2238 (if (memq (car x) '(calcFunc-gt calcFunc-geq))
2240 (+ (if (eq (nth 1 op) 'calcFunc-geq) 2 0)
2241 (if (eq (car x) 'calcFunc-geq) 1 0))
2242 (math-read-expr-level (nth 3 op)) (nth 1 x))
2243 (throw 'syntax "Syntax error"))))))
2245 ;;; calc-prog.el ends here