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 ;; Maintainer: Jay Belanger <belanger@truman.edu>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY. No author or distributor
12 ;; accepts responsibility to anyone for the consequences of using it
13 ;; or for whether it serves any particular purpose or works at all,
14 ;; unless he says so in writing. Refer to the GNU Emacs General Public
15 ;; License for full details.
17 ;; Everyone is granted permission to copy, modify and redistribute
18 ;; GNU Emacs, but only under the conditions described in the
19 ;; GNU Emacs General Public License. A copy of this license is
20 ;; supposed to have been given to you along with GNU Emacs so you
21 ;; can know your rights and responsibilities. It should be in a
22 ;; file named COPYING. Among other things, the copyright notice
23 ;; and this notice must be preserved on all copies.
29 ;; This file is autoloaded from calc-ext.el.
35 (defun calc-equal-to (arg)
38 (if (and (integerp arg
) (> arg
2))
39 (calc-enter-result arg
"eq" (cons 'calcFunc-eq
(calc-top-list-n arg
)))
40 (calc-binary-op "eq" 'calcFunc-eq arg
))))
42 (defun calc-remove-equal (arg)
45 (calc-unary-op "rmeq" 'calcFunc-rmeq arg
)))
47 (defun calc-not-equal-to (arg)
50 (if (and (integerp arg
) (> arg
2))
51 (calc-enter-result arg
"neq" (cons 'calcFunc-neq
(calc-top-list-n arg
)))
52 (calc-binary-op "neq" 'calcFunc-neq arg
))))
54 (defun calc-less-than (arg)
57 (calc-binary-op "lt" 'calcFunc-lt arg
)))
59 (defun calc-greater-than (arg)
62 (calc-binary-op "gt" 'calcFunc-gt arg
)))
64 (defun calc-less-equal (arg)
67 (calc-binary-op "leq" 'calcFunc-leq arg
)))
69 (defun calc-greater-equal (arg)
72 (calc-binary-op "geq" 'calcFunc-geq arg
)))
74 (defun calc-in-set (arg)
77 (calc-binary-op "in" 'calcFunc-in arg
)))
79 (defun calc-logical-and (arg)
82 (calc-binary-op "land" 'calcFunc-land arg
1)))
84 (defun calc-logical-or (arg)
87 (calc-binary-op "lor" 'calcFunc-lor arg
0)))
89 (defun calc-logical-not (arg)
92 (calc-unary-op "lnot" 'calcFunc-lnot arg
)))
94 (defun calc-logical-if ()
97 (calc-enter-result 3 "if" (cons 'calcFunc-if
(calc-top-list-n 3)))))
103 (defun calc-timing (n)
106 (calc-change-mode 'calc-timing n nil t
)
107 (message (if calc-timing
108 "Reporting timing of slow commands in Trail"
109 "Not reporting timing of commands"))))
111 (defun calc-pass-errors ()
113 ;; The following two cases are for the new, optimizing byte compiler
114 ;; or the standard 18.57 byte compiler, respectively.
116 (let ((place (aref (nth 2 (nth 2 (symbol-function 'calc-do
))) 15)))
117 (or (memq (car-safe (car-safe place
)) '(error xxxerror
))
118 (setq place
(aref (nth 2 (nth 2 (symbol-function 'calc-do
))) 27)))
119 (or (memq (car (car place
)) '(error xxxerror
))
121 (setcar (car place
) 'xxxerror
))
122 (error (error "The calc-do function has been modified; unable to patch"))))
124 (defun calc-user-define ()
126 (message "Define user key: z-")
127 (let ((key (read-char)))
128 (if (= (calc-user-function-classify key
) 0)
129 (error "Can't redefine \"?\" key"))
130 (let ((func (intern (completing-read (concat "Set key z "
137 (let* ((kmap (calc-user-key-map))
138 (old (assq key kmap
)))
141 (setcdr kmap
(cons (cons key func
) (cdr kmap
))))))))
143 (defun calc-user-undefine ()
145 (message "Undefine user key: z-")
146 (let ((key (read-char)))
147 (if (= (calc-user-function-classify key
) 0)
148 (error "Can't undefine \"?\" key"))
149 (let* ((kmap (calc-user-key-map)))
150 (delq (or (assq key kmap
)
151 (assq (upcase key
) kmap
)
152 (assq (downcase key
) kmap
)
153 (error "No such user key is defined"))
157 ;; math-integral-cache-state is originally declared in calcalg2.el,
158 ;; it is used in calc-user-define-variable.
159 (defvar math-integral-cache-state
)
161 ;; calc-user-formula-alist is local to calc-user-define-formula,
162 ;; calc-user-define-compostion and calc-finish-formula-edit,
163 ;; but is used by calc-fix-user-formula.
164 (defvar calc-user-formula-alist
)
166 (defun calc-user-define-formula ()
169 (let* ((form (calc-top 1))
171 (is-lambda (and (eq (car-safe form
) 'calcFunc-lambda
)
172 (>= (length form
) 2)))
173 odef key keyname cmd cmd-base cmd-base-default
174 func calc-user-formula-alist is-symb
)
176 (setq arglist
(mapcar (function (lambda (x) (nth 1 x
)))
177 (nreverse (cdr (reverse (cdr form
)))))
178 form
(nth (1- (length form
)) form
))
179 (calc-default-formula-arglist form
)
180 (setq arglist
(sort arglist
'string-lessp
)))
181 (message "Define user key: z-")
182 (setq key
(read-char))
183 (if (= (calc-user-function-classify key
) 0)
184 (error "Can't redefine \"?\" key"))
185 (setq key
(and (not (memq key
'(13 32))) key
)
187 (if (or (and (<= ?
0 key
) (<= key ?
9))
188 (and (<= ?a key
) (<= key ?z
))
189 (and (<= ?A key
) (<= key ?Z
)))
191 (format "%03d" key
)))
192 odef
(assq key
(calc-user-key-map)))
194 (setq keyname
(format "%05d" (abs (%
(random) 10000)))))
197 (setq cmd-base-default
(concat "User-" keyname
))
198 (setq cmd
(completing-read
199 (concat "Define M-x command name (default: calc-"
202 obarray
'commandp nil
203 (if (and odef
(symbolp (cdr odef
)))
204 (symbol-name (cdr odef
))
206 (if (or (string-equal cmd
"")
207 (string-equal cmd
"calc-"))
208 (setq cmd
(concat "calc-User-" keyname
)))
209 (setq cmd-base
(and (string-match "\\`calc-\\(.+\\)\\'" cmd
)
210 (math-match-substring cmd
1)))
211 (setq cmd
(intern cmd
))
217 (if (get cmd
'calc-user-defn
)
218 (concat "Replace previous definition for "
219 (symbol-name cmd
) "? ")
220 "That name conflicts with a built-in Emacs function. Replace this function? "))))))
223 (setq cmd-base-default
226 "\\`User-.+" cmd-base
)
229 (substring cmd-base
5))
231 (concat "User" keyname
)))
235 (concat "Define algebraic function name (default: "
236 cmd-base-default
"): ")
237 (mapcar (lambda (x) (substring x
9))
238 (all-completions "calcFunc-"
242 (intern (concat "calcFunc-" x
))))
245 (if (string-equal func
"calcFunc-")
246 (intern (concat "calcFunc-" cmd-base-default
))
254 (if (get func
'calc-user-defn
)
255 (concat "Replace previous definition for "
256 (symbol-name func
) "? ")
257 "That name conflicts with a built-in Emacs function. Replace this function? "))))))
260 (setq func
(intern (concat "calcFunc-User"
262 (and cmd
(symbol-name cmd
))
263 (format "%05d" (%
(random) 10000)))))))
266 (setq calc-user-formula-alist arglist
)
269 (setq calc-user-formula-alist
270 (read-from-minibuffer "Function argument list: "
272 (prin1-to-string arglist
)
276 (and (not (calc-subsetp calc-user-formula-alist arglist
))
278 "Okay for arguments that don't appear in formula to be ignored? "))))))
279 (setq is-symb
(and calc-user-formula-alist
282 "Leave it symbolic for non-constant arguments? ")))
283 (setq calc-user-formula-alist
284 (mapcar (function (lambda (x)
285 (or (cdr (assq x
'((nil . arg-nil
)
287 x
))) calc-user-formula-alist
))
296 (list 'calc-enter-result
297 (length calc-user-formula-alist
)
298 (let ((name (symbol-name (or func cmd
))))
300 "\\([^-][^-]?[^-]?[^-]?\\)[^-]*\\'"
302 (math-match-substring name
1)))
305 (list 'calc-top-list-n
306 (length calc-user-formula-alist
)))))))
307 (put cmd
'calc-user-defn t
)))
308 (let ((body (list 'math-normalize
(calc-fix-user-formula form
))))
311 (list 'lambda calc-user-formula-alist
)
313 (mapcar (function (lambda (v)
314 (list 'math-check-const v t
)))
315 calc-user-formula-alist
))
317 (put func
'calc-user-defn form
)
318 (setq math-integral-cache-state nil
)
320 (let* ((kmap (calc-user-key-map))
321 (old (assq key kmap
)))
324 (setcdr kmap
(cons (cons key cmd
) (cdr kmap
)))))))
327 (defun calc-default-formula-arglist (form)
329 (if (eq (car form
) 'var
)
330 (if (or (memq (nth 1 form
) arglist
)
331 (math-const-var form
))
333 (setq arglist
(cons (nth 1 form
) arglist
)))
334 (calc-default-formula-arglist-step (cdr form
)))))
336 (defun calc-default-formula-arglist-step (l)
339 (calc-default-formula-arglist (car l
))
340 (calc-default-formula-arglist-step (cdr l
)))))
342 (defun calc-subsetp (a b
)
344 (and (memq (car a
) b
)
345 (calc-subsetp (cdr a
) b
))))
347 (defun calc-fix-user-formula (f)
350 (cond ((and (eq (car f
) 'var
)
351 (memq (setq temp
(or (cdr (assq (nth 1 f
) '((nil . arg-nil
)
354 calc-user-formula-alist
))
356 ((or (math-constp f
) (eq (car f
) 'var
))
358 ((and (eq (car f
) 'calcFunc-eval
)
360 (list 'let
'((calc-simplify-mode nil
))
361 (list 'math-normalize
(calc-fix-user-formula (nth 1 f
)))))
362 ((and (eq (car f
) 'calcFunc-evalsimp
)
364 (list 'math-simplify
(calc-fix-user-formula (nth 1 f
))))
365 ((and (eq (car f
) 'calcFunc-evalextsimp
)
367 (list 'math-simplify-extended
368 (calc-fix-user-formula (nth 1 f
))))
371 (cons (list 'quote
(car f
))
372 (mapcar 'calc-fix-user-formula
(cdr f
)))))))
375 (defun calc-user-define-composition ()
378 (if (eq calc-language
'unform
)
379 (error "Can't define formats for unformatted mode"))
380 (let* ((comp (calc-top 1))
383 (completing-read "Define format for which function: "
384 (mapcar (lambda (x) (substring x
9))
385 (all-completions "calcFunc-"
389 (intern (concat "calcFunc-" x
))))))))
390 (comps (get func
'math-compose-forms
))
393 (calc-user-formula-alist nil
))
394 (if (math-zerop comp
)
395 (if (setq entry
(assq calc-language comps
))
396 (put func
'math-compose-forms
(delq entry comps
)))
397 (calc-default-formula-arglist comp
)
398 (setq arglist
(sort arglist
'string-lessp
))
401 (setq calc-user-formula-alist
402 (read-from-minibuffer "Composition argument list: "
404 (prin1-to-string arglist
)
408 (and (not (calc-subsetp calc-user-formula-alist arglist
))
410 "Okay for arguments that don't appear in formula to be invisible? "))))
411 (or (setq entry
(assq calc-language comps
))
412 (put func
'math-compose-forms
413 (cons (setq entry
(list calc-language
)) comps
)))
414 (or (setq entry2
(assq (length calc-user-formula-alist
) (cdr entry
)))
417 (list (length calc-user-formula-alist
))) (cdr entry
))))
419 (list 'lambda calc-user-formula-alist
(calc-fix-user-formula comp
))))
424 (defun calc-user-define-kbd-macro (arg)
427 (error "No keyboard macro defined"))
428 (message "Define last kbd macro on user key: z-")
429 (let ((key (read-char)))
430 (if (= (calc-user-function-classify key
) 0)
431 (error "Can't redefine \"?\" key"))
432 (let ((cmd (intern (completing-read "Full name for new command: "
437 (if (or (and (>= key ?a
)
444 (format "%03d" key
)))))))
446 (not (let ((f (symbol-function cmd
)))
449 (eq (car-safe (nth 3 f
))
450 'calc-execute-kbd-macro
)))))
451 (error "Function %s is already defined and not a keyboard macro"
453 (put cmd
'calc-user-defn t
)
454 (fset cmd
(if (< (prefix-numeric-value arg
) 0)
459 (list 'calc-execute-kbd-macro
460 (vector (key-description last-kbd-macro
)
463 (format "z%c" key
)))))
464 (let* ((kmap (calc-user-key-map))
465 (old (assq key kmap
)))
468 (setcdr kmap
(cons (cons key cmd
) (cdr kmap
))))))))
471 (defun calc-edit-user-syntax ()
474 (let ((lang calc-language
))
475 (calc-edit-mode (list 'calc-finish-user-syntax-edit
(list 'quote lang
))
477 (format "Editing %s-Mode Syntax Table. "
478 (cond ((null lang
) "Normal")
479 ((eq lang
'tex
) "TeX")
480 (t (capitalize (symbol-name lang
))))))
481 (calc-write-parse-table (cdr (assq lang calc-user-parse-tables
))
483 (calc-show-edit-buffer))
485 (defvar calc-original-buffer
)
487 (defun calc-finish-user-syntax-edit (lang)
488 (let ((tab (calc-read-parse-table calc-original-buffer lang
))
489 (entry (assq lang calc-user-parse-tables
)))
492 (car (setq calc-user-parse-tables
493 (cons (list lang
) calc-user-parse-tables
))))
496 (setq calc-user-parse-tables
497 (delq entry calc-user-parse-tables
)))))
498 (switch-to-buffer calc-original-buffer
))
500 ;; The variable calc-lang is local to calc-write-parse-table, but is
501 ;; used by calc-write-parse-table-part which is called by
502 ;; calc-write-parse-table. The variable is also local to
503 ;; calc-read-parse-table, but is used by calc-fix-token-name which
504 ;; is called (indirectly) by calc-read-parse-table.
507 (defun calc-write-parse-table (tab calc-lang
)
510 (calc-write-parse-table-part (car (car p
)))
512 (let ((math-format-hash-args t
))
513 (math-format-flat-expr (cdr (car p
)) 0))
517 (defun calc-write-parse-table-part (p)
519 (cond ((stringp (car p
))
521 (if (and (string-match "\\`\\\\dots\\>" s
)
522 (not (eq calc-lang
'tex
)))
523 (setq s
(concat ".." (substring s
5))))
524 (if (or (and (string-match
525 "[a-zA-Z0-9\"{}]\\|\\`:=\\'\\|\\`#\\|\\`%%" s
)
526 (string-match "[^a-zA-Z0-9\\]" s
))
527 (and (assoc s
'((")") ("]") (">")))
529 (insert (prin1-to-string s
) " ")
534 (insert "/" (int-to-string (car p
))))
536 ((and (eq (car (car p
)) '\?) (equal (car (nth 2 (car p
))) "$$"))
537 (insert (car (nth 1 (car p
))) " "))
540 (calc-write-parse-table-part (nth 1 (car p
)))
541 (insert "}" (symbol-name (car (car p
))))
543 (calc-write-parse-table-part (list (car (nth 2 (car p
)))))
547 (defun calc-read-parse-table (calc-buf calc-lang
)
550 (skip-chars-forward "\n\t ")
552 (if (looking-at "%%")
555 (p (calc-read-parse-table-part ":=[\n\t ]+" ":=")))
556 (or (stringp (car p
))
557 (and (integerp (car p
))
561 (error "Malformed syntax rule")))
564 (let* ((str (buffer-substring pos
(point)))
566 (set-buffer calc-buf
)
567 (let ((calc-user-parse-tables nil
)
569 (math-expr-opers math-standard-opers
)
570 (calc-hashes-used 0))
572 (if (string-match ",[ \t]*\\'" str
)
573 (substring str
0 (match-beginning 0))
575 (if (eq (car-safe exp
) 'error
)
577 (goto-char (+ pos
(nth 1 exp
)))
578 (error (nth 2 exp
))))
579 (setq tab
(nconc tab
(list (cons p exp
)))))))))
582 (defun calc-fix-token-name (name &optional unquoted
)
583 (cond ((string-match "\\`\\.\\." name
)
584 (concat "\\dots" (substring name
2)))
585 ((and (equal name
"{") (memq calc-lang
'(tex eqn
)))
587 ((and (equal name
"}") (memq calc-lang
'(tex eqn
)))
589 ((and (equal name
"&") (eq calc-lang
'tex
))
592 (search-backward "#")
593 (error "Token '#' is reserved"))
594 ((and unquoted
(string-match "#" name
))
595 (error "Tokens containing '#' must be quoted"))
596 ((not (string-match "[^ ]" name
))
597 (search-backward "\"" nil t
)
598 (error "Blank tokens are not allowed"))
601 (defun calc-read-parse-table-part (term eterm
)
605 (skip-chars-forward "\n\t ")
606 (if (eobp) (error "Expected '%s'" eterm
))
607 (not (looking-at term
)))
608 (cond ((looking-at "%%")
610 ((looking-at "{[\n\t ]")
612 (let ((p (calc-read-parse-table-part "}" "}")))
613 (or (looking-at "[+*?]")
614 (error "Expected '+', '*', or '?'"))
615 (let ((sym (intern (buffer-substring (point) (1+ (point))))))
617 (looking-at "[^\n\t ]*")
618 (let ((sep (buffer-substring (point) (match-end 0))))
619 (goto-char (match-end 0))
620 (and (eq sym
'\?) (> (length sep
) 0)
621 (not (equal sep
"$")) (not (equal sep
"."))
622 (error "Separator not allowed with { ... }?"))
623 (if (string-match "\\`\"" sep
)
624 (setq sep
(read-from-string sep
)))
625 (setq sep
(calc-fix-token-name sep
))
626 (setq part
(nconc part
628 (and (> (length sep
) 0)
629 (cons sep p
))))))))))
631 (error "Too many }'s"))
633 (setq quoted
(calc-fix-token-name (read (current-buffer)))
634 part
(nconc part
(list quoted
))))
635 ((looking-at "#\\(\\(/[0-9]+\\)?\\)[\n\t ]")
636 (setq part
(nconc part
(list (if (= (match-beginning 1)
641 (1+ (match-beginning 1))
643 (goto-char (match-end 0)))
644 ((looking-at ":=[\n\t ]")
645 (error "Misplaced ':='"))
647 (looking-at "[^\n\t ]*")
648 (let ((end (match-end 0)))
649 (setq part
(nconc part
(list (calc-fix-token-name
653 (goto-char (match-end 0))
654 (let ((len (length part
)))
655 (while (and (> len
1)
656 (let ((last (nthcdr (setq len
(1- len
)) part
)))
657 (and (assoc (car last
) '((")") ("]") (">")))
658 (not (eq (car last
) quoted
))
660 (list '\? (list (car last
)) '("$$"))))))))
663 (defun calc-user-define-invocation ()
666 (error "No keyboard macro defined"))
667 (setq calc-invocation-macro last-kbd-macro
)
668 (message "Use `M-# Z' to invoke this macro"))
670 (defun calc-user-define-edit ()
671 (interactive) ; but no calc-wrapper!
672 (message "Edit definition of command: z-")
673 (let* ((key (read-char))
674 (def (or (assq key
(calc-user-key-map))
675 (assq (upcase key
) (calc-user-key-map))
676 (assq (downcase key
) (calc-user-key-map))
677 (error "No command defined for that key")))
680 (setq cmdname
(symbol-name cmd
))
681 (setq cmd
(symbol-function cmd
)))
682 (cond ((or (stringp cmd
)
684 (eq (car-safe (nth 3 cmd
)) 'calc-execute-kbd-macro
)))
685 (let* ((mac (elt (nth 1 (nth 3 cmd
)) 1))
686 (str (edmacro-format-keys mac t
))
687 (kys (nth 3 (nth 3 cmd
))))
689 (list 'calc-edit-macro-finish-edit cmdname kys
)
691 "Editing keyboard macro (%s, bound to %s).\n"
692 "Original keys: %s \n")
693 cmdname kys
(elt (nth 1 (nth 3 cmd
)) 0)))
695 (calc-edit-format-macro-buffer)
696 (calc-show-edit-buffer)))
697 (t (let* ((func (calc-stack-command-p cmd
))
700 (get func
'calc-user-defn
)))
701 (kys (concat "z" (char-to-string (car def
))))
702 (intcmd (symbol-name (cdr def
)))
703 (algcmd (substring (symbol-name func
) 9)))
704 (if (and defn
(calc-valid-formula-func func
))
705 (let ((niceexpr (math-format-nice-expr defn
(frame-width))))
708 (list 'calc-finish-formula-edit
(list 'quote func
))
711 "Editing formula (%s, %s, bound to %s).\n"
712 "Original formula: %s\n")
713 intcmd algcmd kys niceexpr
))
714 (insert (math-showing-full-precision
717 (calc-show-edit-buffer))
718 (error "That command's definition cannot be edited")))))))
720 ;; Formatting the macro buffer
722 (defun calc-edit-macro-repeats ()
723 (goto-char calc-edit-top
)
725 (re-search-forward "^\\([0-9]+\\)\\*" nil t
)
726 (setq num
(string-to-int (match-string 1)))
727 (setq line
(buffer-substring (point) (line-end-position)))
728 (goto-char (line-beginning-position))
732 (setq num
(1- num
)))))
734 (defun calc-edit-macro-adjust-buffer ()
735 (calc-edit-macro-repeats)
736 (goto-char calc-edit-top
)
737 (while (re-search-forward "^RET$" nil t
)
739 (goto-char calc-edit-top
)
740 (while (and (re-search-forward "^$" nil t
)
741 (not (= (point) (point-max))))
744 (defun calc-edit-macro-command ()
745 "Return the command on the current line in a Calc macro editing buffer."
746 (let ((beg (line-beginning-position))
748 (if (search-forward ";;" (line-end-position) 1)
750 (skip-chars-backward " \t")
752 (buffer-substring beg end
)))
754 (defun calc-edit-macro-command-type ()
755 "Return the type of command on the current line in a Calc macro editing buffer."
756 (let ((beg (save-excursion
757 (if (search-forward ";;" (line-end-position) t
)
759 (skip-chars-forward " \t")
762 (goto-char (line-end-position))
763 (skip-chars-backward " \t")
766 (buffer-substring beg end
)
769 (defun calc-edit-macro-combine-alg-ent ()
770 "Put an entire algebraic entry on a single line."
771 (let ((line (calc-edit-macro-command))
772 (type (calc-edit-macro-command-type))
775 (goto-char (line-beginning-position))
777 (setq curline
(calc-edit-macro-command))
779 (not (string-equal "RET" curline
))
780 (not (setq match
(string-match "<return>" curline
))))
781 (setq line
(concat line curline
))
783 (setq curline
(calc-edit-macro-command)))
786 (setq line
(concat line
(substring curline
0 match
))))
787 (setq line
(replace-regexp-in-string "SPC" " SPC "
788 (replace-regexp-in-string " " "" line
)))
789 (insert line
"\t\t\t")
790 (if (> (current-column) 24)
792 (insert ";; " type
"\n")
794 (insert "RET\t\t\t;; calc-enter\n"))))
796 (defun calc-edit-macro-combine-ext-command ()
797 "Put an entire extended command on a single line."
798 (let ((cmdbeg (calc-edit-macro-command))
800 (type (calc-edit-macro-command-type))
803 (goto-char (line-beginning-position))
805 (setq curline
(calc-edit-macro-command))
807 (not (string-equal "RET" curline
))
808 (not (setq match
(string-match "<return>" curline
))))
809 (setq line
(concat line curline
))
811 (setq curline
(calc-edit-macro-command)))
814 (setq line
(concat line
(substring curline
0 match
))))
815 (setq line
(replace-regexp-in-string " " "" line
))
816 (insert cmdbeg
" " line
"\t\t\t")
817 (if (> (current-column) 24)
819 (insert ";; " type
"\n")
821 (insert "RET\t\t\t;; calc-enter\n"))))
823 (defun calc-edit-macro-combine-var-name ()
824 "Put an entire variable name on a single line."
825 (let ((line (calc-edit-macro-command))
828 (goto-char (line-beginning-position))
830 (if (member line
'("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
831 (insert line
"\t\t\t;; calc quick variable\n")
832 (setq curline
(calc-edit-macro-command))
834 (not (string-equal "RET" curline
))
835 (not (setq match
(string-match "<return>" curline
))))
836 (setq line
(concat line curline
))
838 (setq curline
(calc-edit-macro-command)))
841 (setq line
(concat line
(substring curline
0 match
))))
842 (setq line
(replace-regexp-in-string " " "" line
))
843 (insert line
"\t\t\t")
844 (if (> (current-column) 24)
846 (insert ";; calc variable\n")
848 (insert "RET\t\t\t;; calc-enter\n")))))
850 (defun calc-edit-macro-combine-digits ()
851 "Put an entire sequence of digits on a single line."
852 (let ((line (calc-edit-macro-command))
854 (goto-char (line-beginning-position))
856 (while (string-equal (calc-edit-macro-command-type) "calcDigit-start")
857 (setq line
(concat line
(calc-edit-macro-command)))
859 (insert line
"\t\t\t")
860 (if (> (current-column) 24)
862 (insert ";; calc digits\n")))
864 (defun calc-edit-format-macro-buffer ()
865 "Rewrite the Calc macro editing buffer."
866 (calc-edit-macro-adjust-buffer)
867 (goto-char calc-edit-top
)
868 (let ((type (calc-edit-macro-command-type)))
869 (while (not (string-equal type
""))
872 (string-equal type
"calc-algebraic-entry")
873 (string-equal type
"calc-auto-algebraic-entry"))
874 (calc-edit-macro-combine-alg-ent))
875 ((string-equal type
"calc-execute-extended-command")
876 (calc-edit-macro-combine-ext-command))
877 ((string-equal type
"calcDigit-start")
878 (calc-edit-macro-combine-digits))
880 (string-equal type
"calc-store")
881 (string-equal type
"calc-store-into")
882 (string-equal type
"calc-store-neg")
883 (string-equal type
"calc-store-plus")
884 (string-equal type
"calc-store-minus")
885 (string-equal type
"calc-store-div")
886 (string-equal type
"calc-store-times")
887 (string-equal type
"calc-store-power")
888 (string-equal type
"calc-store-concat")
889 (string-equal type
"calc-store-inv")
890 (string-equal type
"calc-store-dec")
891 (string-equal type
"calc-store-incr")
892 (string-equal type
"calc-store-exchange")
893 (string-equal type
"calc-unstore")
894 (string-equal type
"calc-recall")
895 (string-equal type
"calc-let")
896 (string-equal type
"calc-permanent-variable"))
898 (calc-edit-macro-combine-var-name))
900 (string-equal type
"calc-copy-variable")
901 (string-equal type
"calc-declare-variable"))
903 (calc-edit-macro-combine-var-name)
904 (calc-edit-macro-combine-var-name))
905 (t (forward-line 1)))
906 (setq type
(calc-edit-macro-command-type))))
907 (goto-char calc-edit-top
))
909 ;; Finish editing the macro
911 (defun calc-edit-macro-pre-finish-edit ()
912 (goto-char calc-edit-top
)
913 (while (re-search-forward "\\(^\\| \\)RET\\($\\|\t\\| \\)" nil t
)
914 (search-backward "RET")
916 (insert "<return>")))
918 (defvar calc-edit-top
)
919 (defun calc-edit-macro-finish-edit (cmdname key
)
920 "Finish editing a Calc macro.
921 Redefine the corresponding command."
923 (let ((cmd (intern cmdname
)))
924 (calc-edit-macro-pre-finish-edit)
925 (let* ((str (buffer-substring calc-edit-top
(point-max)))
926 (mac (edmacro-parse-keys str t
)))
927 (if (= (length mac
) 0)
932 (list 'calc-execute-kbd-macro
933 (vector (key-description mac
)
937 (defun calc-finish-formula-edit (func)
938 (let ((buf (current-buffer))
939 (str (buffer-substring calc-edit-top
(point-max)))
941 (body (calc-valid-formula-func func
)))
942 (set-buffer calc-original-buffer
)
943 (let ((val (math-read-expr str
)))
944 (if (eq (car-safe val
) 'error
)
947 (goto-char (+ start
(nth 1 val
)))
948 (error (nth 2 val
))))
950 (let ((calc-user-formula-alist (nth 1 (symbol-function func
))))
951 (calc-fix-user-formula val
)))
952 (put func
'calc-user-defn val
))))
954 (defun calc-valid-formula-func (func)
955 (let ((def (symbol-function func
)))
957 (eq (car def
) 'lambda
)
959 (setq def
(cdr (cdr def
)))
961 (not (eq (car (car def
)) 'math-normalize
)))
962 (setq def
(cdr def
)))
966 (defun calc-get-user-defn ()
969 (message "Get definition of command: z-")
970 (let* ((key (read-char))
971 (def (or (assq key
(calc-user-key-map))
972 (assq (upcase key
) (calc-user-key-map))
973 (assq (downcase key
) (calc-user-key-map))
974 (error "No command defined for that key")))
977 (setq cmd
(symbol-function cmd
)))
979 (message "Keyboard macro: %s" cmd
))
980 (t (let* ((func (calc-stack-command-p cmd
))
983 (get func
'calc-user-defn
))))
986 (and (calc-valid-formula-func func
)
987 (setq defn
(append '(calcFunc-lambda)
988 (mapcar 'math-build-var-name
989 (nth 1 (symbol-function
992 (calc-enter-result 0 "gdef" defn
))
993 (error "That command is not defined by a formula"))))))))
996 (defun calc-user-define-permanent ()
999 (message "Record in %s the command: z-" calc-settings-file
)
1000 (let* ((key (read-char))
1001 (def (or (assq key
(calc-user-key-map))
1002 (assq (upcase key
) (calc-user-key-map))
1003 (assq (downcase key
) (calc-user-key-map))
1009 (format "Record in %s the algebraic function: "
1011 (mapcar (lambda (x) (substring x
9))
1012 (all-completions "calcFunc-"
1016 (intern (concat "calcFunc-" x
))))
1020 (intern (completing-read
1021 (format "Record in %s the command: "
1023 obarray
'fboundp nil
"calc-"))))
1024 (error "No command defined for that key"))))
1025 (set-buffer (find-file-noselect (substitute-in-file-name
1026 calc-settings-file
)))
1027 (goto-char (point-max))
1028 (let* ((cmd (cdr def
))
1029 (fcmd (and cmd
(symbolp cmd
) (symbol-function cmd
)))
1035 (insert "\n;;; Definition stored by Calc on " (current-time-string)
1036 "\n(put 'calc-define '"
1037 (if (symbolp cmd
) (symbol-name cmd
) (format "key%d" key
))
1040 (eq (car-safe fcmd
) 'lambda
)
1041 (get cmd
'calc-user-defn
))
1043 (and (eq (car-safe (nth 3 fcmd
)) 'calc-execute-kbd-macro
)
1044 (vectorp (nth 1 (nth 3 fcmd
)))
1045 (progn (and (fboundp 'edit-kbd-macro
)
1046 (edit-kbd-macro nil
))
1047 (fboundp 'edmacro-parse-keys
))
1049 (aset (nth 1 (nth 3 fcmd
)) 1 nil
))
1050 (insert (setq str
(prin1-to-string
1051 (cons 'defun
(cons cmd
(cdr fcmd
)))))
1053 (or (and (string-match "\"" str
) (not q-ok
))
1054 (fill-region pt
(point)))
1055 (indent-rigidly pt
(point) 2)
1056 (delete-region pt
(1+ pt
))
1057 (insert " (put '" (symbol-name cmd
)
1058 " 'calc-user-defn '"
1059 (prin1-to-string (get cmd
'calc-user-defn
))
1061 (setq func
(calc-stack-command-p cmd
))
1062 (let ((ffunc (and func
(symbolp func
) (symbol-function func
)))
1065 (eq (car-safe ffunc
) 'lambda
)
1066 (get func
'calc-user-defn
)
1068 (insert (setq str
(prin1-to-string
1069 (cons 'defun
(cons func
1072 (or (and (string-match "\"" str
) (not q-ok
))
1073 (fill-region pt
(point)))
1074 (indent-rigidly pt
(point) 2)
1075 (delete-region pt
(1+ pt
))
1077 (insert "(put '" (symbol-name func
)
1078 " 'calc-user-defn '"
1079 (prin1-to-string (get func
'calc-user-defn
))
1081 (fill-region pt
(point))
1082 (indent-rigidly pt
(point) 2)
1083 (delete-region pt
(1+ pt
))))))
1085 (insert " (fset '" (prin1-to-string cmd
)
1086 " " (prin1-to-string fcmd
) ")\n")))
1087 (or func
(setq func
(and cmd
(symbolp cmd
) (fboundp cmd
) cmd
)))
1088 (if (get func
'math-compose-forms
)
1090 (insert "(put '" (symbol-name cmd
)
1091 " 'math-compose-forms '"
1092 (prin1-to-string (get func
'math-compose-forms
))
1094 (fill-region pt
(point))
1095 (indent-rigidly pt
(point) 2)
1096 (delete-region pt
(1+ pt
))))
1098 (insert " (define-key calc-mode-map "
1099 (prin1-to-string (concat "z" (char-to-string key
)))
1101 (prin1-to-string cmd
)
1106 (defun calc-stack-command-p (cmd)
1107 (if (and cmd
(symbolp cmd
))
1109 (calc-stack-command-p (symbol-function cmd
)))
1111 (eq (car cmd
) 'lambda
)
1112 (setq cmd
(or (assq 'calc-wrapper cmd
)
1113 (assq 'calc-slow-wrapper cmd
)))
1114 (setq cmd
(assq 'calc-enter-result cmd
))
1115 (memq (car (nth 3 cmd
)) '(cons list
))
1116 (eq (car (nth 1 (nth 3 cmd
))) 'quote
)
1117 (nth 1 (nth 1 (nth 3 cmd
))))))
1120 (defun calc-call-last-kbd-macro (arg)
1122 (and defining-kbd-macro
1123 (error "Can't execute anonymous macro while defining one"))
1125 (error "No kbd macro has been defined"))
1126 (calc-execute-kbd-macro last-kbd-macro arg
))
1128 (defun calc-execute-kbd-macro (mac arg
&rest prefix
)
1129 (if calc-keep-args-flag
1131 (if (and (vectorp mac
) (> (length mac
) 0) (stringp (aref mac
0)))
1132 (setq mac
(or (aref mac
1)
1133 (aset mac
1 (progn (and (fboundp 'edit-kbd-macro
)
1134 (edit-kbd-macro nil
))
1135 (edmacro-parse-keys (aref mac
0)))))))
1136 (if (< (prefix-numeric-value arg
) 0)
1137 (execute-kbd-macro mac
(- (prefix-numeric-value arg
)))
1138 (if calc-executing-macro
1139 (execute-kbd-macro mac arg
)
1141 (let ((old-stack-whole (copy-sequence calc-stack
))
1142 (old-stack-top calc-stack-top
)
1143 (old-buffer-size (buffer-size))
1144 (old-refresh-count calc-refresh-count
))
1146 (let ((calc-executing-macro mac
))
1147 (execute-kbd-macro mac arg
))
1148 (calc-select-buffer)
1149 (let ((new-stack (reverse calc-stack
))
1150 (old-stack (reverse old-stack-whole
)))
1151 (while (and new-stack old-stack
1152 (equal (car new-stack
) (car old-stack
)))
1153 (setq new-stack
(cdr new-stack
)
1154 old-stack
(cdr old-stack
)))
1155 (or (equal prefix
'(nil))
1156 (calc-record-list (if (> (length new-stack
) 1)
1157 (mapcar 'car new-stack
)
1159 (or (car prefix
) "kmac")))
1160 (calc-record-undo (list 'set
'saved-stack-top old-stack-top
))
1162 (calc-record-undo (list 'pop
1 (mapcar 'car old-stack
))))
1163 (let ((calc-stack old-stack-whole
)
1165 (calc-cursor-stack-index (length old-stack
)))
1166 (if (and (= old-buffer-size
(buffer-size))
1167 (= old-refresh-count calc-refresh-count
))
1168 (let ((buffer-read-only nil
))
1169 (delete-region (point) (point-max))
1171 (calc-record-undo (list 'push
1))
1172 (insert (math-format-stack-value (car new-stack
)) "\n")
1173 (setq new-stack
(cdr new-stack
)))
1174 (calc-renumber-stack))
1176 (calc-record-undo (list 'push
1))
1177 (setq new-stack
(cdr new-stack
)))
1179 (calc-record-undo (list 'set
'saved-stack-top
0)))))))))
1181 (defun calc-push-list-in-macro (vals m sels
)
1182 (let ((entry (list (car vals
) 1 (car sels
)))
1183 (mm (+ (or m
1) calc-stack-top
)))
1185 (setcdr (nthcdr (- mm
2) calc-stack
)
1186 (cons entry
(nthcdr (1- mm
) calc-stack
)))
1187 (setq calc-stack
(cons entry calc-stack
)))))
1189 (defun calc-pop-stack-in-macro (n mm
)
1191 (setcdr (nthcdr (- mm
2) calc-stack
)
1192 (nthcdr (+ n mm -
1) calc-stack
))
1193 (setq calc-stack
(nthcdr n calc-stack
))))
1196 (defun calc-kbd-if ()
1199 (let ((cond (calc-top-n 1)))
1201 (if (math-is-true cond
)
1202 (if defining-kbd-macro
1203 (message "If true.."))
1204 (if defining-kbd-macro
1205 (message "Condition is false; skipping to Z: or Z] ..."))
1206 (calc-kbd-skip-to-else-if t
)))))
1208 (defun calc-kbd-else-if ()
1212 (defun calc-kbd-skip-to-else-if (else-okay)
1216 (setq ch
(read-char))
1218 (error "Unterminated Z[ in keyboard macro"))
1221 (setq ch
(read-char))
1223 (setq count
(1+ count
)))
1225 (setq count
(1- count
)))
1231 (keyboard-quit))))))
1232 (and defining-kbd-macro
1235 (message "End-if...")))))
1237 (defun calc-kbd-end-if ()
1239 (if defining-kbd-macro
1240 (message "End-if...")))
1242 (defun calc-kbd-else ()
1244 (if defining-kbd-macro
1245 (message "Else; skipping to Z] ..."))
1246 (calc-kbd-skip-to-else-if nil
))
1249 (defun calc-kbd-repeat ()
1253 (setq count
(math-trunc (calc-top-n 1)))
1254 (or (Math-integerp count
)
1255 (error "Count must be an integer"))
1256 (if (Math-integer-negp count
)
1258 (or (integerp count
)
1259 (setq count
1000000))
1261 (calc-kbd-loop count
)))
1263 (defun calc-kbd-for (dir)
1267 (setq init
(calc-top-n 2)
1268 final
(calc-top-n 1))
1269 (or (and (math-anglep init
) (math-anglep final
))
1270 (error "Initial and final values must be real numbers"))
1272 (calc-kbd-loop nil init final
(and dir
(prefix-numeric-value dir
)))))
1274 (defun calc-kbd-loop (rpt-count &optional initial final dir
)
1276 (setq rpt-count
(if rpt-count
(prefix-numeric-value rpt-count
) 1000000))
1280 (open last-command-char
)
1283 (or executing-kbd-macro
1284 (message "Reading loop body..."))
1286 (setq ch
(read-char))
1288 (error "Unterminated Z%c in keyboard macro" open
))
1291 (setq ch
(read-char)
1292 body
(concat body
"Z" (char-to-string ch
)))
1293 (cond ((memq ch
'(?\
< ?\
( ?\
{))
1294 (setq count
(1+ count
)))
1295 ((memq ch
'(?\
> ?\
) ?\
}))
1296 (setq count
(1- count
)))
1299 (setq parts
(nconc parts
(list (concat (substring body
0 -
2)
1304 (setq body
(concat body
(char-to-string ch
)))))
1305 (if (/= ch
(cdr (assq open
'( (?\
< . ?\
>) (?\
( . ?\
)) (?\
{ . ?\
}) ))))
1306 (error "Mismatched Z%c and Z%c in keyboard macro" open ch
))
1307 (or executing-kbd-macro
1308 (message "Looping..."))
1309 (setq body
(concat (substring body
0 -
2) "Z]"))
1310 (and (not executing-kbd-macro
)
1311 (= rpt-count
1000000)
1315 (message "Warning: Infinite loop! Not executing")
1316 (setq rpt-count
0)))
1317 (or (not initial
) dir
1318 (setq dir
(math-compare final initial
)))
1320 (while (> rpt-count
0)
1323 (if (cond ((eq dir
0) (Math-equal final counter
))
1324 ((eq dir
1) (Math-lessp final counter
))
1325 ((eq dir -
1) (Math-lessp counter final
)))
1327 (calc-push counter
)))
1328 (while (and part
(> rpt-count
0))
1329 (execute-kbd-macro (car part
))
1330 (if (math-is-true (calc-top-n 1))
1332 (setq part
(cdr part
)))
1336 (execute-kbd-macro body
)
1338 (let ((step (calc-top-n 1)))
1340 (setq counter
(calcFunc-add counter step
)))
1341 (setq rpt-count
(1- rpt-count
))))))))
1342 (or executing-kbd-macro
1343 (message "Looping...done"))))
1345 (defun calc-kbd-end-repeat ()
1347 (error "Unbalanced Z> in keyboard macro"))
1349 (defun calc-kbd-end-for ()
1351 (error "Unbalanced Z) in keyboard macro"))
1353 (defun calc-kbd-end-loop ()
1355 (error "Unbalanced Z} in keyboard macro"))
1357 (defun calc-kbd-break ()
1360 (let ((cond (calc-top-n 1)))
1362 (if (math-is-true cond
)
1363 (error "Keyboard macro aborted")))))
1366 (defvar calc-kbd-push-level
0)
1368 ;; The variables var-q0 through var-q9 are the "quick" variables.
1380 (defun calc-kbd-push (arg)
1383 (let* ((defs (and arg
(> (prefix-numeric-value arg
) 0)))
1394 (calc-internal-prec (if defs
12 calc-internal-prec
))
1395 (calc-word-size (if defs
32 calc-word-size
))
1396 (calc-angle-mode (if defs
'deg calc-angle-mode
))
1397 (calc-simplify-mode (if defs nil calc-simplify-mode
))
1398 (calc-algebraic-mode (if arg nil calc-algebraic-mode
))
1399 (calc-incomplete-algebraic-mode (if arg nil
1400 calc-incomplete-algebraic-mode
))
1401 (calc-symbolic-mode (if defs nil calc-symbolic-mode
))
1402 (calc-matrix-mode (if defs nil calc-matrix-mode
))
1403 (calc-prefer-frac (if defs nil calc-prefer-frac
))
1404 (calc-complex-mode (if defs nil calc-complex-mode
))
1405 (calc-infinite-mode (if defs nil calc-infinite-mode
))
1409 (if (or executing-kbd-macro defining-kbd-macro
)
1411 (if defining-kbd-macro
1412 (message "Reading body..."))
1414 (setq ch
(read-char))
1416 (error "Unterminated Z` in keyboard macro"))
1419 (setq ch
(read-char)
1420 body
(concat body
"Z" (char-to-string ch
)))
1422 (setq count
(1+ count
)))
1424 (setq count
(1- count
)))
1427 (setq body
(concat body
(char-to-string ch
)))))
1428 (if defining-kbd-macro
1429 (message "Reading body...done"))
1430 (let ((calc-kbd-push-level 0))
1431 (execute-kbd-macro (substring body
0 -
2))))
1432 (let ((calc-kbd-push-level (1+ calc-kbd-push-level
)))
1433 (message "Saving modes; type Z' to restore")
1434 (recursive-edit))))))
1436 (defun calc-kbd-pop ()
1438 (if (> calc-kbd-push-level
0)
1440 (message "Mode settings restored")
1441 (exit-recursive-edit))
1442 (error "Unbalanced Z' in keyboard macro")))
1445 (defun calc-kbd-report (msg)
1446 (interactive "sMessage: ")
1448 (math-working msg
(calc-top-n 1))))
1450 (defun calc-kbd-query (msg)
1451 (interactive "sPrompt: ")
1453 (calc-alg-entry nil
(and (not (equal msg
"")) msg
))))
1455 ;;;; Logical operations.
1457 (defun calcFunc-eq (a b
&rest more
)
1459 (let* ((args (cons a
(cons b
(copy-sequence more
))))
1463 (while (and (cdr p
) (not (eq res
0)))
1465 (while (and (setq p2
(cdr p2
)) (not (eq res
0)))
1466 (setq res
(math-two-eq (car p
) (car p2
)))
1468 (setcdr p
(delq (car p2
) (cdr p
)))))
1473 (cons 'calcFunc-eq args
)
1475 (or (math-two-eq a b
)
1476 (if (and (or (math-looks-negp a
) (math-zerop a
))
1477 (or (math-looks-negp b
) (math-zerop b
)))
1478 (list 'calcFunc-eq
(math-neg a
) (math-neg b
))
1479 (list 'calcFunc-eq a b
)))))
1481 (defun calcFunc-neq (a b
&rest more
)
1483 (let* ((args (cons a
(cons b more
)))
1488 (while (and (cdr p
) (not (eq res
1)))
1490 (while (and (setq p2
(cdr p2
)) (not (eq res
1)))
1491 (setq res
(math-two-eq (car p
) (car p2
)))
1492 (or res
(setq all nil
)))
1498 (cons 'calcFunc-neq args
))))
1499 (or (cdr (assq (math-two-eq a b
) '((0 .
1) (1 .
0))))
1500 (if (and (or (math-looks-negp a
) (math-zerop a
))
1501 (or (math-looks-negp b
) (math-zerop b
)))
1502 (list 'calcFunc-neq
(math-neg a
) (math-neg b
))
1503 (list 'calcFunc-neq a b
)))))
1505 (defun math-two-eq (a b
)
1506 (if (eq (car-safe a
) 'vec
)
1507 (if (eq (car-safe b
) 'vec
)
1508 (if (= (length a
) (length b
))
1510 (while (and (setq a
(cdr a
) b
(cdr b
)) (not (eq res
0)))
1512 (setq res
(math-two-eq (car a
) (car b
)))
1513 (if (eq (math-two-eq (car a
) (car b
)) 0)
1517 (if (Math-objectp b
)
1520 (if (eq (car-safe b
) 'vec
)
1521 (if (Math-objectp a
)
1524 (let ((res (math-compare a b
)))
1527 (if (and (= res
2) (not (and (Math-scalarp a
) (Math-scalarp b
))))
1531 (defun calcFunc-lt (a b
)
1532 (let ((res (math-compare a b
)))
1536 (if (and (or (math-looks-negp a
) (math-zerop a
))
1537 (or (math-looks-negp b
) (math-zerop b
)))
1538 (list 'calcFunc-gt
(math-neg a
) (math-neg b
))
1539 (list 'calcFunc-lt a b
))
1542 (defun calcFunc-gt (a b
)
1543 (let ((res (math-compare a b
)))
1547 (if (and (or (math-looks-negp a
) (math-zerop a
))
1548 (or (math-looks-negp b
) (math-zerop b
)))
1549 (list 'calcFunc-lt
(math-neg a
) (math-neg b
))
1550 (list 'calcFunc-gt a b
))
1553 (defun calcFunc-leq (a b
)
1554 (let ((res (math-compare a b
)))
1558 (if (and (or (math-looks-negp a
) (math-zerop a
))
1559 (or (math-looks-negp b
) (math-zerop b
)))
1560 (list 'calcFunc-geq
(math-neg a
) (math-neg b
))
1561 (list 'calcFunc-leq a b
))
1564 (defun calcFunc-geq (a b
)
1565 (let ((res (math-compare a b
)))
1569 (if (and (or (math-looks-negp a
) (math-zerop a
))
1570 (or (math-looks-negp b
) (math-zerop b
)))
1571 (list 'calcFunc-leq
(math-neg a
) (math-neg b
))
1572 (list 'calcFunc-geq a b
))
1575 (defun calcFunc-rmeq (a)
1576 (if (math-vectorp a
)
1577 (math-map-vec 'calcFunc-rmeq a
)
1578 (if (assq (car-safe a
) calc-tweak-eqn-table
)
1579 (if (and (eq (car-safe (nth 2 a
)) 'var
)
1580 (math-objectp (nth 1 a
)))
1583 (if (eq (car-safe a
) 'calcFunc-assign
)
1585 (if (eq (car-safe a
) 'calcFunc-evalto
)
1587 (list 'calcFunc-rmeq a
))))))
1589 (defun calcFunc-land (a b
)
1590 (cond ((Math-zerop a
)
1598 (t (list 'calcFunc-land a b
))))
1600 (defun calcFunc-lor (a b
)
1601 (cond ((Math-zerop a
)
1609 (t (list 'calcFunc-lor a b
))))
1611 (defun calcFunc-lnot (a)
1614 (if (math-is-true a
)
1616 (let ((op (and (= (length a
) 3)
1617 (assq (car a
) calc-tweak-eqn-table
))))
1619 (cons (nth 2 op
) (cdr a
))
1620 (list 'calcFunc-lnot a
))))))
1622 (defun calcFunc-if (c e1 e2
)
1625 (if (and (math-is-true c
) (not (Math-vectorp c
)))
1627 (or (and (Math-vectorp c
)
1629 (let ((ee1 (if (Math-vectorp e1
)
1630 (if (= (length c
) (length e1
))
1632 (calc-record-why "*Dimension error" e1
))
1634 (ee2 (if (Math-vectorp e2
)
1635 (if (= (length c
) (length e2
))
1637 (calc-record-why "*Dimension error" e2
))
1640 (cons 'vec
(math-if-vector (cdr c
) ee1 ee2
)))))
1641 (list 'calcFunc-if c e1 e2
)))))
1643 (defun math-if-vector (c e1 e2
)
1645 (cons (if (Math-zerop (car c
)) (car e2
) (car e1
))
1646 (math-if-vector (cdr c
)
1648 (or (cdr e2
) e2
)))))
1650 (defun math-normalize-logical-op (a)
1651 (or (and (eq (car a
) 'calcFunc-if
)
1653 (let ((a1 (math-normalize (nth 1 a
))))
1655 (math-normalize (nth 3 a
))
1656 (if (Math-numberp a1
)
1657 (math-normalize (nth 2 a
))
1658 (if (and (Math-vectorp (nth 1 a
))
1659 (math-constp (nth 1 a
)))
1660 (calcFunc-if (nth 1 a
)
1661 (math-normalize (nth 2 a
))
1662 (math-normalize (nth 3 a
)))
1663 (let ((calc-simplify-mode 'none
))
1664 (list 'calcFunc-if a1
1665 (math-normalize (nth 2 a
))
1666 (math-normalize (nth 3 a
)))))))))
1669 (defun calcFunc-in (a b
)
1670 (or (and (eq (car-safe b
) 'vec
)
1672 (while (and (setq bb
(cdr bb
))
1673 (not (if (memq (car-safe (car bb
)) '(vec intv
))
1674 (eq (calcFunc-in a
(car bb
)) 1)
1675 (Math-equal a
(car bb
))))))
1676 (if bb
1 (and (math-constp a
) (math-constp bb
) 0))))
1677 (and (eq (car-safe b
) 'intv
)
1678 (let ((res (math-compare a
(nth 2 b
))) res2
)
1682 (or (/= (nth 1 b
) 2)
1683 (Math-lessp (nth 2 b
) (nth 3 b
))))
1684 (if (memq (nth 1 b
) '(2 3)) 1 0))
1685 ((= (setq res2
(math-compare a
(nth 3 b
))) 1)
1688 (or (/= (nth 1 b
) 1)
1689 (Math-lessp (nth 2 b
) (nth 3 b
))))
1690 (if (memq (nth 1 b
) '(1 3)) 1 0))
1696 (and (Math-equal a b
)
1698 (and (math-constp a
) (math-constp b
)
1700 (list 'calcFunc-in a b
)))
1702 (defun calcFunc-typeof (a)
1703 (cond ((Math-integerp a
) 1)
1704 ((eq (car a
) 'frac
) 2)
1705 ((eq (car a
) 'float
) 3)
1706 ((eq (car a
) 'hms
) 4)
1707 ((eq (car a
) 'cplx
) 5)
1708 ((eq (car a
) 'polar
) 6)
1709 ((eq (car a
) 'sdev
) 7)
1710 ((eq (car a
) 'intv
) 8)
1711 ((eq (car a
) 'mod
) 9)
1712 ((eq (car a
) 'date
) (if (Math-integerp (nth 1 a
)) 10 11))
1714 (if (memq (nth 2 a
) '(var-inf var-uinf var-nan
)) 12 100))
1715 ((eq (car a
) 'vec
) (if (math-matrixp a
) 102 101))
1716 (t (math-calcFunc-to-var (car a
)))))
1718 (defun calcFunc-integer (a)
1719 (if (Math-integerp a
)
1721 (if (Math-objvecp a
)
1723 (list 'calcFunc-integer a
))))
1725 (defun calcFunc-real (a)
1728 (if (Math-objvecp a
)
1730 (list 'calcFunc-real a
))))
1732 (defun calcFunc-constant (a)
1735 (if (Math-objvecp a
)
1737 (list 'calcFunc-constant a
))))
1739 (defun calcFunc-refers (a b
)
1740 (if (math-expr-contains a b
)
1742 (if (eq (car-safe a
) 'var
)
1743 (list 'calcFunc-refers a b
)
1746 (defun calcFunc-negative (a)
1747 (if (math-looks-negp a
)
1749 (if (or (math-zerop a
)
1752 (list 'calcFunc-negative a
))))
1754 (defun calcFunc-variable (a)
1755 (if (eq (car-safe a
) 'var
)
1757 (if (Math-objvecp a
)
1759 (list 'calcFunc-variable a
))))
1761 (defun calcFunc-nonvar (a)
1762 (if (eq (car-safe a
) 'var
)
1763 (list 'calcFunc-nonvar a
)
1766 (defun calcFunc-istrue (a)
1767 (if (math-is-true a
)
1773 ;;;; User-programmability.
1775 ;;; Compiling Lisp-like forms to use the math library.
1777 (defun math-do-defmath (func args body
)
1778 (require 'calc-macs
)
1779 (let* ((fname (intern (concat "calcFunc-" (symbol-name func
))))
1780 (doc (if (stringp (car body
)) (list (car body
))))
1781 (clargs (mapcar 'math-clean-arg args
))
1782 (body (math-define-function-body
1783 (if (stringp (car body
)) (cdr body
) body
)
1786 (if (and (consp (car body
))
1787 (eq (car (car body
)) 'interactive
))
1788 (let ((inter (car body
)))
1789 (setq body
(cdr body
))
1790 (if (or (> (length inter
) 2)
1791 (integerp (nth 1 inter
)))
1792 (let ((hasprefix nil
) (hasmulti nil
))
1793 (if (stringp (nth 1 inter
))
1795 (cond ((equal (nth 1 inter
) "p")
1797 ((equal (nth 1 inter
) "m")
1800 "Can't handle interactive code string \"%s\""
1802 (setq inter
(cdr inter
))))
1803 (if (not (integerp (nth 1 inter
)))
1805 "Expected an integer in interactive specification"))
1806 (append (list 'defun
1807 (intern (concat "calc-"
1808 (symbol-name func
)))
1809 (if (or hasprefix hasmulti
)
1813 (if (or hasprefix hasmulti
)
1814 '((interactive "P"))
1818 '(calc-slow-wrapper)
1825 (list 'prefix-numeric-value
1829 (list 'calc-enter-result
1830 (if hasmulti
'n
(nth 1 inter
))
1834 (list 'quote
(list fname
))
1835 (list 'calc-top-list-n
1844 'prefix-numeric-value
1848 (list 'calc-top-list-n
1851 (nth 1 inter
)))))))))))
1852 (append (list 'defun
1853 (intern (concat "calc-" (symbol-name func
)))
1858 (cons 'calc-wrapper body
))))))
1859 (append (list 'defun
fname clargs
)
1861 (math-do-arg-list-check args nil nil
)
1864 (defun math-clean-arg (arg)
1866 (math-clean-arg (nth 1 arg
))
1869 (defun math-do-arg-check (arg var is-opt is-rest
)
1871 (let ((chk (math-do-arg-check arg var nil nil
)))
1875 (setq chk
(list (cons 'progn chk
)))
1878 (let* ((rest (math-do-arg-check (nth 1 arg
) var is-opt is-rest
))
1880 (qqual (list 'quote qual
))
1881 (qual-name (symbol-name qual
))
1882 (chk (intern (concat "math-check-" qual-name
))))
1888 (list 'mapcar
(list 'quote chk
) var
))
1889 (list 'setq var
(list chk var
)))))
1890 (if (fboundp (setq chk
(intern (concat "math-" qual-name
))))
1899 (list 'math-reject-arg
1904 (list 'math-reject-arg var qqual
)))))
1905 (if (and (string-match "\\`not-\\(.*\\)\\'" qual-name
)
1906 (fboundp (setq chk
(intern
1908 (math-match-substring
1918 (list 'math-reject-arg
1923 (list 'math-reject-arg var qqual
)))))
1924 (error "Unknown qualifier `%s'" qual-name
))))))))
1926 (defun math-do-arg-list-check (args is-opt is-rest
)
1927 (cond ((null args
) nil
)
1929 (append (math-do-arg-check (car args
)
1930 (math-clean-arg (car args
))
1932 (math-do-arg-list-check (cdr args
) is-opt is-rest
)))
1933 ((eq (car args
) '&optional
)
1934 (math-do-arg-list-check (cdr args
) t nil
))
1935 ((eq (car args
) '&rest
)
1936 (math-do-arg-list-check (cdr args
) nil t
))
1937 (t (math-do-arg-list-check (cdr args
) is-opt is-rest
))))
1939 (defconst math-prim-funcs
1940 '( (~
= . math-nearly-equal
)
1942 (lsh . calcFunc-lsh
)
1943 (ash . calcFunc-ash
)
1944 (logand . calcFunc-and
)
1945 (logandc2 . calcFunc-diff
)
1946 (logior . calcFunc-or
)
1947 (logxor . calcFunc-xor
)
1948 (lognot . calcFunc-not
)
1949 (equal . equal
) ; need to leave these ones alone!
1958 (defconst math-prim-vars
1961 (&optional .
&optional
)
1965 (defun math-define-function-body (body env
)
1966 (let ((body (math-define-body body env
)))
1967 (if (math-body-refers-to body
'math-return
)
1968 (list (cons 'catch
(cons '(quote math-return
) body
)))
1971 ;; The variable math-exp-env is local to math-define-body, but is
1972 ;; used by math-define-exp, which is called (indirectly) by
1973 ;; by math-define-body.
1974 (defvar math-exp-env
)
1976 (defun math-define-body (body math-exp-env
)
1977 (math-define-list body
))
1979 (defun math-define-list (body &optional quote
)
1982 ((and (eq (car body
) ':)
1983 (stringp (nth 1 body
)))
1984 (cons (let* ((math-read-expr-quotes t
)
1985 (exp (math-read-plain-expr (nth 1 body
) t
)))
1986 (math-define-exp exp
))
1987 (math-define-list (cdr (cdr body
)))))
1989 (cons (cond ((consp (car body
))
1990 (math-define-list (cdr body
) t
))
1993 (math-define-list (cdr body
))))
1995 (cons (math-define-exp (car body
))
1996 (math-define-list (cdr body
))))))
1998 (defun math-define-exp (exp)
2000 (let ((func (car exp
)))
2001 (cond ((memq func
'(quote function
))
2002 (if (and (consp (nth 1 exp
))
2003 (eq (car (nth 1 exp
)) 'lambda
))
2005 (math-define-lambda (nth 1 exp
) math-exp-env
))
2007 ((memq func
'(let let
* for foreach
))
2008 (let ((head (nth 1 exp
))
2009 (body (cdr (cdr exp
))))
2010 (if (memq func
'(let let
*))
2012 (setq func
(cdr (assq func
'((for . math-for
)
2013 (foreach . math-foreach
)))))
2014 (if (not (listp (car head
)))
2015 (setq head
(list head
))))
2018 (cons (math-define-let head
)
2019 (math-define-body body
2021 (math-define-let-env head
)
2023 ((and (memq func
'(setq setf
))
2024 (math-complicated-lhs (cdr exp
)))
2025 (if (> (length exp
) 3)
2026 (cons 'progn
(math-define-setf-list (cdr exp
)))
2027 (math-define-setf (nth 1 exp
) (nth 2 exp
))))
2028 ((eq func
'condition-case
)
2031 (math-define-body (cdr (cdr exp
))
2036 (math-define-cond (cdr exp
))))
2037 ((and (consp func
) ; ('spam a b) == force use of plain spam
2038 (eq (car func
) 'quote
))
2039 (cons func
(math-define-list (cdr exp
))))
2041 (let ((args (math-define-list (cdr exp
)))
2042 (prim (assq func math-prim-funcs
)))
2044 (cons (cdr prim
) args
))
2046 (list 'eq
(car args
) '(quote float
)))
2048 (math-define-binop 'math-add
0
2049 (car args
) (cdr args
)))
2051 (if (= (length args
) 1)
2052 (cons 'math-neg args
)
2053 (math-define-binop 'math-sub
0
2054 (car args
) (cdr args
))))
2056 (math-define-binop 'math-mul
1
2057 (car args
) (cdr args
)))
2059 (math-define-binop 'math-div
1
2060 (car args
) (cdr args
)))
2062 (math-define-binop 'math-min
0
2063 (car args
) (cdr args
)))
2065 (math-define-binop 'math-max
0
2066 (car args
) (cdr args
)))
2068 (if (and (math-numberp (nth 1 args
))
2069 (math-zerop (nth 1 args
)))
2070 (list 'math-negp
(car args
))
2071 (cons 'math-lessp args
)))
2073 (if (and (math-numberp (nth 1 args
))
2074 (math-zerop (nth 1 args
)))
2075 (list 'math-posp
(car args
))
2076 (list 'math-lessp
(nth 1 args
) (nth 0 args
))))
2079 (if (and (math-numberp (nth 1 args
))
2080 (math-zerop (nth 1 args
)))
2081 (list 'math-posp
(car args
))
2083 (nth 1 args
) (nth 0 args
)))))
2086 (if (and (math-numberp (nth 1 args
))
2087 (math-zerop (nth 1 args
)))
2088 (list 'math-negp
(car args
))
2089 (cons 'math-lessp args
))))
2091 (if (and (math-numberp (nth 1 args
))
2092 (math-zerop (nth 1 args
)))
2093 (list 'math-zerop
(nth 0 args
))
2094 (if (and (integerp (nth 1 args
))
2095 (/= (%
(nth 1 args
) 10) 0))
2096 (cons 'math-equal-int args
)
2097 (cons 'math-equal args
))))
2100 (if (and (math-numberp (nth 1 args
))
2101 (math-zerop (nth 1 args
)))
2102 (list 'math-zerop
(nth 0 args
))
2103 (if (and (integerp (nth 1 args
))
2104 (/= (%
(nth 1 args
) 10) 0))
2105 (cons 'math-equal-int args
)
2106 (cons 'math-equal args
)))))
2108 (list 'math-add
(car args
) 1))
2110 (list 'math-add
(car args
) -
1))
2111 ((eq func
'not
) ; optimize (not (not x)) => x
2112 (if (eq (car-safe args
) func
)
2115 ((and (eq func
'elt
) (cdr (cdr args
)))
2116 (math-define-elt (car args
) (cdr args
)))
2119 (let* ((name (symbol-name func
))
2120 (cfunc (intern (concat "calcFunc-" name
)))
2121 (mfunc (intern (concat "math-" name
))))
2122 (cond ((fboundp cfunc
)
2127 (string-match "\\`calcFunc-.*" name
))
2130 (cons cfunc args
)))))))))
2131 (t (cons func
(math-define-list (cdr exp
))))))) ;;args
2133 (let ((prim (assq exp math-prim-vars
))
2134 (name (symbol-name exp
)))
2137 ((memq exp math-exp-env
)
2139 ((string-match "-" name
)
2142 (intern (concat "var-" name
))))))
2144 (if (or (<= exp -
1000000) (>= exp
1000000))
2145 (list 'quote
(math-normalize exp
))
2149 (defun math-define-cond (forms)
2151 (cons (math-define-list (car forms
))
2152 (math-define-cond (cdr forms
)))))
2154 (defun math-complicated-lhs (body)
2156 (or (not (symbolp (car body
)))
2157 (math-complicated-lhs (cdr (cdr body
))))))
2159 (defun math-define-setf-list (body)
2161 (cons (math-define-setf (nth 0 body
) (nth 1 body
))
2162 (math-define-setf-list (cdr (cdr body
))))))
2164 (defun math-define-setf (place value
)
2165 (setq place
(math-define-exp place
)
2166 value
(math-define-exp value
))
2167 (cond ((symbolp place
)
2168 (list 'setq place value
))
2169 ((eq (car-safe place
) 'nth
)
2170 (list 'setcar
(list 'nthcdr
(nth 1 place
) (nth 2 place
)) value
))
2171 ((eq (car-safe place
) 'elt
)
2172 (list 'setcar
(list 'nthcdr
(nth 2 place
) (nth 1 place
)) value
))
2173 ((eq (car-safe place
) 'car
)
2174 (list 'setcar
(nth 1 place
) value
))
2175 ((eq (car-safe place
) 'cdr
)
2176 (list 'setcdr
(nth 1 place
) value
))
2178 (error "Bad place form for setf: %s" place
))))
2180 (defun math-define-binop (op ident arg1 rest
)
2182 (math-define-binop op ident
2183 (list op arg1
(car rest
))
2187 (defun math-define-let (vlist)
2189 (cons (if (consp (car vlist
))
2190 (cons (car (car vlist
))
2191 (math-define-list (cdr (car vlist
))))
2193 (math-define-let (cdr vlist
)))))
2195 (defun math-define-let-env (vlist)
2197 (cons (if (consp (car vlist
))
2200 (math-define-let-env (cdr vlist
)))))
2202 (defun math-define-lambda (exp exp-env
)
2203 (nconc (list (nth 0 exp
) ; 'lambda
2204 (nth 1 exp
)) ; arg list
2205 (math-define-function-body (cdr (cdr exp
))
2206 (append (nth 1 exp
) exp-env
))))
2208 (defun math-define-elt (seq idx
)
2210 (math-define-elt (list 'elt seq
(car idx
)) (cdr idx
))
2215 ;;; Useful programming macros.
2217 (defmacro math-while
(head &rest body
)
2218 (let ((body (cons 'while
(cons head body
))))
2219 (if (math-body-refers-to body
'math-break
)
2220 (cons 'catch
(cons '(quote math-break
) (list body
)))
2222 ;; (put 'math-while 'lisp-indent-hook 1)
2224 (defmacro math-for
(head &rest body
)
2225 (let ((body (if head
2226 (math-handle-for head body
)
2227 (cons 'while
(cons t body
)))))
2228 (if (math-body-refers-to body
'math-break
)
2229 (cons 'catch
(cons '(quote math-break
) (list body
)))
2231 ;; (put 'math-for 'lisp-indent-hook 1)
2233 (defun math-handle-for (head body
)
2234 (let* ((var (nth 0 (car head
)))
2235 (init (nth 1 (car head
)))
2236 (limit (nth 2 (car head
)))
2237 (step (or (nth 3 (car head
)) 1))
2238 (body (if (cdr head
)
2239 (list (math-handle-for (cdr head
) body
))
2241 (all-ints (and (integerp init
) (integerp limit
) (integerp step
)))
2242 (const-limit (or (integerp limit
)
2243 (and (eq (car-safe limit
) 'quote
)
2244 (math-realp (nth 1 limit
)))))
2245 (const-step (or (integerp step
)
2246 (and (eq (car-safe step
) 'quote
)
2247 (math-realp (nth 1 step
)))))
2248 (save-limit (if const-limit limit
(make-symbol "<limit>")))
2249 (save-step (if const-step step
(make-symbol "<step>"))))
2251 (cons (append (if const-limit nil
(list (list save-limit limit
)))
2252 (if const-step nil
(list (list save-step step
)))
2253 (list (list var init
)))
2258 (list '<= var save-limit
)
2259 (list '>= var save-limit
))
2262 (if (or (math-posp step
)
2287 save-step
)))))))))))
2289 (defmacro math-foreach
(head &rest body
)
2290 (let ((body (math-handle-foreach head body
)))
2291 (if (math-body-refers-to body
'math-break
)
2292 (cons 'catch
(cons '(quote math-break
) (list body
)))
2294 ;; (put 'math-foreach 'lisp-indent-hook 1)
2296 (defun math-handle-foreach (head body
)
2297 (let ((var (nth 0 (car head
)))
2298 (data (nth 1 (car head
)))
2299 (body (if (cdr head
)
2300 (list (math-handle-foreach (cdr head
) body
))
2303 (cons (list (list var data
))
2310 (list 'cdr var
)))))))))))
2313 (defun math-body-refers-to (body thing
)
2314 (or (equal body thing
)
2316 (or (math-body-refers-to (car body
) thing
)
2317 (math-body-refers-to (cdr body
) thing
)))))
2319 (defun math-break (&optional value
)
2320 (throw 'math-break value
))
2322 (defun math-return (&optional value
)
2323 (throw 'math-return value
))
2329 (defun math-composite-inequalities (x op
)
2330 (if (memq (nth 1 op
) '(calcFunc-eq calcFunc-neq
))
2331 (if (eq (car x
) (nth 1 op
))
2332 (append x
(list (math-read-expr-level (nth 3 op
))))
2333 (throw 'syntax
"Syntax error"))
2336 (if (memq (nth 1 op
) '(calcFunc-lt calcFunc-leq
))
2337 (if (memq (car x
) '(calcFunc-lt calcFunc-leq
))
2339 (+ (if (eq (car x
) 'calcFunc-leq
) 2 0)
2340 (if (eq (nth 1 op
) 'calcFunc-leq
) 1 0))
2341 (nth 1 x
) (math-read-expr-level (nth 3 op
)))
2342 (throw 'syntax
"Syntax error"))
2343 (if (memq (car x
) '(calcFunc-gt calcFunc-geq
))
2345 (+ (if (eq (nth 1 op
) 'calcFunc-geq
) 2 0)
2346 (if (eq (car x
) 'calcFunc-geq
) 1 0))
2347 (math-read-expr-level (nth 3 op
)) (nth 1 x
))
2348 (throw 'syntax
"Syntax error"))))))
2350 (provide 'calc-prog
)
2352 ;;; arch-tag: 4c5a183b-c9e5-4632-bb3f-e41a764518b0
2353 ;;; calc-prog.el ends here