1 ;;; calc-prog.el --- user programmability functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
6 ;; Author: David Gillespie <daveg@synaptics.com>
7 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
28 ;; This file is autoloaded from calc-ext.el.
33 ;; Declare functions which are defined elsewhere.
34 (declare-function edmacro-format-keys
"edmacro" (macro &optional verbose
))
35 (declare-function edmacro-parse-keys
"edmacro" (string &optional need-vector
))
36 (declare-function math-read-expr-level
"calc-aent" (exp-prec &optional exp-term
))
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"))
161 ;; math-integral-cache-state is originally declared in calcalg2.el,
162 ;; it is used in calc-user-define-variable.
163 (defvar math-integral-cache-state
)
165 ;; calc-user-formula-alist is local to calc-user-define-formula,
166 ;; calc-user-define-composition and calc-finish-formula-edit,
167 ;; but is used by calc-fix-user-formula.
168 (defvar calc-user-formula-alist
)
170 (defun calc-user-define-formula ()
173 (let* ((form (calc-top 1))
175 (is-lambda (and (eq (car-safe form
) 'calcFunc-lambda
)
176 (>= (length form
) 2)))
177 odef key keyname cmd cmd-base cmd-base-default
178 func calc-user-formula-alist is-symb
)
180 (setq arglist
(mapcar (function (lambda (x) (nth 1 x
)))
181 (nreverse (cdr (reverse (cdr form
)))))
182 form
(nth (1- (length form
)) form
))
183 (calc-default-formula-arglist form
)
184 (setq arglist
(sort arglist
'string-lessp
)))
185 (message "Define user key: z-")
186 (setq key
(read-char))
187 (if (= (calc-user-function-classify key
) 0)
188 (error "Can't redefine \"?\" key"))
189 (setq key
(and (not (memq key
'(13 32))) key
)
191 (if (or (and (<= ?
0 key
) (<= key ?
9))
192 (and (<= ?a key
) (<= key ?z
))
193 (and (<= ?A key
) (<= key ?Z
)))
195 (format "%03d" key
)))
196 odef
(assq key
(calc-user-key-map)))
198 (setq keyname
(format "%05d" (abs (%
(random) 10000)))))
201 (setq cmd-base-default
(concat "User-" keyname
))
202 (setq cmd
(completing-read
203 (concat "Define M-x command name (default calc-"
206 obarray
'commandp nil
207 (if (and odef
(symbolp (cdr odef
)))
208 (symbol-name (cdr odef
))
210 (if (or (string-equal cmd
"")
211 (string-equal cmd
"calc-"))
212 (setq cmd
(concat "calc-User-" keyname
)))
213 (setq cmd-base
(and (string-match "\\`calc-\\(.+\\)\\'" cmd
)
214 (math-match-substring cmd
1)))
215 (setq cmd
(intern cmd
))
221 (if (get cmd
'calc-user-defn
)
222 (concat "Replace previous definition for "
223 (symbol-name cmd
) "? ")
224 "That name conflicts with a built-in Emacs function. Replace this function? "))))))
227 (setq cmd-base-default
230 "\\`User-.+" cmd-base
)
233 (substring cmd-base
5))
235 (concat "User" keyname
)))
239 (concat "Define algebraic function name (default "
240 cmd-base-default
"): ")
241 (mapcar (lambda (x) (substring x
9))
242 (all-completions "calcFunc-"
246 (intern (concat "calcFunc-" x
))))
249 (if (string-equal func
"calcFunc-")
250 (intern (concat "calcFunc-" cmd-base-default
))
258 (if (get func
'calc-user-defn
)
259 (concat "Replace previous definition for "
260 (symbol-name func
) "? ")
261 "That name conflicts with a built-in Emacs function. Replace this function? "))))))
264 (setq func
(intern (concat "calcFunc-User"
266 (and cmd
(symbol-name cmd
))
267 (format "%05d" (%
(random) 10000)))))))
270 (setq calc-user-formula-alist arglist
)
273 (setq calc-user-formula-alist
274 (read-from-minibuffer "Function argument list: "
276 (prin1-to-string arglist
)
280 (and (not (calc-subsetp calc-user-formula-alist arglist
))
282 "Okay for arguments that don't appear in formula to be ignored? "))))))
283 (setq is-symb
(and calc-user-formula-alist
286 "Leave it symbolic for non-constant arguments? ")))
287 (setq calc-user-formula-alist
288 (mapcar (function (lambda (x)
289 (or (cdr (assq x
'((nil . arg-nil
)
291 x
))) calc-user-formula-alist
))
300 (list 'calc-enter-result
301 (length calc-user-formula-alist
)
302 (let ((name (symbol-name (or func cmd
))))
304 "\\([^-][^-]?[^-]?[^-]?\\)[^-]*\\'"
306 (math-match-substring name
1)))
309 (list 'calc-top-list-n
310 (length calc-user-formula-alist
)))))))
311 (put cmd
'calc-user-defn t
)))
312 (let ((body (list 'math-normalize
(calc-fix-user-formula form
))))
315 (list 'lambda calc-user-formula-alist
)
317 (mapcar (function (lambda (v)
318 (list 'math-check-const v t
)))
319 calc-user-formula-alist
))
321 (put func
'calc-user-defn form
)
322 (setq math-integral-cache-state nil
)
324 (let* ((kmap (calc-user-key-map))
325 (old (assq key kmap
)))
328 (setcdr kmap
(cons (cons key cmd
) (cdr kmap
)))))))
331 (defvar arglist
) ; dynamically bound in all callers
332 (defun calc-default-formula-arglist (form)
334 (if (eq (car form
) 'var
)
335 (if (or (memq (nth 1 form
) arglist
)
336 (math-const-var form
))
338 (setq arglist
(cons (nth 1 form
) arglist
)))
339 (calc-default-formula-arglist-step (cdr form
)))))
341 (defun calc-default-formula-arglist-step (l)
344 (calc-default-formula-arglist (car l
))
345 (calc-default-formula-arglist-step (cdr l
)))))
347 (defun calc-subsetp (a b
)
349 (and (memq (car a
) b
)
350 (calc-subsetp (cdr a
) b
))))
352 (defun calc-fix-user-formula (f)
355 (cond ((and (eq (car f
) 'var
)
356 (memq (setq temp
(or (cdr (assq (nth 1 f
) '((nil . arg-nil
)
359 calc-user-formula-alist
))
361 ((or (math-constp f
) (eq (car f
) 'var
))
363 ((and (eq (car f
) 'calcFunc-eval
)
365 (list 'let
'((calc-simplify-mode nil
))
366 (list 'math-normalize
(calc-fix-user-formula (nth 1 f
)))))
367 ((and (eq (car f
) 'calcFunc-evalsimp
)
369 (list 'math-simplify
(calc-fix-user-formula (nth 1 f
))))
370 ((and (eq (car f
) 'calcFunc-evalextsimp
)
372 (list 'math-simplify-extended
373 (calc-fix-user-formula (nth 1 f
))))
376 (cons (list 'quote
(car f
))
377 (mapcar 'calc-fix-user-formula
(cdr f
)))))))
380 (defun calc-user-define-composition ()
383 (if (eq calc-language
'unform
)
384 (error "Can't define formats for unformatted mode"))
385 (let* ((comp (calc-top 1))
388 (completing-read "Define format for which function: "
389 (mapcar (lambda (x) (substring x
9))
390 (all-completions "calcFunc-"
394 (intern (concat "calcFunc-" x
))))))))
395 (comps (get func
'math-compose-forms
))
398 (calc-user-formula-alist nil
))
399 (if (math-zerop comp
)
400 (if (setq entry
(assq calc-language comps
))
401 (put func
'math-compose-forms
(delq entry comps
)))
402 (calc-default-formula-arglist comp
)
403 (setq arglist
(sort arglist
'string-lessp
))
406 (setq calc-user-formula-alist
407 (read-from-minibuffer "Composition argument list: "
409 (prin1-to-string arglist
)
413 (and (not (calc-subsetp calc-user-formula-alist arglist
))
415 "Okay for arguments that don't appear in formula to be invisible? "))))
416 (or (setq entry
(assq calc-language comps
))
417 (put func
'math-compose-forms
418 (cons (setq entry
(list calc-language
)) comps
)))
419 (or (setq entry2
(assq (length calc-user-formula-alist
) (cdr entry
)))
422 (list (length calc-user-formula-alist
))) (cdr entry
))))
424 (list 'lambda calc-user-formula-alist
(calc-fix-user-formula comp
))))
429 (defun calc-user-define-kbd-macro (arg)
432 (error "No keyboard macro defined"))
433 (message "Define last kbd macro on user key: z-")
434 (let ((key (read-char)))
435 (if (= (calc-user-function-classify key
) 0)
436 (error "Can't redefine \"?\" key"))
437 (let ((cmd (intern (completing-read "Full name for new command: "
442 (if (or (and (>= key ?a
)
449 (format "%03d" key
)))))))
451 (not (let ((f (symbol-function cmd
)))
454 (eq (car-safe (nth 3 f
))
455 'calc-execute-kbd-macro
)))))
456 (error "Function %s is already defined and not a keyboard macro"
458 (put cmd
'calc-user-defn t
)
459 (fset cmd
(if (< (prefix-numeric-value arg
) 0)
464 (list 'calc-execute-kbd-macro
465 (vector (key-description last-kbd-macro
)
468 (format "z%c" key
)))))
469 (let* ((kmap (calc-user-key-map))
470 (old (assq key kmap
)))
473 (setcdr kmap
(cons (cons key cmd
) (cdr kmap
))))))))
476 (defun calc-edit-user-syntax ()
479 (let ((lang calc-language
))
480 (calc-edit-mode (list 'calc-finish-user-syntax-edit
(list 'quote lang
))
482 (format "Editing %s-Mode Syntax Table. "
483 (cond ((null lang
) "Normal")
484 ((eq lang
'tex
) "TeX")
485 ((eq lang
'latex
) "LaTeX")
486 (t (capitalize (symbol-name lang
))))))
487 (calc-write-parse-table (cdr (assq lang calc-user-parse-tables
))
489 (calc-show-edit-buffer))
491 (defvar calc-original-buffer
)
493 (defun calc-finish-user-syntax-edit (lang)
494 (let ((tab (calc-read-parse-table calc-original-buffer lang
))
495 (entry (assq lang calc-user-parse-tables
)))
498 (car (setq calc-user-parse-tables
499 (cons (list lang
) calc-user-parse-tables
))))
502 (setq calc-user-parse-tables
503 (delq entry calc-user-parse-tables
)))))
504 (switch-to-buffer calc-original-buffer
))
506 ;; The variable calc-lang is local to calc-write-parse-table, but is
507 ;; used by calc-write-parse-table-part which is called by
508 ;; calc-write-parse-table. The variable is also local to
509 ;; calc-read-parse-table, but is used by calc-fix-token-name which
510 ;; is called (indirectly) by calc-read-parse-table.
513 (defun calc-write-parse-table (tab calc-lang
)
516 (calc-write-parse-table-part (car (car p
)))
518 (let ((math-format-hash-args t
))
519 (math-format-flat-expr (cdr (car p
)) 0))
523 (defun calc-write-parse-table-part (p)
525 (cond ((stringp (car p
))
527 (if (and (string-match "\\`\\\\dots\\>" s
)
528 (not (memq calc-lang
'(tex latex
))))
529 (setq s
(concat ".." (substring s
5))))
530 (if (or (and (string-match
531 "[a-zA-Z0-9\"{}]\\|\\`:=\\'\\|\\`#\\|\\`%%" s
)
532 (string-match "[^a-zA-Z0-9\\]" s
))
533 (and (assoc s
'((")") ("]") (">")))
535 (insert (prin1-to-string s
) " ")
540 (insert "/" (int-to-string (car p
))))
542 ((and (eq (car (car p
)) '\?) (equal (car (nth 2 (car p
))) "$$"))
543 (insert (car (nth 1 (car p
))) " "))
546 (calc-write-parse-table-part (nth 1 (car p
)))
547 (insert "}" (symbol-name (car (car p
))))
549 (calc-write-parse-table-part (list (car (nth 2 (car p
)))))
553 (defun calc-read-parse-table (calc-buf calc-lang
)
556 (skip-chars-forward "\n\t ")
558 (if (looking-at "%%")
561 (p (calc-read-parse-table-part ":=[\n\t ]+" ":=")))
562 (or (stringp (car p
))
563 (and (integerp (car p
))
567 (error "Malformed syntax rule")))
570 (let* ((str (buffer-substring pos
(point)))
571 (exp (with-current-buffer calc-buf
572 (let ((calc-user-parse-tables nil
)
574 (math-expr-opers (math-standard-ops))
575 (calc-hashes-used 0))
577 (if (string-match ",[ \t]*\\'" str
)
578 (substring str
0 (match-beginning 0))
580 (if (eq (car-safe exp
) 'error
)
582 (goto-char (+ pos
(nth 1 exp
)))
583 (error (nth 2 exp
))))
584 (setq tab
(nconc tab
(list (cons p exp
)))))))))
587 (defun calc-fix-token-name (name &optional unquoted
)
588 (cond ((string-match "\\`\\.\\." name
)
589 (concat "\\dots" (substring name
2)))
590 ((and (equal name
"{") (memq calc-lang
'(tex latex eqn
)))
592 ((and (equal name
"}") (memq calc-lang
'(tex latex eqn
)))
594 ((and (equal name
"&") (memq calc-lang
'(tex latex
)))
597 (search-backward "#")
598 (error "Token '#' is reserved"))
599 ((and unquoted
(string-match "#" name
))
600 (error "Tokens containing '#' must be quoted"))
601 ((not (string-match "[^ ]" name
))
602 (search-backward "\"" nil t
)
603 (error "Blank tokens are not allowed"))
606 (defun calc-read-parse-table-part (term eterm
)
610 (skip-chars-forward "\n\t ")
611 (if (eobp) (error "Expected '%s'" eterm
))
612 (not (looking-at term
)))
613 (cond ((looking-at "%%")
615 ((looking-at "{[\n\t ]")
617 (let ((p (calc-read-parse-table-part "}" "}")))
618 (or (looking-at "[+*?]")
619 (error "Expected '+', '*', or '?'"))
620 (let ((sym (intern (buffer-substring (point) (1+ (point))))))
622 (looking-at "[^\n\t ]*")
623 (let ((sep (buffer-substring (point) (match-end 0))))
624 (goto-char (match-end 0))
625 (and (eq sym
'\?) (> (length sep
) 0)
626 (not (equal sep
"$")) (not (equal sep
"."))
627 (error "Separator not allowed with { ... }?"))
628 (if (string-match "\\`\"" sep
)
629 (setq sep
(read-from-string sep
)))
630 (if (> (length sep
) 0)
631 (setq sep
(calc-fix-token-name sep
)))
632 (setq part
(nconc part
634 (and (> (length sep
) 0)
635 (cons sep p
))))))))))
637 (error "Too many }'s"))
639 (setq quoted
(calc-fix-token-name (read (current-buffer)))
640 part
(nconc part
(list quoted
))))
641 ((looking-at "#\\(\\(/[0-9]+\\)?\\)[\n\t ]")
642 (setq part
(nconc part
(list (if (= (match-beginning 1)
647 (1+ (match-beginning 1))
649 (goto-char (match-end 0)))
650 ((looking-at ":=[\n\t ]")
651 (error "Misplaced ':='"))
653 (looking-at "[^\n\t ]*")
654 (let ((end (match-end 0)))
655 (setq part
(nconc part
(list (calc-fix-token-name
659 (goto-char (match-end 0))
660 (let ((len (length part
)))
661 (while (and (> len
1)
662 (let ((last (nthcdr (setq len
(1- len
)) part
)))
663 (and (assoc (car last
) '((")") ("]") (">")))
664 (not (eq (car last
) quoted
))
666 (list '\? (list (car last
)) '("$$"))))))))
669 (defun calc-user-define-invocation ()
672 (error "No keyboard macro defined"))
673 (setq calc-invocation-macro last-kbd-macro
)
674 (message "Use `C-x * Z' to invoke this macro"))
676 (defun calc-user-define-edit ()
677 (interactive) ; but no calc-wrapper!
678 (message "Edit definition of command: z-")
681 (def (or (assq key
(calc-user-key-map))
682 (assq (upcase key
) (calc-user-key-map))
683 (assq (downcase key
) (calc-user-key-map))
684 (error "No command defined for that key")))
687 (setq cmdname
(symbol-name cmd
))
688 (setq cmd
(symbol-function cmd
)))
689 (cond ((or (stringp cmd
)
691 (eq (car-safe (nth 3 cmd
)) 'calc-execute-kbd-macro
)))
692 (let* ((mac (elt (nth 1 (nth 3 cmd
)) 1))
693 (str (edmacro-format-keys mac t
))
694 (kys (nth 3 (nth 3 cmd
))))
696 (list 'calc-edit-macro-finish-edit cmdname kys
)
698 "Editing keyboard macro (%s, bound to %s).\n"
699 "Original keys: %s \n")
700 cmdname kys
(elt (nth 1 (nth 3 cmd
)) 0)))
702 (calc-edit-format-macro-buffer)
703 (calc-show-edit-buffer)))
704 (t (let* ((func (calc-stack-command-p cmd
))
707 (get func
'calc-user-defn
)))
708 (kys (concat "z" (char-to-string (car def
))))
709 (intcmd (symbol-name (cdr def
)))
710 (algcmd (if func
(substring (symbol-name func
) 9) "")))
711 (if (and defn
(calc-valid-formula-func func
))
712 (let ((niceexpr (math-format-nice-expr defn
(frame-width))))
715 (list 'calc-finish-formula-edit
(list 'quote func
))
718 "Editing formula (%s, %s, bound to %s).\n"
719 "Original formula: %s\n")
720 intcmd algcmd kys niceexpr
))
721 (insert (math-showing-full-precision
724 (calc-show-edit-buffer))
725 (error "That command's definition cannot be edited")))))))
727 ;; Formatting the macro buffer
729 (defvar calc-edit-top
)
731 (defun calc-edit-macro-repeats ()
732 (goto-char calc-edit-top
)
734 (re-search-forward "^\\([0-9]+\\)\\*" nil t
)
735 (let ((num (string-to-number (match-string 1)))
736 (line (buffer-substring (point) (line-end-position))))
737 (goto-char (line-beginning-position))
741 (setq num
(1- num
))))))
743 (defun calc-edit-macro-adjust-buffer ()
744 (calc-edit-macro-repeats)
745 (goto-char calc-edit-top
)
746 (while (re-search-forward "^RET$" nil t
)
748 (goto-char calc-edit-top
)
749 (while (and (re-search-forward "^$" nil t
)
750 (not (= (point) (point-max))))
753 (defun calc-edit-macro-command ()
754 "Return the command on the current line in a Calc macro editing buffer."
755 (let ((beg (line-beginning-position))
757 (if (search-forward ";;" (line-end-position) 1)
759 (skip-chars-backward " \t")
761 (buffer-substring beg end
)))
763 (defun calc-edit-macro-command-type ()
764 "Return the type of command on the current line in a Calc macro editing buffer."
765 (let ((beg (save-excursion
766 (if (search-forward ";;" (line-end-position) t
)
768 (skip-chars-forward " \t")
771 (goto-char (line-end-position))
772 (skip-chars-backward " \t")
775 (buffer-substring beg end
)
778 (defun calc-edit-macro-combine-alg-ent ()
779 "Put an entire algebraic entry on a single line."
780 (let ((line (calc-edit-macro-command))
781 (type (calc-edit-macro-command-type))
784 (goto-char (line-beginning-position))
786 (setq curline
(calc-edit-macro-command))
788 (not (string-equal "RET" curline
))
789 (not (setq match
(string-match "<return>" curline
))))
790 (setq line
(concat line curline
))
792 (setq curline
(calc-edit-macro-command)))
795 (setq line
(concat line
(substring curline
0 match
))))
796 (setq line
(replace-regexp-in-string "SPC" " SPC "
797 (replace-regexp-in-string " " "" line
)))
798 (insert line
"\t\t\t")
799 (if (> (current-column) 24)
801 (insert ";; " type
"\n")
803 (insert "RET\t\t\t;; calc-enter\n"))))
805 (defun calc-edit-macro-combine-ext-command ()
806 "Put an entire extended command on a single line."
807 (let ((cmdbeg (calc-edit-macro-command))
809 (type (calc-edit-macro-command-type))
812 (goto-char (line-beginning-position))
814 (setq curline
(calc-edit-macro-command))
816 (not (string-equal "RET" curline
))
817 (not (setq match
(string-match "<return>" curline
))))
818 (setq line
(concat line curline
))
820 (setq curline
(calc-edit-macro-command)))
823 (setq line
(concat line
(substring curline
0 match
))))
824 (setq line
(replace-regexp-in-string " " "" line
))
825 (insert cmdbeg
" " line
"\t\t\t")
826 (if (> (current-column) 24)
828 (insert ";; " type
"\n")
830 (insert "RET\t\t\t;; calc-enter\n"))))
832 (defun calc-edit-macro-combine-var-name ()
833 "Put an entire variable name on a single line."
834 (let ((line (calc-edit-macro-command))
837 (goto-char (line-beginning-position))
839 (if (member line
'("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
840 (insert line
"\t\t\t;; calc quick variable\n")
841 (setq curline
(calc-edit-macro-command))
843 (not (string-equal "RET" curline
))
844 (not (setq match
(string-match "<return>" curline
))))
845 (setq line
(concat line curline
))
847 (setq curline
(calc-edit-macro-command)))
850 (setq line
(concat line
(substring curline
0 match
))))
851 (setq line
(replace-regexp-in-string " " "" line
))
852 (insert line
"\t\t\t")
853 (if (> (current-column) 24)
855 (insert ";; calc variable\n")
857 (insert "RET\t\t\t;; calc-enter\n")))))
859 (defun calc-edit-macro-combine-digits ()
860 "Put an entire sequence of digits on a single line."
861 (let ((line (calc-edit-macro-command))
863 (goto-char (line-beginning-position))
865 (while (string-equal (calc-edit-macro-command-type) "calcDigit-start")
866 (setq line
(concat line
(calc-edit-macro-command)))
868 (insert line
"\t\t\t")
869 (if (> (current-column) 24)
871 (insert ";; calc digits\n")))
873 (defun calc-edit-format-macro-buffer ()
874 "Rewrite the Calc macro editing buffer."
875 (calc-edit-macro-adjust-buffer)
876 (goto-char calc-edit-top
)
877 (let ((type (calc-edit-macro-command-type)))
878 (while (not (string-equal type
""))
881 (string-equal type
"calc-algebraic-entry")
882 (string-equal type
"calc-auto-algebraic-entry"))
883 (calc-edit-macro-combine-alg-ent))
884 ((string-equal type
"calc-execute-extended-command")
885 (calc-edit-macro-combine-ext-command))
886 ((string-equal type
"calcDigit-start")
887 (calc-edit-macro-combine-digits))
889 (string-equal type
"calc-store")
890 (string-equal type
"calc-store-into")
891 (string-equal type
"calc-store-neg")
892 (string-equal type
"calc-store-plus")
893 (string-equal type
"calc-store-minus")
894 (string-equal type
"calc-store-div")
895 (string-equal type
"calc-store-times")
896 (string-equal type
"calc-store-power")
897 (string-equal type
"calc-store-concat")
898 (string-equal type
"calc-store-inv")
899 (string-equal type
"calc-store-dec")
900 (string-equal type
"calc-store-incr")
901 (string-equal type
"calc-store-exchange")
902 (string-equal type
"calc-unstore")
903 (string-equal type
"calc-recall")
904 (string-equal type
"calc-let")
905 (string-equal type
"calc-permanent-variable"))
907 (calc-edit-macro-combine-var-name))
909 (string-equal type
"calc-copy-variable")
910 (string-equal type
"calc-copy-special-constant")
911 (string-equal type
"calc-declare-variable"))
913 (calc-edit-macro-combine-var-name)
914 (calc-edit-macro-combine-var-name))
915 (t (forward-line 1)))
916 (setq type
(calc-edit-macro-command-type))))
917 (goto-char calc-edit-top
))
919 ;; Finish editing the macro
921 (defun calc-edit-macro-pre-finish-edit ()
922 (goto-char calc-edit-top
)
923 (while (re-search-forward "\\(^\\| \\)RET\\($\\|\t\\| \\)" nil t
)
924 (search-backward "RET")
926 (insert "<return>")))
928 (defun calc-edit-macro-finish-edit (cmdname key
)
929 "Finish editing a Calc macro.
930 Redefine the corresponding command."
932 (let ((cmd (intern cmdname
)))
933 (calc-edit-macro-pre-finish-edit)
934 (let* ((str (buffer-substring calc-edit-top
(point-max)))
935 (mac (edmacro-parse-keys str t
)))
936 (if (= (length mac
) 0)
941 (list 'calc-execute-kbd-macro
942 (vector (key-description mac
)
946 (defun calc-finish-formula-edit (func)
947 (let ((buf (current-buffer))
948 (str (buffer-substring calc-edit-top
(point-max)))
950 (body (calc-valid-formula-func func
)))
951 (set-buffer calc-original-buffer
)
952 (let ((val (math-read-expr str
)))
953 (if (eq (car-safe val
) 'error
)
956 (goto-char (+ start
(nth 1 val
)))
957 (error (nth 2 val
))))
959 (let ((calc-user-formula-alist (nth 1 (symbol-function func
))))
960 (calc-fix-user-formula val
)))
961 (put func
'calc-user-defn val
))))
963 (defun calc-valid-formula-func (func)
964 (let ((def (symbol-function func
)))
966 (eq (car def
) 'lambda
)
968 (setq def
(cdr (cdr def
)))
970 (not (eq (car (car def
)) 'math-normalize
)))
971 (setq def
(cdr def
)))
975 (defun calc-get-user-defn ()
978 (message "Get definition of command: z-")
979 (let* ((key (read-char))
980 (def (or (assq key
(calc-user-key-map))
981 (assq (upcase key
) (calc-user-key-map))
982 (assq (downcase key
) (calc-user-key-map))
983 (error "No command defined for that key")))
986 (setq cmd
(symbol-function cmd
)))
988 (message "Keyboard macro: %s" cmd
))
989 (t (let* ((func (calc-stack-command-p cmd
))
992 (get func
'calc-user-defn
))))
995 (and (calc-valid-formula-func func
)
996 (setq defn
(append '(calcFunc-lambda)
997 (mapcar 'math-build-var-name
998 (nth 1 (symbol-function
1001 (calc-enter-result 0 "gdef" defn
))
1002 (error "That command is not defined by a formula"))))))))
1005 (defun calc-user-define-permanent ()
1008 (message "Record in %s the command: z-" calc-settings-file
)
1009 (let* ((key (read-char))
1010 (def (or (assq key
(calc-user-key-map))
1011 (assq (upcase key
) (calc-user-key-map))
1012 (assq (downcase key
) (calc-user-key-map))
1018 (format "Record in %s the algebraic function: "
1020 (mapcar (lambda (x) (substring x
9))
1021 (all-completions "calcFunc-"
1025 (intern (concat "calcFunc-" x
))))
1029 (intern (completing-read
1030 (format "Record in %s the command: "
1032 obarray
'fboundp nil
"calc-"))))
1033 (error "No command defined for that key"))))
1034 (set-buffer (find-file-noselect (substitute-in-file-name
1035 calc-settings-file
)))
1036 (goto-char (point-max))
1037 (let* ((cmd (cdr def
))
1038 (fcmd (and cmd
(symbolp cmd
) (symbol-function cmd
)))
1044 (insert "\n;;; Definition stored by Calc on " (current-time-string)
1045 "\n(put 'calc-define '"
1046 (if (symbolp cmd
) (symbol-name cmd
) (format "key%d" key
))
1049 (eq (car-safe fcmd
) 'lambda
)
1050 (get cmd
'calc-user-defn
))
1052 (and (eq (car-safe (nth 3 fcmd
)) 'calc-execute-kbd-macro
)
1053 (vectorp (nth 1 (nth 3 fcmd
)))
1054 (progn (and (fboundp 'edit-kbd-macro
)
1055 (edit-kbd-macro nil
))
1056 (fboundp 'edmacro-parse-keys
))
1058 (aset (nth 1 (nth 3 fcmd
)) 1 nil
))
1059 (insert (setq str
(prin1-to-string
1060 (cons 'defun
(cons cmd
(cdr fcmd
)))))
1062 (or (and (string-match "\"" str
) (not q-ok
))
1063 (fill-region pt
(point)))
1064 (indent-rigidly pt
(point) 2)
1065 (delete-region pt
(1+ pt
))
1066 (insert " (put '" (symbol-name cmd
)
1067 " 'calc-user-defn '"
1068 (prin1-to-string (get cmd
'calc-user-defn
))
1070 (setq func
(calc-stack-command-p cmd
))
1071 (let ((ffunc (and func
(symbolp func
) (symbol-function func
)))
1074 (eq (car-safe ffunc
) 'lambda
)
1075 (get func
'calc-user-defn
)
1077 (insert (setq str
(prin1-to-string
1078 (cons 'defun
(cons func
1081 (or (and (string-match "\"" str
) (not q-ok
))
1082 (fill-region pt
(point)))
1083 (indent-rigidly pt
(point) 2)
1084 (delete-region pt
(1+ pt
))
1086 (insert "(put '" (symbol-name func
)
1087 " 'calc-user-defn '"
1088 (prin1-to-string (get func
'calc-user-defn
))
1090 (fill-region pt
(point))
1091 (indent-rigidly pt
(point) 2)
1092 (delete-region pt
(1+ pt
))))))
1094 (insert " (fset '" (prin1-to-string cmd
)
1095 " " (prin1-to-string fcmd
) ")\n")))
1096 (or func
(setq func
(and cmd
(symbolp cmd
) (fboundp cmd
) cmd
)))
1097 (if (get func
'math-compose-forms
)
1099 (insert "(put '" (symbol-name cmd
)
1100 " 'math-compose-forms '"
1101 (prin1-to-string (get func
'math-compose-forms
))
1103 (fill-region pt
(point))
1104 (indent-rigidly pt
(point) 2)
1105 (delete-region pt
(1+ pt
))))
1107 (insert " (define-key calc-mode-map "
1108 (prin1-to-string (concat "z" (char-to-string key
)))
1110 (prin1-to-string cmd
)
1115 (defun calc-stack-command-p (cmd)
1116 (if (and cmd
(symbolp cmd
))
1118 (calc-stack-command-p (symbol-function cmd
)))
1120 (eq (car cmd
) 'lambda
)
1121 (setq cmd
(or (assq 'calc-wrapper cmd
)
1122 (assq 'calc-slow-wrapper cmd
)))
1123 (setq cmd
(assq 'calc-enter-result cmd
))
1124 (memq (car (nth 3 cmd
)) '(cons list
))
1125 (eq (car (nth 1 (nth 3 cmd
))) 'quote
)
1126 (nth 1 (nth 1 (nth 3 cmd
))))))
1129 (defun calc-call-last-kbd-macro (arg)
1131 (and defining-kbd-macro
1132 (error "Can't execute anonymous macro while defining one"))
1134 (error "No kbd macro has been defined"))
1135 (calc-execute-kbd-macro last-kbd-macro arg
))
1137 (defun calc-execute-kbd-macro (mac arg
&rest prefix
)
1138 (if calc-keep-args-flag
1140 (if (and (vectorp mac
) (> (length mac
) 0) (stringp (aref mac
0)))
1141 (setq mac
(or (aref mac
1)
1142 (aset mac
1 (progn (and (fboundp 'edit-kbd-macro
)
1143 (edit-kbd-macro nil
))
1144 (edmacro-parse-keys (aref mac
0)))))))
1145 (if (< (prefix-numeric-value arg
) 0)
1146 (execute-kbd-macro mac
(- (prefix-numeric-value arg
)))
1147 (if calc-executing-macro
1148 (execute-kbd-macro mac arg
)
1150 (let ((old-stack-whole (copy-sequence calc-stack
))
1151 (old-stack-top calc-stack-top
)
1152 (old-buffer-size (buffer-size))
1153 (old-refresh-count calc-refresh-count
))
1155 (let ((calc-executing-macro mac
))
1156 (execute-kbd-macro mac arg
))
1157 (calc-select-buffer)
1158 (let ((new-stack (reverse calc-stack
))
1159 (old-stack (reverse old-stack-whole
)))
1160 (while (and new-stack old-stack
1161 (equal (car new-stack
) (car old-stack
)))
1162 (setq new-stack
(cdr new-stack
)
1163 old-stack
(cdr old-stack
)))
1164 (or (equal prefix
'(nil))
1165 (calc-record-list (if (> (length new-stack
) 1)
1166 (mapcar 'car new-stack
)
1168 (or (car prefix
) "kmac")))
1169 (calc-record-undo (list 'set
'saved-stack-top old-stack-top
))
1171 (calc-record-undo (list 'pop
1 (mapcar 'car old-stack
))))
1172 (let ((calc-stack old-stack-whole
)
1174 (calc-cursor-stack-index (length old-stack
)))
1175 (if (and (= old-buffer-size
(buffer-size))
1176 (= old-refresh-count calc-refresh-count
))
1177 (let ((buffer-read-only nil
))
1178 (delete-region (point) (point-max))
1180 (calc-record-undo (list 'push
1))
1181 (insert (math-format-stack-value (car new-stack
)) "\n")
1182 (setq new-stack
(cdr new-stack
)))
1183 (calc-renumber-stack))
1185 (calc-record-undo (list 'push
1))
1186 (setq new-stack
(cdr new-stack
)))
1188 (calc-record-undo (list 'set
'saved-stack-top
0)))))))))
1190 (defun calc-push-list-in-macro (vals m sels
)
1191 (let ((entry (list (car vals
) 1 (car sels
)))
1192 (mm (+ (or m
1) calc-stack-top
)))
1194 (setcdr (nthcdr (- mm
2) calc-stack
)
1195 (cons entry
(nthcdr (1- mm
) calc-stack
)))
1196 (setq calc-stack
(cons entry calc-stack
)))))
1198 (defun calc-pop-stack-in-macro (n mm
)
1200 (setcdr (nthcdr (- mm
2) calc-stack
)
1201 (nthcdr (+ n mm -
1) calc-stack
))
1202 (setq calc-stack
(nthcdr n calc-stack
))))
1205 (defun calc-kbd-if ()
1208 (let ((cond (calc-top-n 1)))
1210 (if (math-is-true cond
)
1211 (if defining-kbd-macro
1212 (message "If true..."))
1213 (if defining-kbd-macro
1214 (message "Condition is false; skipping to Z: or Z] ..."))
1215 (calc-kbd-skip-to-else-if t
)))))
1217 (defun calc-kbd-else-if ()
1221 (defun calc-kbd-skip-to-else-if (else-okay)
1225 (setq ch
(read-char))
1227 (error "Unterminated Z[ in keyboard macro"))
1230 (setq ch
(read-char))
1232 (setq count
(1+ count
)))
1234 (setq count
(1- count
)))
1240 (keyboard-quit))))))
1241 (and defining-kbd-macro
1244 (message "End-if...")))))
1246 (defun calc-kbd-end-if ()
1248 (if defining-kbd-macro
1249 (message "End-if...")))
1251 (defun calc-kbd-else ()
1253 (if defining-kbd-macro
1254 (message "Else; skipping to Z] ..."))
1255 (calc-kbd-skip-to-else-if nil
))
1258 (defun calc-kbd-repeat ()
1262 (setq count
(math-trunc (calc-top-n 1)))
1263 (or (Math-integerp count
)
1264 (error "Count must be an integer"))
1265 (if (Math-integer-negp count
)
1267 (or (integerp count
)
1268 (setq count
1000000))
1270 (calc-kbd-loop count
)))
1272 (defun calc-kbd-for (dir)
1276 (setq init
(calc-top-n 2)
1277 final
(calc-top-n 1))
1278 (or (and (math-anglep init
) (math-anglep final
))
1279 (error "Initial and final values must be real numbers"))
1281 (calc-kbd-loop nil init final
(and dir
(prefix-numeric-value dir
)))))
1283 (defun calc-kbd-loop (rpt-count &optional initial final dir
)
1285 (setq rpt-count
(if rpt-count
(prefix-numeric-value rpt-count
) 1000000))
1289 (open last-command-event
)
1292 (or executing-kbd-macro
1293 (message "Reading loop body..."))
1295 (setq ch
(read-char))
1297 (error "Unterminated Z%c in keyboard macro" open
))
1300 (setq ch
(read-char)
1301 body
(concat body
"Z" (char-to-string ch
)))
1302 (cond ((memq ch
'(?\
< ?\
( ?\
{))
1303 (setq count
(1+ count
)))
1304 ((memq ch
'(?\
> ?\
) ?\
}))
1305 (setq count
(1- count
)))
1308 (setq parts
(nconc parts
(list (concat (substring body
0 -
2)
1313 (setq body
(concat body
(char-to-string ch
)))))
1314 (if (/= ch
(cdr (assq open
'( (?\
< . ?\
>) (?\
( . ?\
)) (?\
{ . ?\
}) ))))
1315 (error "Mismatched Z%c and Z%c in keyboard macro" open ch
))
1316 (or executing-kbd-macro
1317 (message "Looping..."))
1318 (setq body
(concat (substring body
0 -
2) "Z]"))
1319 (and (not executing-kbd-macro
)
1320 (= rpt-count
1000000)
1324 (message "Warning: Infinite loop! Not executing")
1325 (setq rpt-count
0)))
1326 (or (not initial
) dir
1327 (setq dir
(math-compare final initial
)))
1329 (while (> rpt-count
0)
1332 (if (cond ((eq dir
0) (Math-equal final counter
))
1333 ((eq dir
1) (Math-lessp final counter
))
1334 ((eq dir -
1) (Math-lessp counter final
)))
1336 (calc-push counter
)))
1337 (while (and part
(> rpt-count
0))
1338 (execute-kbd-macro (car part
))
1339 (if (math-is-true (calc-top-n 1))
1341 (setq part
(cdr part
)))
1345 (execute-kbd-macro body
)
1347 (let ((step (calc-top-n 1)))
1349 (setq counter
(calcFunc-add counter step
)))
1350 (setq rpt-count
(1- rpt-count
))))))))
1351 (or executing-kbd-macro
1352 (message "Looping...done"))))
1354 (defun calc-kbd-end-repeat ()
1356 (error "Unbalanced Z> in keyboard macro"))
1358 (defun calc-kbd-end-for ()
1360 (error "Unbalanced Z) in keyboard macro"))
1362 (defun calc-kbd-end-loop ()
1364 (error "Unbalanced Z} in keyboard macro"))
1366 (defun calc-kbd-break ()
1369 (let ((cond (calc-top-n 1)))
1371 (if (math-is-true cond
)
1372 (error "Keyboard macro aborted")))))
1375 (defvar calc-kbd-push-level
0)
1377 ;; The variables var-q0 through var-q9 are the "quick" variables.
1389 (defun calc-kbd-push (arg)
1392 (let* ((defs (and arg
(> (prefix-numeric-value arg
) 0)))
1403 (calc-internal-prec (if defs
12 calc-internal-prec
))
1404 (calc-word-size (if defs
32 calc-word-size
))
1405 (calc-angle-mode (if defs
'deg calc-angle-mode
))
1406 (calc-simplify-mode (if defs nil calc-simplify-mode
))
1407 (calc-algebraic-mode (if arg nil calc-algebraic-mode
))
1408 (calc-incomplete-algebraic-mode (if arg nil
1409 calc-incomplete-algebraic-mode
))
1410 (calc-symbolic-mode (if defs nil calc-symbolic-mode
))
1411 (calc-matrix-mode (if defs nil calc-matrix-mode
))
1412 (calc-prefer-frac (if defs nil calc-prefer-frac
))
1413 (calc-complex-mode (if defs nil calc-complex-mode
))
1414 (calc-infinite-mode (if defs nil calc-infinite-mode
))
1418 (if (or executing-kbd-macro defining-kbd-macro
)
1420 (if defining-kbd-macro
1421 (message "Reading body..."))
1423 (setq ch
(read-char))
1425 (error "Unterminated Z` in keyboard macro"))
1428 (setq ch
(read-char)
1429 body
(concat body
"Z" (char-to-string ch
)))
1431 (setq count
(1+ count
)))
1433 (setq count
(1- count
)))
1436 (setq body
(concat body
(char-to-string ch
)))))
1437 (if defining-kbd-macro
1438 (message "Reading body...done"))
1439 (let ((calc-kbd-push-level 0))
1440 (execute-kbd-macro (substring body
0 -
2))))
1441 (let ((calc-kbd-push-level (1+ calc-kbd-push-level
)))
1442 (message "Saving modes; type Z' to restore")
1443 (recursive-edit))))))
1445 (defun calc-kbd-pop ()
1447 (if (> calc-kbd-push-level
0)
1449 (message "Mode settings restored")
1450 (exit-recursive-edit))
1451 (error "Unbalanced Z' in keyboard macro")))
1454 ;; (defun calc-kbd-report (msg)
1455 ;; (interactive "sMessage: ")
1457 ;; (math-working msg (calc-top-n 1))))
1459 (defun calc-kbd-query ()
1461 (let ((defining-kbd-macro nil
)
1462 (executing-kbd-macro nil
)
1464 (if (not (eq (car-safe msg
) 'vec
))
1465 (error "No prompt string provided")
1466 (setq msg
(math-vector-to-string msg
))
1469 (calc-alg-entry nil
(and (not (equal msg
"")) msg
))))))
1471 ;;;; Logical operations.
1473 (defun calcFunc-eq (a b
&rest more
)
1475 (let* ((args (cons a
(cons b
(copy-sequence more
))))
1479 (while (and (cdr p
) (not (eq res
0)))
1481 (while (and (setq p2
(cdr p2
)) (not (eq res
0)))
1482 (setq res
(math-two-eq (car p
) (car p2
)))
1484 (setcdr p
(delq (car p2
) (cdr p
)))))
1489 (cons 'calcFunc-eq args
)
1491 (or (math-two-eq a b
)
1492 (if (and (or (math-looks-negp a
) (math-zerop a
))
1493 (or (math-looks-negp b
) (math-zerop b
)))
1494 (list 'calcFunc-eq
(math-neg a
) (math-neg b
))
1495 (list 'calcFunc-eq a b
)))))
1497 (defun calcFunc-neq (a b
&rest more
)
1499 (let* ((args (cons a
(cons b more
)))
1504 (while (and (cdr p
) (not (eq res
1)))
1506 (while (and (setq p2
(cdr p2
)) (not (eq res
1)))
1507 (setq res
(math-two-eq (car p
) (car p2
)))
1508 (or res
(setq all nil
)))
1514 (cons 'calcFunc-neq args
))))
1515 (or (cdr (assq (math-two-eq a b
) '((0 .
1) (1 .
0))))
1516 (if (and (or (math-looks-negp a
) (math-zerop a
))
1517 (or (math-looks-negp b
) (math-zerop b
)))
1518 (list 'calcFunc-neq
(math-neg a
) (math-neg b
))
1519 (list 'calcFunc-neq a b
)))))
1521 (defun math-two-eq (a b
)
1522 (if (eq (car-safe a
) 'vec
)
1523 (if (eq (car-safe b
) 'vec
)
1524 (if (= (length a
) (length b
))
1526 (while (and (setq a
(cdr a
) b
(cdr b
)) (not (eq res
0)))
1528 (setq res
(math-two-eq (car a
) (car b
)))
1529 (if (eq (math-two-eq (car a
) (car b
)) 0)
1533 (if (Math-objectp b
)
1536 (if (eq (car-safe b
) 'vec
)
1537 (if (Math-objectp a
)
1540 (let ((res (math-compare a b
)))
1543 (if (and (= res
2) (not (and (Math-scalarp a
) (Math-scalarp b
))))
1547 (defun calcFunc-lt (a b
)
1548 (let ((res (math-compare a b
)))
1552 (if (and (or (math-looks-negp a
) (math-zerop a
))
1553 (or (math-looks-negp b
) (math-zerop b
)))
1554 (list 'calcFunc-gt
(math-neg a
) (math-neg b
))
1555 (list 'calcFunc-lt a b
))
1558 (defun calcFunc-gt (a b
)
1559 (let ((res (math-compare a b
)))
1563 (if (and (or (math-looks-negp a
) (math-zerop a
))
1564 (or (math-looks-negp b
) (math-zerop b
)))
1565 (list 'calcFunc-lt
(math-neg a
) (math-neg b
))
1566 (list 'calcFunc-gt a b
))
1569 (defun calcFunc-leq (a b
)
1570 (let ((res (math-compare a b
)))
1574 (if (and (or (math-looks-negp a
) (math-zerop a
))
1575 (or (math-looks-negp b
) (math-zerop b
)))
1576 (list 'calcFunc-geq
(math-neg a
) (math-neg b
))
1577 (list 'calcFunc-leq a b
))
1580 (defun calcFunc-geq (a b
)
1581 (let ((res (math-compare a b
)))
1585 (if (and (or (math-looks-negp a
) (math-zerop a
))
1586 (or (math-looks-negp b
) (math-zerop b
)))
1587 (list 'calcFunc-leq
(math-neg a
) (math-neg b
))
1588 (list 'calcFunc-geq a b
))
1591 (defun calcFunc-rmeq (a)
1592 (if (math-vectorp a
)
1593 (math-map-vec 'calcFunc-rmeq a
)
1594 (if (assq (car-safe a
) calc-tweak-eqn-table
)
1595 (if (and (eq (car-safe (nth 2 a
)) 'var
)
1596 (math-objectp (nth 1 a
)))
1599 (if (eq (car-safe a
) 'calcFunc-assign
)
1601 (if (eq (car-safe a
) 'calcFunc-evalto
)
1603 (list 'calcFunc-rmeq a
))))))
1605 (defun calcFunc-land (a b
)
1606 (cond ((Math-zerop a
)
1614 (t (list 'calcFunc-land a b
))))
1616 (defun calcFunc-lor (a b
)
1617 (cond ((Math-zerop a
)
1625 (t (list 'calcFunc-lor a b
))))
1627 (defun calcFunc-lnot (a)
1630 (if (math-is-true a
)
1632 (let ((op (and (= (length a
) 3)
1633 (assq (car a
) calc-tweak-eqn-table
))))
1635 (cons (nth 2 op
) (cdr a
))
1636 (list 'calcFunc-lnot a
))))))
1638 (defun calcFunc-if (c e1 e2
)
1641 (if (and (math-is-true c
) (not (Math-vectorp c
)))
1643 (or (and (Math-vectorp c
)
1645 (let ((ee1 (if (Math-vectorp e1
)
1646 (if (= (length c
) (length e1
))
1648 (calc-record-why "*Dimension error" e1
))
1650 (ee2 (if (Math-vectorp e2
)
1651 (if (= (length c
) (length e2
))
1653 (calc-record-why "*Dimension error" e2
))
1656 (cons 'vec
(math-if-vector (cdr c
) ee1 ee2
)))))
1657 (list 'calcFunc-if c e1 e2
)))))
1659 (defun math-if-vector (c e1 e2
)
1661 (cons (if (Math-zerop (car c
)) (car e2
) (car e1
))
1662 (math-if-vector (cdr c
)
1664 (or (cdr e2
) e2
)))))
1666 (defun math-normalize-logical-op (a)
1667 (or (and (eq (car a
) 'calcFunc-if
)
1669 (let ((a1 (math-normalize (nth 1 a
))))
1671 (math-normalize (nth 3 a
))
1672 (if (Math-numberp a1
)
1673 (math-normalize (nth 2 a
))
1674 (if (and (Math-vectorp (nth 1 a
))
1675 (math-constp (nth 1 a
)))
1676 (calcFunc-if (nth 1 a
)
1677 (math-normalize (nth 2 a
))
1678 (math-normalize (nth 3 a
)))
1679 (let ((calc-simplify-mode 'none
))
1680 (list 'calcFunc-if a1
1681 (math-normalize (nth 2 a
))
1682 (math-normalize (nth 3 a
)))))))))
1685 (defun calcFunc-in (a b
)
1686 (or (and (eq (car-safe b
) 'vec
)
1688 (while (and (setq bb
(cdr bb
))
1689 (not (if (memq (car-safe (car bb
)) '(vec intv
))
1690 (eq (calcFunc-in a
(car bb
)) 1)
1691 (Math-equal a
(car bb
))))))
1692 (if bb
1 (and (math-constp a
) (math-constp bb
) 0))))
1693 (and (eq (car-safe b
) 'intv
)
1694 (let ((res (math-compare a
(nth 2 b
))) res2
)
1698 (or (/= (nth 1 b
) 2)
1699 (Math-lessp (nth 2 b
) (nth 3 b
))))
1700 (if (memq (nth 1 b
) '(2 3)) 1 0))
1701 ((= (setq res2
(math-compare a
(nth 3 b
))) 1)
1704 (or (/= (nth 1 b
) 1)
1705 (Math-lessp (nth 2 b
) (nth 3 b
))))
1706 (if (memq (nth 1 b
) '(1 3)) 1 0))
1712 (and (Math-equal a b
)
1714 (and (math-constp a
) (math-constp b
)
1716 (list 'calcFunc-in a b
)))
1718 (defun calcFunc-typeof (a)
1719 (cond ((Math-integerp a
) 1)
1720 ((eq (car a
) 'frac
) 2)
1721 ((eq (car a
) 'float
) 3)
1722 ((eq (car a
) 'hms
) 4)
1723 ((eq (car a
) 'cplx
) 5)
1724 ((eq (car a
) 'polar
) 6)
1725 ((eq (car a
) 'sdev
) 7)
1726 ((eq (car a
) 'intv
) 8)
1727 ((eq (car a
) 'mod
) 9)
1728 ((eq (car a
) 'date
) (if (Math-integerp (nth 1 a
)) 10 11))
1730 (if (memq (nth 2 a
) '(var-inf var-uinf var-nan
)) 12 100))
1731 ((eq (car a
) 'vec
) (if (math-matrixp a
) 102 101))
1732 (t (math-calcFunc-to-var (car a
)))))
1734 (defun calcFunc-integer (a)
1735 (if (Math-integerp a
)
1737 (if (Math-objvecp a
)
1739 (list 'calcFunc-integer a
))))
1741 (defun calcFunc-real (a)
1744 (if (Math-objvecp a
)
1746 (list 'calcFunc-real a
))))
1748 (defun calcFunc-constant (a)
1751 (if (Math-objvecp a
)
1753 (list 'calcFunc-constant a
))))
1755 (defun calcFunc-refers (a b
)
1756 (if (math-expr-contains a b
)
1758 (if (eq (car-safe a
) 'var
)
1759 (list 'calcFunc-refers a b
)
1762 (defun calcFunc-negative (a)
1763 (if (math-looks-negp a
)
1765 (if (or (math-zerop a
)
1768 (list 'calcFunc-negative a
))))
1770 (defun calcFunc-variable (a)
1771 (if (eq (car-safe a
) 'var
)
1773 (if (Math-objvecp a
)
1775 (list 'calcFunc-variable a
))))
1777 (defun calcFunc-nonvar (a)
1778 (if (eq (car-safe a
) 'var
)
1779 (list 'calcFunc-nonvar a
)
1782 (defun calcFunc-istrue (a)
1783 (if (math-is-true a
)
1789 ;;;; User-programmability.
1791 ;;; Compiling Lisp-like forms to use the math library.
1793 (defun math-do-defmath (func args body
)
1794 (require 'calc-macs
)
1795 (let* ((fname (intern (concat "calcFunc-" (symbol-name func
))))
1796 (doc (if (stringp (car body
)) (list (car body
))))
1797 (clargs (mapcar 'math-clean-arg args
))
1798 (body (math-define-function-body
1799 (if (stringp (car body
)) (cdr body
) body
)
1802 (if (and (consp (car body
))
1803 (eq (car (car body
)) 'interactive
))
1804 (let ((inter (car body
)))
1805 (setq body
(cdr body
))
1806 (if (or (> (length inter
) 2)
1807 (integerp (nth 1 inter
)))
1808 (let ((hasprefix nil
) (hasmulti nil
))
1809 (if (stringp (nth 1 inter
))
1811 (cond ((equal (nth 1 inter
) "p")
1813 ((equal (nth 1 inter
) "m")
1816 "Can't handle interactive code string \"%s\""
1818 (setq inter
(cdr inter
))))
1819 (if (not (integerp (nth 1 inter
)))
1821 "Expected an integer in interactive specification"))
1822 (append (list 'defun
1823 (intern (concat "calc-"
1824 (symbol-name func
)))
1825 (if (or hasprefix hasmulti
)
1829 (if (or hasprefix hasmulti
)
1830 '((interactive "P"))
1834 '(calc-slow-wrapper)
1841 (list 'prefix-numeric-value
1845 (list 'calc-enter-result
1846 (if hasmulti
'n
(nth 1 inter
))
1850 (list 'quote
(list fname
))
1851 (list 'calc-top-list-n
1860 'prefix-numeric-value
1864 (list 'calc-top-list-n
1867 (nth 1 inter
)))))))))))
1868 (append (list 'defun
1869 (intern (concat "calc-" (symbol-name func
)))
1874 (cons 'calc-wrapper body
))))))
1875 (append (list 'defun
fname clargs
)
1877 (math-do-arg-list-check args nil nil
)
1880 (defun math-clean-arg (arg)
1882 (math-clean-arg (nth 1 arg
))
1885 (defun math-do-arg-check (arg var is-opt is-rest
)
1887 (let ((chk (math-do-arg-check arg var nil nil
)))
1891 (setq chk
(list (cons 'progn chk
)))
1894 (let* ((rest (math-do-arg-check (nth 1 arg
) var is-opt is-rest
))
1896 (qqual (list 'quote qual
))
1897 (qual-name (symbol-name qual
))
1898 (chk (intern (concat "math-check-" qual-name
))))
1904 (list 'mapcar
(list 'quote chk
) var
))
1905 (list 'setq var
(list chk var
)))))
1906 (if (fboundp (setq chk
(intern (concat "math-" qual-name
))))
1915 (list 'math-reject-arg
1920 (list 'math-reject-arg var qqual
)))))
1921 (if (and (string-match "\\`not-\\(.*\\)\\'" qual-name
)
1922 (fboundp (setq chk
(intern
1924 (math-match-substring
1934 (list 'math-reject-arg
1939 (list 'math-reject-arg var qqual
)))))
1940 (error "Unknown qualifier `%s'" qual-name
))))))))
1942 (defun math-do-arg-list-check (args is-opt is-rest
)
1943 (cond ((null args
) nil
)
1945 (append (math-do-arg-check (car args
)
1946 (math-clean-arg (car args
))
1948 (math-do-arg-list-check (cdr args
) is-opt is-rest
)))
1949 ((eq (car args
) '&optional
)
1950 (math-do-arg-list-check (cdr args
) t nil
))
1951 ((eq (car args
) '&rest
)
1952 (math-do-arg-list-check (cdr args
) nil t
))
1953 (t (math-do-arg-list-check (cdr args
) is-opt is-rest
))))
1955 (defconst math-prim-funcs
1956 '( (~
= . math-nearly-equal
)
1958 (lsh . calcFunc-lsh
)
1959 (ash . calcFunc-ash
)
1960 (logand . calcFunc-and
)
1961 (logandc2 . calcFunc-diff
)
1962 (logior . calcFunc-or
)
1963 (logxor . calcFunc-xor
)
1964 (lognot . calcFunc-not
)
1965 (equal . equal
) ; need to leave these ones alone!
1974 (defconst math-prim-vars
1977 (&optional .
&optional
)
1981 (defun math-define-function-body (body env
)
1982 (let ((body (math-define-body body env
)))
1983 (if (math-body-refers-to body
'math-return
)
1984 (list (cons 'catch
(cons '(quote math-return
) body
)))
1987 ;; The variable math-exp-env is local to math-define-body, but is
1988 ;; used by math-define-exp, which is called (indirectly) by
1989 ;; by math-define-body.
1990 (defvar math-exp-env
)
1992 (defun math-define-body (body math-exp-env
)
1993 (math-define-list body
))
1995 (defun math-define-list (body &optional quote
)
1998 ((and (eq (car body
) ':)
1999 (stringp (nth 1 body
)))
2000 (cons (let* ((math-read-expr-quotes t
)
2001 (exp (math-read-plain-expr (nth 1 body
) t
)))
2002 (math-define-exp exp
))
2003 (math-define-list (cdr (cdr body
)))))
2005 (cons (cond ((consp (car body
))
2006 (math-define-list (cdr body
) t
))
2009 (math-define-list (cdr body
))))
2011 (cons (math-define-exp (car body
))
2012 (math-define-list (cdr body
))))))
2014 (defun math-define-exp (exp)
2016 (let ((func (car exp
)))
2017 (cond ((memq func
'(quote function
))
2018 (if (and (consp (nth 1 exp
))
2019 (eq (car (nth 1 exp
)) 'lambda
))
2021 (math-define-lambda (nth 1 exp
) math-exp-env
))
2023 ((memq func
'(let let
* for foreach
))
2024 (let ((head (nth 1 exp
))
2025 (body (cdr (cdr exp
))))
2026 (if (memq func
'(let let
*))
2028 (setq func
(cdr (assq func
'((for . math-for
)
2029 (foreach . math-foreach
)))))
2030 (if (not (listp (car head
)))
2031 (setq head
(list head
))))
2034 (cons (math-define-let head
)
2035 (math-define-body body
2037 (math-define-let-env head
)
2039 ((and (memq func
'(setq setf
))
2040 (math-complicated-lhs (cdr exp
)))
2041 (if (> (length exp
) 3)
2042 (cons 'progn
(math-define-setf-list (cdr exp
)))
2043 (math-define-setf (nth 1 exp
) (nth 2 exp
))))
2044 ((eq func
'condition-case
)
2047 (math-define-body (cdr (cdr exp
))
2052 (math-define-cond (cdr exp
))))
2053 ((and (consp func
) ; ('spam a b) == force use of plain spam
2054 (eq (car func
) 'quote
))
2055 (cons func
(math-define-list (cdr exp
))))
2057 (let ((args (math-define-list (cdr exp
)))
2058 (prim (assq func math-prim-funcs
)))
2060 (cons (cdr prim
) args
))
2062 (list 'eq
(car args
) '(quote float
)))
2064 (math-define-binop 'math-add
0
2065 (car args
) (cdr args
)))
2067 (if (= (length args
) 1)
2068 (cons 'math-neg args
)
2069 (math-define-binop 'math-sub
0
2070 (car args
) (cdr args
))))
2072 (math-define-binop 'math-mul
1
2073 (car args
) (cdr args
)))
2075 (math-define-binop 'math-div
1
2076 (car args
) (cdr args
)))
2078 (math-define-binop 'math-min
0
2079 (car args
) (cdr args
)))
2081 (math-define-binop 'math-max
0
2082 (car args
) (cdr args
)))
2084 (if (and (math-numberp (nth 1 args
))
2085 (math-zerop (nth 1 args
)))
2086 (list 'math-negp
(car args
))
2087 (cons 'math-lessp args
)))
2089 (if (and (math-numberp (nth 1 args
))
2090 (math-zerop (nth 1 args
)))
2091 (list 'math-posp
(car args
))
2092 (list 'math-lessp
(nth 1 args
) (nth 0 args
))))
2095 (if (and (math-numberp (nth 1 args
))
2096 (math-zerop (nth 1 args
)))
2097 (list 'math-posp
(car args
))
2099 (nth 1 args
) (nth 0 args
)))))
2102 (if (and (math-numberp (nth 1 args
))
2103 (math-zerop (nth 1 args
)))
2104 (list 'math-negp
(car args
))
2105 (cons 'math-lessp args
))))
2107 (if (and (math-numberp (nth 1 args
))
2108 (math-zerop (nth 1 args
)))
2109 (list 'math-zerop
(nth 0 args
))
2110 (if (and (integerp (nth 1 args
))
2111 (/= (%
(nth 1 args
) 10) 0))
2112 (cons 'math-equal-int args
)
2113 (cons 'math-equal args
))))
2116 (if (and (math-numberp (nth 1 args
))
2117 (math-zerop (nth 1 args
)))
2118 (list 'math-zerop
(nth 0 args
))
2119 (if (and (integerp (nth 1 args
))
2120 (/= (%
(nth 1 args
) 10) 0))
2121 (cons 'math-equal-int args
)
2122 (cons 'math-equal args
)))))
2124 (list 'math-add
(car args
) 1))
2126 (list 'math-add
(car args
) -
1))
2127 ((eq func
'not
) ; optimize (not (not x)) => x
2128 (if (eq (car-safe args
) func
)
2131 ((and (eq func
'elt
) (cdr (cdr args
)))
2132 (math-define-elt (car args
) (cdr args
)))
2135 (let* ((name (symbol-name func
))
2136 (cfunc (intern (concat "calcFunc-" name
)))
2137 (mfunc (intern (concat "math-" name
))))
2138 (cond ((fboundp cfunc
)
2143 (string-match "\\`calcFunc-.*" name
))
2146 (cons cfunc args
)))))))))
2147 (t (cons func
(math-define-list (cdr exp
))))))) ;;args
2149 (let ((prim (assq exp math-prim-vars
))
2150 (name (symbol-name exp
)))
2153 ((memq exp math-exp-env
)
2155 ((string-match "-" name
)
2158 (intern (concat "var-" name
))))))
2160 (if (or (<= exp -
1000000) (>= exp
1000000))
2161 (list 'quote
(math-normalize exp
))
2165 (defun math-define-cond (forms)
2167 (cons (math-define-list (car forms
))
2168 (math-define-cond (cdr forms
)))))
2170 (defun math-complicated-lhs (body)
2172 (or (not (symbolp (car body
)))
2173 (math-complicated-lhs (cdr (cdr body
))))))
2175 (defun math-define-setf-list (body)
2177 (cons (math-define-setf (nth 0 body
) (nth 1 body
))
2178 (math-define-setf-list (cdr (cdr body
))))))
2180 (defun math-define-setf (place value
)
2181 (setq place
(math-define-exp place
)
2182 value
(math-define-exp value
))
2183 (cond ((symbolp place
)
2184 (list 'setq place value
))
2185 ((eq (car-safe place
) 'nth
)
2186 (list 'setcar
(list 'nthcdr
(nth 1 place
) (nth 2 place
)) value
))
2187 ((eq (car-safe place
) 'elt
)
2188 (list 'setcar
(list 'nthcdr
(nth 2 place
) (nth 1 place
)) value
))
2189 ((eq (car-safe place
) 'car
)
2190 (list 'setcar
(nth 1 place
) value
))
2191 ((eq (car-safe place
) 'cdr
)
2192 (list 'setcdr
(nth 1 place
) value
))
2194 (error "Bad place form for setf: %s" place
))))
2196 (defun math-define-binop (op ident arg1 rest
)
2198 (math-define-binop op ident
2199 (list op arg1
(car rest
))
2203 (defun math-define-let (vlist)
2205 (cons (if (consp (car vlist
))
2206 (cons (car (car vlist
))
2207 (math-define-list (cdr (car vlist
))))
2209 (math-define-let (cdr vlist
)))))
2211 (defun math-define-let-env (vlist)
2213 (cons (if (consp (car vlist
))
2216 (math-define-let-env (cdr vlist
)))))
2218 (defun math-define-lambda (exp exp-env
)
2219 (nconc (list (nth 0 exp
) ; 'lambda
2220 (nth 1 exp
)) ; arg list
2221 (math-define-function-body (cdr (cdr exp
))
2222 (append (nth 1 exp
) exp-env
))))
2224 (defun math-define-elt (seq idx
)
2226 (math-define-elt (list 'elt seq
(car idx
)) (cdr idx
))
2231 ;;; Useful programming macros.
2233 (defmacro math-while
(head &rest body
)
2234 (let ((body (cons 'while
(cons head body
))))
2235 (if (math-body-refers-to body
'math-break
)
2236 (cons 'catch
(cons '(quote math-break
) (list body
)))
2238 ;; (put 'math-while 'lisp-indent-hook 1)
2240 (defmacro math-for
(head &rest body
)
2241 (let ((body (if head
2242 (math-handle-for head body
)
2243 (cons 'while
(cons t body
)))))
2244 (if (math-body-refers-to body
'math-break
)
2245 (cons 'catch
(cons '(quote math-break
) (list body
)))
2247 ;; (put 'math-for 'lisp-indent-hook 1)
2249 (defun math-handle-for (head body
)
2250 (let* ((var (nth 0 (car head
)))
2251 (init (nth 1 (car head
)))
2252 (limit (nth 2 (car head
)))
2253 (step (or (nth 3 (car head
)) 1))
2254 (body (if (cdr head
)
2255 (list (math-handle-for (cdr head
) body
))
2257 (all-ints (and (integerp init
) (integerp limit
) (integerp step
)))
2258 (const-limit (or (integerp limit
)
2259 (and (eq (car-safe limit
) 'quote
)
2260 (math-realp (nth 1 limit
)))))
2261 (const-step (or (integerp step
)
2262 (and (eq (car-safe step
) 'quote
)
2263 (math-realp (nth 1 step
)))))
2264 (save-limit (if const-limit limit
(make-symbol "<limit>")))
2265 (save-step (if const-step step
(make-symbol "<step>"))))
2267 (cons (append (if const-limit nil
(list (list save-limit limit
)))
2268 (if const-step nil
(list (list save-step step
)))
2269 (list (list var init
)))
2274 (list '<= var save-limit
)
2275 (list '>= var save-limit
))
2278 (if (or (math-posp step
)
2303 save-step
)))))))))))
2305 (defmacro math-foreach
(head &rest body
)
2306 (let ((body (math-handle-foreach head body
)))
2307 (if (math-body-refers-to body
'math-break
)
2308 (cons 'catch
(cons '(quote math-break
) (list body
)))
2310 ;; (put 'math-foreach 'lisp-indent-hook 1)
2312 (defun math-handle-foreach (head body
)
2313 (let ((var (nth 0 (car head
)))
2314 (data (nth 1 (car head
)))
2315 (body (if (cdr head
)
2316 (list (math-handle-foreach (cdr head
) body
))
2319 (cons (list (list var data
))
2326 (list 'cdr var
)))))))))))
2329 (defun math-body-refers-to (body thing
)
2330 (or (equal body thing
)
2332 (or (math-body-refers-to (car body
) thing
)
2333 (math-body-refers-to (cdr body
) thing
)))))
2335 (defun math-break (&optional value
)
2336 (throw 'math-break value
))
2338 (defun math-return (&optional value
)
2339 (throw 'math-return value
))
2345 (defun math-composite-inequalities (x op
)
2346 (if (memq (nth 1 op
) '(calcFunc-eq calcFunc-neq
))
2347 (if (eq (car x
) (nth 1 op
))
2348 (append x
(list (math-read-expr-level (nth 3 op
))))
2349 (throw 'syntax
"Syntax error"))
2352 (if (memq (nth 1 op
) '(calcFunc-lt calcFunc-leq
))
2353 (if (memq (car x
) '(calcFunc-lt calcFunc-leq
))
2355 (+ (if (eq (car x
) 'calcFunc-leq
) 2 0)
2356 (if (eq (nth 1 op
) 'calcFunc-leq
) 1 0))
2357 (nth 1 x
) (math-read-expr-level (nth 3 op
)))
2358 (throw 'syntax
"Syntax error"))
2359 (if (memq (car x
) '(calcFunc-gt calcFunc-geq
))
2361 (+ (if (eq (nth 1 op
) 'calcFunc-geq
) 2 0)
2362 (if (eq (car x
) 'calcFunc-geq
) 1 0))
2363 (math-read-expr-level (nth 3 op
)) (nth 1 x
))
2364 (throw 'syntax
"Syntax error"))))))
2366 (provide 'calc-prog
)
2368 ;; arch-tag: 4c5a183b-c9e5-4632-bb3f-e41a764518b0
2369 ;;; calc-prog.el ends here