1 ;;; calc-prog.el --- user programmability functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2005 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 ((eq lang
'latex
) "LaTeX")
481 (t (capitalize (symbol-name lang
))))))
482 (calc-write-parse-table (cdr (assq lang calc-user-parse-tables
))
484 (calc-show-edit-buffer))
486 (defvar calc-original-buffer
)
488 (defun calc-finish-user-syntax-edit (lang)
489 (let ((tab (calc-read-parse-table calc-original-buffer lang
))
490 (entry (assq lang calc-user-parse-tables
)))
493 (car (setq calc-user-parse-tables
494 (cons (list lang
) calc-user-parse-tables
))))
497 (setq calc-user-parse-tables
498 (delq entry calc-user-parse-tables
)))))
499 (switch-to-buffer calc-original-buffer
))
501 ;; The variable calc-lang is local to calc-write-parse-table, but is
502 ;; used by calc-write-parse-table-part which is called by
503 ;; calc-write-parse-table. The variable is also local to
504 ;; calc-read-parse-table, but is used by calc-fix-token-name which
505 ;; is called (indirectly) by calc-read-parse-table.
508 (defun calc-write-parse-table (tab calc-lang
)
511 (calc-write-parse-table-part (car (car p
)))
513 (let ((math-format-hash-args t
))
514 (math-format-flat-expr (cdr (car p
)) 0))
518 (defun calc-write-parse-table-part (p)
520 (cond ((stringp (car p
))
522 (if (and (string-match "\\`\\\\dots\\>" s
)
523 (not (memq calc-lang
'(tex latex
))))
524 (setq s
(concat ".." (substring s
5))))
525 (if (or (and (string-match
526 "[a-zA-Z0-9\"{}]\\|\\`:=\\'\\|\\`#\\|\\`%%" s
)
527 (string-match "[^a-zA-Z0-9\\]" s
))
528 (and (assoc s
'((")") ("]") (">")))
530 (insert (prin1-to-string s
) " ")
535 (insert "/" (int-to-string (car p
))))
537 ((and (eq (car (car p
)) '\?) (equal (car (nth 2 (car p
))) "$$"))
538 (insert (car (nth 1 (car p
))) " "))
541 (calc-write-parse-table-part (nth 1 (car p
)))
542 (insert "}" (symbol-name (car (car p
))))
544 (calc-write-parse-table-part (list (car (nth 2 (car p
)))))
548 (defun calc-read-parse-table (calc-buf calc-lang
)
551 (skip-chars-forward "\n\t ")
553 (if (looking-at "%%")
556 (p (calc-read-parse-table-part ":=[\n\t ]+" ":=")))
557 (or (stringp (car p
))
558 (and (integerp (car p
))
562 (error "Malformed syntax rule")))
565 (let* ((str (buffer-substring pos
(point)))
567 (set-buffer calc-buf
)
568 (let ((calc-user-parse-tables nil
)
570 (math-expr-opers math-standard-opers
)
571 (calc-hashes-used 0))
573 (if (string-match ",[ \t]*\\'" str
)
574 (substring str
0 (match-beginning 0))
576 (if (eq (car-safe exp
) 'error
)
578 (goto-char (+ pos
(nth 1 exp
)))
579 (error (nth 2 exp
))))
580 (setq tab
(nconc tab
(list (cons p exp
)))))))))
583 (defun calc-fix-token-name (name &optional unquoted
)
584 (cond ((string-match "\\`\\.\\." name
)
585 (concat "\\dots" (substring name
2)))
586 ((and (equal name
"{") (memq calc-lang
'(tex latex eqn
)))
588 ((and (equal name
"}") (memq calc-lang
'(tex latex eqn
)))
590 ((and (equal name
"&") (memq calc-lang
'(tex latex
)))
593 (search-backward "#")
594 (error "Token '#' is reserved"))
595 ((and unquoted
(string-match "#" name
))
596 (error "Tokens containing '#' must be quoted"))
597 ((not (string-match "[^ ]" name
))
598 (search-backward "\"" nil t
)
599 (error "Blank tokens are not allowed"))
602 (defun calc-read-parse-table-part (term eterm
)
606 (skip-chars-forward "\n\t ")
607 (if (eobp) (error "Expected '%s'" eterm
))
608 (not (looking-at term
)))
609 (cond ((looking-at "%%")
611 ((looking-at "{[\n\t ]")
613 (let ((p (calc-read-parse-table-part "}" "}")))
614 (or (looking-at "[+*?]")
615 (error "Expected '+', '*', or '?'"))
616 (let ((sym (intern (buffer-substring (point) (1+ (point))))))
618 (looking-at "[^\n\t ]*")
619 (let ((sep (buffer-substring (point) (match-end 0))))
620 (goto-char (match-end 0))
621 (and (eq sym
'\?) (> (length sep
) 0)
622 (not (equal sep
"$")) (not (equal sep
"."))
623 (error "Separator not allowed with { ... }?"))
624 (if (string-match "\\`\"" sep
)
625 (setq sep
(read-from-string sep
)))
626 (setq sep
(calc-fix-token-name sep
))
627 (setq part
(nconc part
629 (and (> (length sep
) 0)
630 (cons sep p
))))))))))
632 (error "Too many }'s"))
634 (setq quoted
(calc-fix-token-name (read (current-buffer)))
635 part
(nconc part
(list quoted
))))
636 ((looking-at "#\\(\\(/[0-9]+\\)?\\)[\n\t ]")
637 (setq part
(nconc part
(list (if (= (match-beginning 1)
642 (1+ (match-beginning 1))
644 (goto-char (match-end 0)))
645 ((looking-at ":=[\n\t ]")
646 (error "Misplaced ':='"))
648 (looking-at "[^\n\t ]*")
649 (let ((end (match-end 0)))
650 (setq part
(nconc part
(list (calc-fix-token-name
654 (goto-char (match-end 0))
655 (let ((len (length part
)))
656 (while (and (> len
1)
657 (let ((last (nthcdr (setq len
(1- len
)) part
)))
658 (and (assoc (car last
) '((")") ("]") (">")))
659 (not (eq (car last
) quoted
))
661 (list '\? (list (car last
)) '("$$"))))))))
664 (defun calc-user-define-invocation ()
667 (error "No keyboard macro defined"))
668 (setq calc-invocation-macro last-kbd-macro
)
669 (message "Use `M-# Z' to invoke this macro"))
671 (defun calc-user-define-edit ()
672 (interactive) ; but no calc-wrapper!
673 (message "Edit definition of command: z-")
676 (def (or (assq key
(calc-user-key-map))
677 (assq (upcase key
) (calc-user-key-map))
678 (assq (downcase key
) (calc-user-key-map))
679 (error "No command defined for that key")))
682 (setq cmdname
(symbol-name cmd
))
683 (setq cmd
(symbol-function cmd
)))
684 (cond ((or (stringp cmd
)
686 (eq (car-safe (nth 3 cmd
)) 'calc-execute-kbd-macro
)))
687 (let* ((mac (elt (nth 1 (nth 3 cmd
)) 1))
688 (str (edmacro-format-keys mac t
))
689 (kys (nth 3 (nth 3 cmd
))))
691 (list 'calc-edit-macro-finish-edit cmdname kys
)
693 "Editing keyboard macro (%s, bound to %s).\n"
694 "Original keys: %s \n")
695 cmdname kys
(elt (nth 1 (nth 3 cmd
)) 0)))
697 (calc-edit-format-macro-buffer)
698 (calc-show-edit-buffer)))
699 (t (let* ((func (calc-stack-command-p cmd
))
702 (get func
'calc-user-defn
)))
703 (kys (concat "z" (char-to-string (car def
))))
704 (intcmd (symbol-name (cdr def
)))
705 (algcmd (if func
(substring (symbol-name func
) 9) "")))
706 (if (and defn
(calc-valid-formula-func func
))
707 (let ((niceexpr (math-format-nice-expr defn
(frame-width))))
710 (list 'calc-finish-formula-edit
(list 'quote func
))
713 "Editing formula (%s, %s, bound to %s).\n"
714 "Original formula: %s\n")
715 intcmd algcmd kys niceexpr
))
716 (insert (math-showing-full-precision
719 (calc-show-edit-buffer))
720 (error "That command's definition cannot be edited")))))))
722 ;; Formatting the macro buffer
724 (defvar calc-edit-top
)
726 (defun calc-edit-macro-repeats ()
727 (goto-char calc-edit-top
)
729 (re-search-forward "^\\([0-9]+\\)\\*" nil t
)
730 (let ((num (string-to-number (match-string 1)))
731 (line (buffer-substring (point) (line-end-position))))
732 (goto-char (line-beginning-position))
736 (setq num
(1- num
))))))
738 (defun calc-edit-macro-adjust-buffer ()
739 (calc-edit-macro-repeats)
740 (goto-char calc-edit-top
)
741 (while (re-search-forward "^RET$" nil t
)
743 (goto-char calc-edit-top
)
744 (while (and (re-search-forward "^$" nil t
)
745 (not (= (point) (point-max))))
748 (defun calc-edit-macro-command ()
749 "Return the command on the current line in a Calc macro editing buffer."
750 (let ((beg (line-beginning-position))
752 (if (search-forward ";;" (line-end-position) 1)
754 (skip-chars-backward " \t")
756 (buffer-substring beg end
)))
758 (defun calc-edit-macro-command-type ()
759 "Return the type of command on the current line in a Calc macro editing buffer."
760 (let ((beg (save-excursion
761 (if (search-forward ";;" (line-end-position) t
)
763 (skip-chars-forward " \t")
766 (goto-char (line-end-position))
767 (skip-chars-backward " \t")
770 (buffer-substring beg end
)
773 (defun calc-edit-macro-combine-alg-ent ()
774 "Put an entire algebraic entry on a single line."
775 (let ((line (calc-edit-macro-command))
776 (type (calc-edit-macro-command-type))
779 (goto-char (line-beginning-position))
781 (setq curline
(calc-edit-macro-command))
783 (not (string-equal "RET" curline
))
784 (not (setq match
(string-match "<return>" curline
))))
785 (setq line
(concat line curline
))
787 (setq curline
(calc-edit-macro-command)))
790 (setq line
(concat line
(substring curline
0 match
))))
791 (setq line
(replace-regexp-in-string "SPC" " SPC "
792 (replace-regexp-in-string " " "" line
)))
793 (insert line
"\t\t\t")
794 (if (> (current-column) 24)
796 (insert ";; " type
"\n")
798 (insert "RET\t\t\t;; calc-enter\n"))))
800 (defun calc-edit-macro-combine-ext-command ()
801 "Put an entire extended command on a single line."
802 (let ((cmdbeg (calc-edit-macro-command))
804 (type (calc-edit-macro-command-type))
807 (goto-char (line-beginning-position))
809 (setq curline
(calc-edit-macro-command))
811 (not (string-equal "RET" curline
))
812 (not (setq match
(string-match "<return>" curline
))))
813 (setq line
(concat line curline
))
815 (setq curline
(calc-edit-macro-command)))
818 (setq line
(concat line
(substring curline
0 match
))))
819 (setq line
(replace-regexp-in-string " " "" line
))
820 (insert cmdbeg
" " line
"\t\t\t")
821 (if (> (current-column) 24)
823 (insert ";; " type
"\n")
825 (insert "RET\t\t\t;; calc-enter\n"))))
827 (defun calc-edit-macro-combine-var-name ()
828 "Put an entire variable name on a single line."
829 (let ((line (calc-edit-macro-command))
832 (goto-char (line-beginning-position))
834 (if (member line
'("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
835 (insert line
"\t\t\t;; calc quick variable\n")
836 (setq curline
(calc-edit-macro-command))
838 (not (string-equal "RET" curline
))
839 (not (setq match
(string-match "<return>" curline
))))
840 (setq line
(concat line curline
))
842 (setq curline
(calc-edit-macro-command)))
845 (setq line
(concat line
(substring curline
0 match
))))
846 (setq line
(replace-regexp-in-string " " "" line
))
847 (insert line
"\t\t\t")
848 (if (> (current-column) 24)
850 (insert ";; calc variable\n")
852 (insert "RET\t\t\t;; calc-enter\n")))))
854 (defun calc-edit-macro-combine-digits ()
855 "Put an entire sequence of digits on a single line."
856 (let ((line (calc-edit-macro-command))
858 (goto-char (line-beginning-position))
860 (while (string-equal (calc-edit-macro-command-type) "calcDigit-start")
861 (setq line
(concat line
(calc-edit-macro-command)))
863 (insert line
"\t\t\t")
864 (if (> (current-column) 24)
866 (insert ";; calc digits\n")))
868 (defun calc-edit-format-macro-buffer ()
869 "Rewrite the Calc macro editing buffer."
870 (calc-edit-macro-adjust-buffer)
871 (goto-char calc-edit-top
)
872 (let ((type (calc-edit-macro-command-type)))
873 (while (not (string-equal type
""))
876 (string-equal type
"calc-algebraic-entry")
877 (string-equal type
"calc-auto-algebraic-entry"))
878 (calc-edit-macro-combine-alg-ent))
879 ((string-equal type
"calc-execute-extended-command")
880 (calc-edit-macro-combine-ext-command))
881 ((string-equal type
"calcDigit-start")
882 (calc-edit-macro-combine-digits))
884 (string-equal type
"calc-store")
885 (string-equal type
"calc-store-into")
886 (string-equal type
"calc-store-neg")
887 (string-equal type
"calc-store-plus")
888 (string-equal type
"calc-store-minus")
889 (string-equal type
"calc-store-div")
890 (string-equal type
"calc-store-times")
891 (string-equal type
"calc-store-power")
892 (string-equal type
"calc-store-concat")
893 (string-equal type
"calc-store-inv")
894 (string-equal type
"calc-store-dec")
895 (string-equal type
"calc-store-incr")
896 (string-equal type
"calc-store-exchange")
897 (string-equal type
"calc-unstore")
898 (string-equal type
"calc-recall")
899 (string-equal type
"calc-let")
900 (string-equal type
"calc-permanent-variable"))
902 (calc-edit-macro-combine-var-name))
904 (string-equal type
"calc-copy-variable")
905 (string-equal type
"calc-copy-special-constant")
906 (string-equal type
"calc-declare-variable"))
908 (calc-edit-macro-combine-var-name)
909 (calc-edit-macro-combine-var-name))
910 (t (forward-line 1)))
911 (setq type
(calc-edit-macro-command-type))))
912 (goto-char calc-edit-top
))
914 ;; Finish editing the macro
916 (defun calc-edit-macro-pre-finish-edit ()
917 (goto-char calc-edit-top
)
918 (while (re-search-forward "\\(^\\| \\)RET\\($\\|\t\\| \\)" nil t
)
919 (search-backward "RET")
921 (insert "<return>")))
923 (defun calc-edit-macro-finish-edit (cmdname key
)
924 "Finish editing a Calc macro.
925 Redefine the corresponding command."
927 (let ((cmd (intern cmdname
)))
928 (calc-edit-macro-pre-finish-edit)
929 (let* ((str (buffer-substring calc-edit-top
(point-max)))
930 (mac (edmacro-parse-keys str t
)))
931 (if (= (length mac
) 0)
936 (list 'calc-execute-kbd-macro
937 (vector (key-description mac
)
941 (defun calc-finish-formula-edit (func)
942 (let ((buf (current-buffer))
943 (str (buffer-substring calc-edit-top
(point-max)))
945 (body (calc-valid-formula-func func
)))
946 (set-buffer calc-original-buffer
)
947 (let ((val (math-read-expr str
)))
948 (if (eq (car-safe val
) 'error
)
951 (goto-char (+ start
(nth 1 val
)))
952 (error (nth 2 val
))))
954 (let ((calc-user-formula-alist (nth 1 (symbol-function func
))))
955 (calc-fix-user-formula val
)))
956 (put func
'calc-user-defn val
))))
958 (defun calc-valid-formula-func (func)
959 (let ((def (symbol-function func
)))
961 (eq (car def
) 'lambda
)
963 (setq def
(cdr (cdr def
)))
965 (not (eq (car (car def
)) 'math-normalize
)))
966 (setq def
(cdr def
)))
970 (defun calc-get-user-defn ()
973 (message "Get definition of command: z-")
974 (let* ((key (read-char))
975 (def (or (assq key
(calc-user-key-map))
976 (assq (upcase key
) (calc-user-key-map))
977 (assq (downcase key
) (calc-user-key-map))
978 (error "No command defined for that key")))
981 (setq cmd
(symbol-function cmd
)))
983 (message "Keyboard macro: %s" cmd
))
984 (t (let* ((func (calc-stack-command-p cmd
))
987 (get func
'calc-user-defn
))))
990 (and (calc-valid-formula-func func
)
991 (setq defn
(append '(calcFunc-lambda)
992 (mapcar 'math-build-var-name
993 (nth 1 (symbol-function
996 (calc-enter-result 0 "gdef" defn
))
997 (error "That command is not defined by a formula"))))))))
1000 (defun calc-user-define-permanent ()
1003 (message "Record in %s the command: z-" calc-settings-file
)
1004 (let* ((key (read-char))
1005 (def (or (assq key
(calc-user-key-map))
1006 (assq (upcase key
) (calc-user-key-map))
1007 (assq (downcase key
) (calc-user-key-map))
1013 (format "Record in %s the algebraic function: "
1015 (mapcar (lambda (x) (substring x
9))
1016 (all-completions "calcFunc-"
1020 (intern (concat "calcFunc-" x
))))
1024 (intern (completing-read
1025 (format "Record in %s the command: "
1027 obarray
'fboundp nil
"calc-"))))
1028 (error "No command defined for that key"))))
1029 (set-buffer (find-file-noselect (substitute-in-file-name
1030 calc-settings-file
)))
1031 (goto-char (point-max))
1032 (let* ((cmd (cdr def
))
1033 (fcmd (and cmd
(symbolp cmd
) (symbol-function cmd
)))
1039 (insert "\n;;; Definition stored by Calc on " (current-time-string)
1040 "\n(put 'calc-define '"
1041 (if (symbolp cmd
) (symbol-name cmd
) (format "key%d" key
))
1044 (eq (car-safe fcmd
) 'lambda
)
1045 (get cmd
'calc-user-defn
))
1047 (and (eq (car-safe (nth 3 fcmd
)) 'calc-execute-kbd-macro
)
1048 (vectorp (nth 1 (nth 3 fcmd
)))
1049 (progn (and (fboundp 'edit-kbd-macro
)
1050 (edit-kbd-macro nil
))
1051 (fboundp 'edmacro-parse-keys
))
1053 (aset (nth 1 (nth 3 fcmd
)) 1 nil
))
1054 (insert (setq str
(prin1-to-string
1055 (cons 'defun
(cons cmd
(cdr fcmd
)))))
1057 (or (and (string-match "\"" str
) (not q-ok
))
1058 (fill-region pt
(point)))
1059 (indent-rigidly pt
(point) 2)
1060 (delete-region pt
(1+ pt
))
1061 (insert " (put '" (symbol-name cmd
)
1062 " 'calc-user-defn '"
1063 (prin1-to-string (get cmd
'calc-user-defn
))
1065 (setq func
(calc-stack-command-p cmd
))
1066 (let ((ffunc (and func
(symbolp func
) (symbol-function func
)))
1069 (eq (car-safe ffunc
) 'lambda
)
1070 (get func
'calc-user-defn
)
1072 (insert (setq str
(prin1-to-string
1073 (cons 'defun
(cons func
1076 (or (and (string-match "\"" str
) (not q-ok
))
1077 (fill-region pt
(point)))
1078 (indent-rigidly pt
(point) 2)
1079 (delete-region pt
(1+ pt
))
1081 (insert "(put '" (symbol-name func
)
1082 " 'calc-user-defn '"
1083 (prin1-to-string (get func
'calc-user-defn
))
1085 (fill-region pt
(point))
1086 (indent-rigidly pt
(point) 2)
1087 (delete-region pt
(1+ pt
))))))
1089 (insert " (fset '" (prin1-to-string cmd
)
1090 " " (prin1-to-string fcmd
) ")\n")))
1091 (or func
(setq func
(and cmd
(symbolp cmd
) (fboundp cmd
) cmd
)))
1092 (if (get func
'math-compose-forms
)
1094 (insert "(put '" (symbol-name cmd
)
1095 " 'math-compose-forms '"
1096 (prin1-to-string (get func
'math-compose-forms
))
1098 (fill-region pt
(point))
1099 (indent-rigidly pt
(point) 2)
1100 (delete-region pt
(1+ pt
))))
1102 (insert " (define-key calc-mode-map "
1103 (prin1-to-string (concat "z" (char-to-string key
)))
1105 (prin1-to-string cmd
)
1110 (defun calc-stack-command-p (cmd)
1111 (if (and cmd
(symbolp cmd
))
1113 (calc-stack-command-p (symbol-function cmd
)))
1115 (eq (car cmd
) 'lambda
)
1116 (setq cmd
(or (assq 'calc-wrapper cmd
)
1117 (assq 'calc-slow-wrapper cmd
)))
1118 (setq cmd
(assq 'calc-enter-result cmd
))
1119 (memq (car (nth 3 cmd
)) '(cons list
))
1120 (eq (car (nth 1 (nth 3 cmd
))) 'quote
)
1121 (nth 1 (nth 1 (nth 3 cmd
))))))
1124 (defun calc-call-last-kbd-macro (arg)
1126 (and defining-kbd-macro
1127 (error "Can't execute anonymous macro while defining one"))
1129 (error "No kbd macro has been defined"))
1130 (calc-execute-kbd-macro last-kbd-macro arg
))
1132 (defun calc-execute-kbd-macro (mac arg
&rest prefix
)
1133 (if calc-keep-args-flag
1135 (if (and (vectorp mac
) (> (length mac
) 0) (stringp (aref mac
0)))
1136 (setq mac
(or (aref mac
1)
1137 (aset mac
1 (progn (and (fboundp 'edit-kbd-macro
)
1138 (edit-kbd-macro nil
))
1139 (edmacro-parse-keys (aref mac
0)))))))
1140 (if (< (prefix-numeric-value arg
) 0)
1141 (execute-kbd-macro mac
(- (prefix-numeric-value arg
)))
1142 (if calc-executing-macro
1143 (execute-kbd-macro mac arg
)
1145 (let ((old-stack-whole (copy-sequence calc-stack
))
1146 (old-stack-top calc-stack-top
)
1147 (old-buffer-size (buffer-size))
1148 (old-refresh-count calc-refresh-count
))
1150 (let ((calc-executing-macro mac
))
1151 (execute-kbd-macro mac arg
))
1152 (calc-select-buffer)
1153 (let ((new-stack (reverse calc-stack
))
1154 (old-stack (reverse old-stack-whole
)))
1155 (while (and new-stack old-stack
1156 (equal (car new-stack
) (car old-stack
)))
1157 (setq new-stack
(cdr new-stack
)
1158 old-stack
(cdr old-stack
)))
1159 (or (equal prefix
'(nil))
1160 (calc-record-list (if (> (length new-stack
) 1)
1161 (mapcar 'car new-stack
)
1163 (or (car prefix
) "kmac")))
1164 (calc-record-undo (list 'set
'saved-stack-top old-stack-top
))
1166 (calc-record-undo (list 'pop
1 (mapcar 'car old-stack
))))
1167 (let ((calc-stack old-stack-whole
)
1169 (calc-cursor-stack-index (length old-stack
)))
1170 (if (and (= old-buffer-size
(buffer-size))
1171 (= old-refresh-count calc-refresh-count
))
1172 (let ((buffer-read-only nil
))
1173 (delete-region (point) (point-max))
1175 (calc-record-undo (list 'push
1))
1176 (insert (math-format-stack-value (car new-stack
)) "\n")
1177 (setq new-stack
(cdr new-stack
)))
1178 (calc-renumber-stack))
1180 (calc-record-undo (list 'push
1))
1181 (setq new-stack
(cdr new-stack
)))
1183 (calc-record-undo (list 'set
'saved-stack-top
0)))))))))
1185 (defun calc-push-list-in-macro (vals m sels
)
1186 (let ((entry (list (car vals
) 1 (car sels
)))
1187 (mm (+ (or m
1) calc-stack-top
)))
1189 (setcdr (nthcdr (- mm
2) calc-stack
)
1190 (cons entry
(nthcdr (1- mm
) calc-stack
)))
1191 (setq calc-stack
(cons entry calc-stack
)))))
1193 (defun calc-pop-stack-in-macro (n mm
)
1195 (setcdr (nthcdr (- mm
2) calc-stack
)
1196 (nthcdr (+ n mm -
1) calc-stack
))
1197 (setq calc-stack
(nthcdr n calc-stack
))))
1200 (defun calc-kbd-if ()
1203 (let ((cond (calc-top-n 1)))
1205 (if (math-is-true cond
)
1206 (if defining-kbd-macro
1207 (message "If true.."))
1208 (if defining-kbd-macro
1209 (message "Condition is false; skipping to Z: or Z] ..."))
1210 (calc-kbd-skip-to-else-if t
)))))
1212 (defun calc-kbd-else-if ()
1216 (defun calc-kbd-skip-to-else-if (else-okay)
1220 (setq ch
(read-char))
1222 (error "Unterminated Z[ in keyboard macro"))
1225 (setq ch
(read-char))
1227 (setq count
(1+ count
)))
1229 (setq count
(1- count
)))
1235 (keyboard-quit))))))
1236 (and defining-kbd-macro
1239 (message "End-if...")))))
1241 (defun calc-kbd-end-if ()
1243 (if defining-kbd-macro
1244 (message "End-if...")))
1246 (defun calc-kbd-else ()
1248 (if defining-kbd-macro
1249 (message "Else; skipping to Z] ..."))
1250 (calc-kbd-skip-to-else-if nil
))
1253 (defun calc-kbd-repeat ()
1257 (setq count
(math-trunc (calc-top-n 1)))
1258 (or (Math-integerp count
)
1259 (error "Count must be an integer"))
1260 (if (Math-integer-negp count
)
1262 (or (integerp count
)
1263 (setq count
1000000))
1265 (calc-kbd-loop count
)))
1267 (defun calc-kbd-for (dir)
1271 (setq init
(calc-top-n 2)
1272 final
(calc-top-n 1))
1273 (or (and (math-anglep init
) (math-anglep final
))
1274 (error "Initial and final values must be real numbers"))
1276 (calc-kbd-loop nil init final
(and dir
(prefix-numeric-value dir
)))))
1278 (defun calc-kbd-loop (rpt-count &optional initial final dir
)
1280 (setq rpt-count
(if rpt-count
(prefix-numeric-value rpt-count
) 1000000))
1284 (open last-command-char
)
1287 (or executing-kbd-macro
1288 (message "Reading loop body..."))
1290 (setq ch
(read-char))
1292 (error "Unterminated Z%c in keyboard macro" open
))
1295 (setq ch
(read-char)
1296 body
(concat body
"Z" (char-to-string ch
)))
1297 (cond ((memq ch
'(?\
< ?\
( ?\
{))
1298 (setq count
(1+ count
)))
1299 ((memq ch
'(?\
> ?\
) ?\
}))
1300 (setq count
(1- count
)))
1303 (setq parts
(nconc parts
(list (concat (substring body
0 -
2)
1308 (setq body
(concat body
(char-to-string ch
)))))
1309 (if (/= ch
(cdr (assq open
'( (?\
< . ?\
>) (?\
( . ?\
)) (?\
{ . ?\
}) ))))
1310 (error "Mismatched Z%c and Z%c in keyboard macro" open ch
))
1311 (or executing-kbd-macro
1312 (message "Looping..."))
1313 (setq body
(concat (substring body
0 -
2) "Z]"))
1314 (and (not executing-kbd-macro
)
1315 (= rpt-count
1000000)
1319 (message "Warning: Infinite loop! Not executing")
1320 (setq rpt-count
0)))
1321 (or (not initial
) dir
1322 (setq dir
(math-compare final initial
)))
1324 (while (> rpt-count
0)
1327 (if (cond ((eq dir
0) (Math-equal final counter
))
1328 ((eq dir
1) (Math-lessp final counter
))
1329 ((eq dir -
1) (Math-lessp counter final
)))
1331 (calc-push counter
)))
1332 (while (and part
(> rpt-count
0))
1333 (execute-kbd-macro (car part
))
1334 (if (math-is-true (calc-top-n 1))
1336 (setq part
(cdr part
)))
1340 (execute-kbd-macro body
)
1342 (let ((step (calc-top-n 1)))
1344 (setq counter
(calcFunc-add counter step
)))
1345 (setq rpt-count
(1- rpt-count
))))))))
1346 (or executing-kbd-macro
1347 (message "Looping...done"))))
1349 (defun calc-kbd-end-repeat ()
1351 (error "Unbalanced Z> in keyboard macro"))
1353 (defun calc-kbd-end-for ()
1355 (error "Unbalanced Z) in keyboard macro"))
1357 (defun calc-kbd-end-loop ()
1359 (error "Unbalanced Z} in keyboard macro"))
1361 (defun calc-kbd-break ()
1364 (let ((cond (calc-top-n 1)))
1366 (if (math-is-true cond
)
1367 (error "Keyboard macro aborted")))))
1370 (defvar calc-kbd-push-level
0)
1372 ;; The variables var-q0 through var-q9 are the "quick" variables.
1384 (defun calc-kbd-push (arg)
1387 (let* ((defs (and arg
(> (prefix-numeric-value arg
) 0)))
1398 (calc-internal-prec (if defs
12 calc-internal-prec
))
1399 (calc-word-size (if defs
32 calc-word-size
))
1400 (calc-angle-mode (if defs
'deg calc-angle-mode
))
1401 (calc-simplify-mode (if defs nil calc-simplify-mode
))
1402 (calc-algebraic-mode (if arg nil calc-algebraic-mode
))
1403 (calc-incomplete-algebraic-mode (if arg nil
1404 calc-incomplete-algebraic-mode
))
1405 (calc-symbolic-mode (if defs nil calc-symbolic-mode
))
1406 (calc-matrix-mode (if defs nil calc-matrix-mode
))
1407 (calc-prefer-frac (if defs nil calc-prefer-frac
))
1408 (calc-complex-mode (if defs nil calc-complex-mode
))
1409 (calc-infinite-mode (if defs nil calc-infinite-mode
))
1413 (if (or executing-kbd-macro defining-kbd-macro
)
1415 (if defining-kbd-macro
1416 (message "Reading body..."))
1418 (setq ch
(read-char))
1420 (error "Unterminated Z` in keyboard macro"))
1423 (setq ch
(read-char)
1424 body
(concat body
"Z" (char-to-string ch
)))
1426 (setq count
(1+ count
)))
1428 (setq count
(1- count
)))
1431 (setq body
(concat body
(char-to-string ch
)))))
1432 (if defining-kbd-macro
1433 (message "Reading body...done"))
1434 (let ((calc-kbd-push-level 0))
1435 (execute-kbd-macro (substring body
0 -
2))))
1436 (let ((calc-kbd-push-level (1+ calc-kbd-push-level
)))
1437 (message "Saving modes; type Z' to restore")
1438 (recursive-edit))))))
1440 (defun calc-kbd-pop ()
1442 (if (> calc-kbd-push-level
0)
1444 (message "Mode settings restored")
1445 (exit-recursive-edit))
1446 (error "Unbalanced Z' in keyboard macro")))
1449 ;; (defun calc-kbd-report (msg)
1450 ;; (interactive "sMessage: ")
1452 ;; (math-working msg (calc-top-n 1))))
1454 (defun calc-kbd-query ()
1456 (let ((defining-kbd-macro nil
)
1457 (executing-kbd-macro nil
)
1459 (if (not (eq (car-safe msg
) 'vec
))
1460 (error "No prompt string provided")
1461 (setq msg
(math-vector-to-string msg
))
1464 (calc-alg-entry nil
(and (not (equal msg
"")) msg
))))))
1466 ;;;; Logical operations.
1468 (defun calcFunc-eq (a b
&rest more
)
1470 (let* ((args (cons a
(cons b
(copy-sequence more
))))
1474 (while (and (cdr p
) (not (eq res
0)))
1476 (while (and (setq p2
(cdr p2
)) (not (eq res
0)))
1477 (setq res
(math-two-eq (car p
) (car p2
)))
1479 (setcdr p
(delq (car p2
) (cdr p
)))))
1484 (cons 'calcFunc-eq args
)
1486 (or (math-two-eq a b
)
1487 (if (and (or (math-looks-negp a
) (math-zerop a
))
1488 (or (math-looks-negp b
) (math-zerop b
)))
1489 (list 'calcFunc-eq
(math-neg a
) (math-neg b
))
1490 (list 'calcFunc-eq a b
)))))
1492 (defun calcFunc-neq (a b
&rest more
)
1494 (let* ((args (cons a
(cons b more
)))
1499 (while (and (cdr p
) (not (eq res
1)))
1501 (while (and (setq p2
(cdr p2
)) (not (eq res
1)))
1502 (setq res
(math-two-eq (car p
) (car p2
)))
1503 (or res
(setq all nil
)))
1509 (cons 'calcFunc-neq args
))))
1510 (or (cdr (assq (math-two-eq a b
) '((0 .
1) (1 .
0))))
1511 (if (and (or (math-looks-negp a
) (math-zerop a
))
1512 (or (math-looks-negp b
) (math-zerop b
)))
1513 (list 'calcFunc-neq
(math-neg a
) (math-neg b
))
1514 (list 'calcFunc-neq a b
)))))
1516 (defun math-two-eq (a b
)
1517 (if (eq (car-safe a
) 'vec
)
1518 (if (eq (car-safe b
) 'vec
)
1519 (if (= (length a
) (length b
))
1521 (while (and (setq a
(cdr a
) b
(cdr b
)) (not (eq res
0)))
1523 (setq res
(math-two-eq (car a
) (car b
)))
1524 (if (eq (math-two-eq (car a
) (car b
)) 0)
1528 (if (Math-objectp b
)
1531 (if (eq (car-safe b
) 'vec
)
1532 (if (Math-objectp a
)
1535 (let ((res (math-compare a b
)))
1538 (if (and (= res
2) (not (and (Math-scalarp a
) (Math-scalarp b
))))
1542 (defun calcFunc-lt (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-gt
(math-neg a
) (math-neg b
))
1550 (list 'calcFunc-lt a b
))
1553 (defun calcFunc-gt (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-lt
(math-neg a
) (math-neg b
))
1561 (list 'calcFunc-gt a b
))
1564 (defun calcFunc-leq (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-geq
(math-neg a
) (math-neg b
))
1572 (list 'calcFunc-leq a b
))
1575 (defun calcFunc-geq (a b
)
1576 (let ((res (math-compare a b
)))
1580 (if (and (or (math-looks-negp a
) (math-zerop a
))
1581 (or (math-looks-negp b
) (math-zerop b
)))
1582 (list 'calcFunc-leq
(math-neg a
) (math-neg b
))
1583 (list 'calcFunc-geq a b
))
1586 (defun calcFunc-rmeq (a)
1587 (if (math-vectorp a
)
1588 (math-map-vec 'calcFunc-rmeq a
)
1589 (if (assq (car-safe a
) calc-tweak-eqn-table
)
1590 (if (and (eq (car-safe (nth 2 a
)) 'var
)
1591 (math-objectp (nth 1 a
)))
1594 (if (eq (car-safe a
) 'calcFunc-assign
)
1596 (if (eq (car-safe a
) 'calcFunc-evalto
)
1598 (list 'calcFunc-rmeq a
))))))
1600 (defun calcFunc-land (a b
)
1601 (cond ((Math-zerop a
)
1609 (t (list 'calcFunc-land a b
))))
1611 (defun calcFunc-lor (a b
)
1612 (cond ((Math-zerop a
)
1620 (t (list 'calcFunc-lor a b
))))
1622 (defun calcFunc-lnot (a)
1625 (if (math-is-true a
)
1627 (let ((op (and (= (length a
) 3)
1628 (assq (car a
) calc-tweak-eqn-table
))))
1630 (cons (nth 2 op
) (cdr a
))
1631 (list 'calcFunc-lnot a
))))))
1633 (defun calcFunc-if (c e1 e2
)
1636 (if (and (math-is-true c
) (not (Math-vectorp c
)))
1638 (or (and (Math-vectorp c
)
1640 (let ((ee1 (if (Math-vectorp e1
)
1641 (if (= (length c
) (length e1
))
1643 (calc-record-why "*Dimension error" e1
))
1645 (ee2 (if (Math-vectorp e2
)
1646 (if (= (length c
) (length e2
))
1648 (calc-record-why "*Dimension error" e2
))
1651 (cons 'vec
(math-if-vector (cdr c
) ee1 ee2
)))))
1652 (list 'calcFunc-if c e1 e2
)))))
1654 (defun math-if-vector (c e1 e2
)
1656 (cons (if (Math-zerop (car c
)) (car e2
) (car e1
))
1657 (math-if-vector (cdr c
)
1659 (or (cdr e2
) e2
)))))
1661 (defun math-normalize-logical-op (a)
1662 (or (and (eq (car a
) 'calcFunc-if
)
1664 (let ((a1 (math-normalize (nth 1 a
))))
1666 (math-normalize (nth 3 a
))
1667 (if (Math-numberp a1
)
1668 (math-normalize (nth 2 a
))
1669 (if (and (Math-vectorp (nth 1 a
))
1670 (math-constp (nth 1 a
)))
1671 (calcFunc-if (nth 1 a
)
1672 (math-normalize (nth 2 a
))
1673 (math-normalize (nth 3 a
)))
1674 (let ((calc-simplify-mode 'none
))
1675 (list 'calcFunc-if a1
1676 (math-normalize (nth 2 a
))
1677 (math-normalize (nth 3 a
)))))))))
1680 (defun calcFunc-in (a b
)
1681 (or (and (eq (car-safe b
) 'vec
)
1683 (while (and (setq bb
(cdr bb
))
1684 (not (if (memq (car-safe (car bb
)) '(vec intv
))
1685 (eq (calcFunc-in a
(car bb
)) 1)
1686 (Math-equal a
(car bb
))))))
1687 (if bb
1 (and (math-constp a
) (math-constp bb
) 0))))
1688 (and (eq (car-safe b
) 'intv
)
1689 (let ((res (math-compare a
(nth 2 b
))) res2
)
1693 (or (/= (nth 1 b
) 2)
1694 (Math-lessp (nth 2 b
) (nth 3 b
))))
1695 (if (memq (nth 1 b
) '(2 3)) 1 0))
1696 ((= (setq res2
(math-compare a
(nth 3 b
))) 1)
1699 (or (/= (nth 1 b
) 1)
1700 (Math-lessp (nth 2 b
) (nth 3 b
))))
1701 (if (memq (nth 1 b
) '(1 3)) 1 0))
1707 (and (Math-equal a b
)
1709 (and (math-constp a
) (math-constp b
)
1711 (list 'calcFunc-in a b
)))
1713 (defun calcFunc-typeof (a)
1714 (cond ((Math-integerp a
) 1)
1715 ((eq (car a
) 'frac
) 2)
1716 ((eq (car a
) 'float
) 3)
1717 ((eq (car a
) 'hms
) 4)
1718 ((eq (car a
) 'cplx
) 5)
1719 ((eq (car a
) 'polar
) 6)
1720 ((eq (car a
) 'sdev
) 7)
1721 ((eq (car a
) 'intv
) 8)
1722 ((eq (car a
) 'mod
) 9)
1723 ((eq (car a
) 'date
) (if (Math-integerp (nth 1 a
)) 10 11))
1725 (if (memq (nth 2 a
) '(var-inf var-uinf var-nan
)) 12 100))
1726 ((eq (car a
) 'vec
) (if (math-matrixp a
) 102 101))
1727 (t (math-calcFunc-to-var (car a
)))))
1729 (defun calcFunc-integer (a)
1730 (if (Math-integerp a
)
1732 (if (Math-objvecp a
)
1734 (list 'calcFunc-integer a
))))
1736 (defun calcFunc-real (a)
1739 (if (Math-objvecp a
)
1741 (list 'calcFunc-real a
))))
1743 (defun calcFunc-constant (a)
1746 (if (Math-objvecp a
)
1748 (list 'calcFunc-constant a
))))
1750 (defun calcFunc-refers (a b
)
1751 (if (math-expr-contains a b
)
1753 (if (eq (car-safe a
) 'var
)
1754 (list 'calcFunc-refers a b
)
1757 (defun calcFunc-negative (a)
1758 (if (math-looks-negp a
)
1760 (if (or (math-zerop a
)
1763 (list 'calcFunc-negative a
))))
1765 (defun calcFunc-variable (a)
1766 (if (eq (car-safe a
) 'var
)
1768 (if (Math-objvecp a
)
1770 (list 'calcFunc-variable a
))))
1772 (defun calcFunc-nonvar (a)
1773 (if (eq (car-safe a
) 'var
)
1774 (list 'calcFunc-nonvar a
)
1777 (defun calcFunc-istrue (a)
1778 (if (math-is-true a
)
1784 ;;;; User-programmability.
1786 ;;; Compiling Lisp-like forms to use the math library.
1788 (defun math-do-defmath (func args body
)
1789 (require 'calc-macs
)
1790 (let* ((fname (intern (concat "calcFunc-" (symbol-name func
))))
1791 (doc (if (stringp (car body
)) (list (car body
))))
1792 (clargs (mapcar 'math-clean-arg args
))
1793 (body (math-define-function-body
1794 (if (stringp (car body
)) (cdr body
) body
)
1797 (if (and (consp (car body
))
1798 (eq (car (car body
)) 'interactive
))
1799 (let ((inter (car body
)))
1800 (setq body
(cdr body
))
1801 (if (or (> (length inter
) 2)
1802 (integerp (nth 1 inter
)))
1803 (let ((hasprefix nil
) (hasmulti nil
))
1804 (if (stringp (nth 1 inter
))
1806 (cond ((equal (nth 1 inter
) "p")
1808 ((equal (nth 1 inter
) "m")
1811 "Can't handle interactive code string \"%s\""
1813 (setq inter
(cdr inter
))))
1814 (if (not (integerp (nth 1 inter
)))
1816 "Expected an integer in interactive specification"))
1817 (append (list 'defun
1818 (intern (concat "calc-"
1819 (symbol-name func
)))
1820 (if (or hasprefix hasmulti
)
1824 (if (or hasprefix hasmulti
)
1825 '((interactive "P"))
1829 '(calc-slow-wrapper)
1836 (list 'prefix-numeric-value
1840 (list 'calc-enter-result
1841 (if hasmulti
'n
(nth 1 inter
))
1845 (list 'quote
(list fname
))
1846 (list 'calc-top-list-n
1855 'prefix-numeric-value
1859 (list 'calc-top-list-n
1862 (nth 1 inter
)))))))))))
1863 (append (list 'defun
1864 (intern (concat "calc-" (symbol-name func
)))
1869 (cons 'calc-wrapper body
))))))
1870 (append (list 'defun
fname clargs
)
1872 (math-do-arg-list-check args nil nil
)
1875 (defun math-clean-arg (arg)
1877 (math-clean-arg (nth 1 arg
))
1880 (defun math-do-arg-check (arg var is-opt is-rest
)
1882 (let ((chk (math-do-arg-check arg var nil nil
)))
1886 (setq chk
(list (cons 'progn chk
)))
1889 (let* ((rest (math-do-arg-check (nth 1 arg
) var is-opt is-rest
))
1891 (qqual (list 'quote qual
))
1892 (qual-name (symbol-name qual
))
1893 (chk (intern (concat "math-check-" qual-name
))))
1899 (list 'mapcar
(list 'quote chk
) var
))
1900 (list 'setq var
(list chk var
)))))
1901 (if (fboundp (setq chk
(intern (concat "math-" qual-name
))))
1910 (list 'math-reject-arg
1915 (list 'math-reject-arg var qqual
)))))
1916 (if (and (string-match "\\`not-\\(.*\\)\\'" qual-name
)
1917 (fboundp (setq chk
(intern
1919 (math-match-substring
1929 (list 'math-reject-arg
1934 (list 'math-reject-arg var qqual
)))))
1935 (error "Unknown qualifier `%s'" qual-name
))))))))
1937 (defun math-do-arg-list-check (args is-opt is-rest
)
1938 (cond ((null args
) nil
)
1940 (append (math-do-arg-check (car args
)
1941 (math-clean-arg (car args
))
1943 (math-do-arg-list-check (cdr args
) is-opt is-rest
)))
1944 ((eq (car args
) '&optional
)
1945 (math-do-arg-list-check (cdr args
) t nil
))
1946 ((eq (car args
) '&rest
)
1947 (math-do-arg-list-check (cdr args
) nil t
))
1948 (t (math-do-arg-list-check (cdr args
) is-opt is-rest
))))
1950 (defconst math-prim-funcs
1951 '( (~
= . math-nearly-equal
)
1953 (lsh . calcFunc-lsh
)
1954 (ash . calcFunc-ash
)
1955 (logand . calcFunc-and
)
1956 (logandc2 . calcFunc-diff
)
1957 (logior . calcFunc-or
)
1958 (logxor . calcFunc-xor
)
1959 (lognot . calcFunc-not
)
1960 (equal . equal
) ; need to leave these ones alone!
1969 (defconst math-prim-vars
1972 (&optional .
&optional
)
1976 (defun math-define-function-body (body env
)
1977 (let ((body (math-define-body body env
)))
1978 (if (math-body-refers-to body
'math-return
)
1979 (list (cons 'catch
(cons '(quote math-return
) body
)))
1982 ;; The variable math-exp-env is local to math-define-body, but is
1983 ;; used by math-define-exp, which is called (indirectly) by
1984 ;; by math-define-body.
1985 (defvar math-exp-env
)
1987 (defun math-define-body (body math-exp-env
)
1988 (math-define-list body
))
1990 (defun math-define-list (body &optional quote
)
1993 ((and (eq (car body
) ':)
1994 (stringp (nth 1 body
)))
1995 (cons (let* ((math-read-expr-quotes t
)
1996 (exp (math-read-plain-expr (nth 1 body
) t
)))
1997 (math-define-exp exp
))
1998 (math-define-list (cdr (cdr body
)))))
2000 (cons (cond ((consp (car body
))
2001 (math-define-list (cdr body
) t
))
2004 (math-define-list (cdr body
))))
2006 (cons (math-define-exp (car body
))
2007 (math-define-list (cdr body
))))))
2009 (defun math-define-exp (exp)
2011 (let ((func (car exp
)))
2012 (cond ((memq func
'(quote function
))
2013 (if (and (consp (nth 1 exp
))
2014 (eq (car (nth 1 exp
)) 'lambda
))
2016 (math-define-lambda (nth 1 exp
) math-exp-env
))
2018 ((memq func
'(let let
* for foreach
))
2019 (let ((head (nth 1 exp
))
2020 (body (cdr (cdr exp
))))
2021 (if (memq func
'(let let
*))
2023 (setq func
(cdr (assq func
'((for . math-for
)
2024 (foreach . math-foreach
)))))
2025 (if (not (listp (car head
)))
2026 (setq head
(list head
))))
2029 (cons (math-define-let head
)
2030 (math-define-body body
2032 (math-define-let-env head
)
2034 ((and (memq func
'(setq setf
))
2035 (math-complicated-lhs (cdr exp
)))
2036 (if (> (length exp
) 3)
2037 (cons 'progn
(math-define-setf-list (cdr exp
)))
2038 (math-define-setf (nth 1 exp
) (nth 2 exp
))))
2039 ((eq func
'condition-case
)
2042 (math-define-body (cdr (cdr exp
))
2047 (math-define-cond (cdr exp
))))
2048 ((and (consp func
) ; ('spam a b) == force use of plain spam
2049 (eq (car func
) 'quote
))
2050 (cons func
(math-define-list (cdr exp
))))
2052 (let ((args (math-define-list (cdr exp
)))
2053 (prim (assq func math-prim-funcs
)))
2055 (cons (cdr prim
) args
))
2057 (list 'eq
(car args
) '(quote float
)))
2059 (math-define-binop 'math-add
0
2060 (car args
) (cdr args
)))
2062 (if (= (length args
) 1)
2063 (cons 'math-neg args
)
2064 (math-define-binop 'math-sub
0
2065 (car args
) (cdr args
))))
2067 (math-define-binop 'math-mul
1
2068 (car args
) (cdr args
)))
2070 (math-define-binop 'math-div
1
2071 (car args
) (cdr args
)))
2073 (math-define-binop 'math-min
0
2074 (car args
) (cdr args
)))
2076 (math-define-binop 'math-max
0
2077 (car args
) (cdr args
)))
2079 (if (and (math-numberp (nth 1 args
))
2080 (math-zerop (nth 1 args
)))
2081 (list 'math-negp
(car args
))
2082 (cons 'math-lessp args
)))
2084 (if (and (math-numberp (nth 1 args
))
2085 (math-zerop (nth 1 args
)))
2086 (list 'math-posp
(car args
))
2087 (list 'math-lessp
(nth 1 args
) (nth 0 args
))))
2090 (if (and (math-numberp (nth 1 args
))
2091 (math-zerop (nth 1 args
)))
2092 (list 'math-posp
(car args
))
2094 (nth 1 args
) (nth 0 args
)))))
2097 (if (and (math-numberp (nth 1 args
))
2098 (math-zerop (nth 1 args
)))
2099 (list 'math-negp
(car args
))
2100 (cons 'math-lessp args
))))
2102 (if (and (math-numberp (nth 1 args
))
2103 (math-zerop (nth 1 args
)))
2104 (list 'math-zerop
(nth 0 args
))
2105 (if (and (integerp (nth 1 args
))
2106 (/= (%
(nth 1 args
) 10) 0))
2107 (cons 'math-equal-int args
)
2108 (cons 'math-equal args
))))
2111 (if (and (math-numberp (nth 1 args
))
2112 (math-zerop (nth 1 args
)))
2113 (list 'math-zerop
(nth 0 args
))
2114 (if (and (integerp (nth 1 args
))
2115 (/= (%
(nth 1 args
) 10) 0))
2116 (cons 'math-equal-int args
)
2117 (cons 'math-equal args
)))))
2119 (list 'math-add
(car args
) 1))
2121 (list 'math-add
(car args
) -
1))
2122 ((eq func
'not
) ; optimize (not (not x)) => x
2123 (if (eq (car-safe args
) func
)
2126 ((and (eq func
'elt
) (cdr (cdr args
)))
2127 (math-define-elt (car args
) (cdr args
)))
2130 (let* ((name (symbol-name func
))
2131 (cfunc (intern (concat "calcFunc-" name
)))
2132 (mfunc (intern (concat "math-" name
))))
2133 (cond ((fboundp cfunc
)
2138 (string-match "\\`calcFunc-.*" name
))
2141 (cons cfunc args
)))))))))
2142 (t (cons func
(math-define-list (cdr exp
))))))) ;;args
2144 (let ((prim (assq exp math-prim-vars
))
2145 (name (symbol-name exp
)))
2148 ((memq exp math-exp-env
)
2150 ((string-match "-" name
)
2153 (intern (concat "var-" name
))))))
2155 (if (or (<= exp -
1000000) (>= exp
1000000))
2156 (list 'quote
(math-normalize exp
))
2160 (defun math-define-cond (forms)
2162 (cons (math-define-list (car forms
))
2163 (math-define-cond (cdr forms
)))))
2165 (defun math-complicated-lhs (body)
2167 (or (not (symbolp (car body
)))
2168 (math-complicated-lhs (cdr (cdr body
))))))
2170 (defun math-define-setf-list (body)
2172 (cons (math-define-setf (nth 0 body
) (nth 1 body
))
2173 (math-define-setf-list (cdr (cdr body
))))))
2175 (defun math-define-setf (place value
)
2176 (setq place
(math-define-exp place
)
2177 value
(math-define-exp value
))
2178 (cond ((symbolp place
)
2179 (list 'setq place value
))
2180 ((eq (car-safe place
) 'nth
)
2181 (list 'setcar
(list 'nthcdr
(nth 1 place
) (nth 2 place
)) value
))
2182 ((eq (car-safe place
) 'elt
)
2183 (list 'setcar
(list 'nthcdr
(nth 2 place
) (nth 1 place
)) value
))
2184 ((eq (car-safe place
) 'car
)
2185 (list 'setcar
(nth 1 place
) value
))
2186 ((eq (car-safe place
) 'cdr
)
2187 (list 'setcdr
(nth 1 place
) value
))
2189 (error "Bad place form for setf: %s" place
))))
2191 (defun math-define-binop (op ident arg1 rest
)
2193 (math-define-binop op ident
2194 (list op arg1
(car rest
))
2198 (defun math-define-let (vlist)
2200 (cons (if (consp (car vlist
))
2201 (cons (car (car vlist
))
2202 (math-define-list (cdr (car vlist
))))
2204 (math-define-let (cdr vlist
)))))
2206 (defun math-define-let-env (vlist)
2208 (cons (if (consp (car vlist
))
2211 (math-define-let-env (cdr vlist
)))))
2213 (defun math-define-lambda (exp exp-env
)
2214 (nconc (list (nth 0 exp
) ; 'lambda
2215 (nth 1 exp
)) ; arg list
2216 (math-define-function-body (cdr (cdr exp
))
2217 (append (nth 1 exp
) exp-env
))))
2219 (defun math-define-elt (seq idx
)
2221 (math-define-elt (list 'elt seq
(car idx
)) (cdr idx
))
2226 ;;; Useful programming macros.
2228 (defmacro math-while
(head &rest body
)
2229 (let ((body (cons 'while
(cons head body
))))
2230 (if (math-body-refers-to body
'math-break
)
2231 (cons 'catch
(cons '(quote math-break
) (list body
)))
2233 ;; (put 'math-while 'lisp-indent-hook 1)
2235 (defmacro math-for
(head &rest body
)
2236 (let ((body (if head
2237 (math-handle-for head body
)
2238 (cons 'while
(cons t body
)))))
2239 (if (math-body-refers-to body
'math-break
)
2240 (cons 'catch
(cons '(quote math-break
) (list body
)))
2242 ;; (put 'math-for 'lisp-indent-hook 1)
2244 (defun math-handle-for (head body
)
2245 (let* ((var (nth 0 (car head
)))
2246 (init (nth 1 (car head
)))
2247 (limit (nth 2 (car head
)))
2248 (step (or (nth 3 (car head
)) 1))
2249 (body (if (cdr head
)
2250 (list (math-handle-for (cdr head
) body
))
2252 (all-ints (and (integerp init
) (integerp limit
) (integerp step
)))
2253 (const-limit (or (integerp limit
)
2254 (and (eq (car-safe limit
) 'quote
)
2255 (math-realp (nth 1 limit
)))))
2256 (const-step (or (integerp step
)
2257 (and (eq (car-safe step
) 'quote
)
2258 (math-realp (nth 1 step
)))))
2259 (save-limit (if const-limit limit
(make-symbol "<limit>")))
2260 (save-step (if const-step step
(make-symbol "<step>"))))
2262 (cons (append (if const-limit nil
(list (list save-limit limit
)))
2263 (if const-step nil
(list (list save-step step
)))
2264 (list (list var init
)))
2269 (list '<= var save-limit
)
2270 (list '>= var save-limit
))
2273 (if (or (math-posp step
)
2298 save-step
)))))))))))
2300 (defmacro math-foreach
(head &rest body
)
2301 (let ((body (math-handle-foreach head body
)))
2302 (if (math-body-refers-to body
'math-break
)
2303 (cons 'catch
(cons '(quote math-break
) (list body
)))
2305 ;; (put 'math-foreach 'lisp-indent-hook 1)
2307 (defun math-handle-foreach (head body
)
2308 (let ((var (nth 0 (car head
)))
2309 (data (nth 1 (car head
)))
2310 (body (if (cdr head
)
2311 (list (math-handle-foreach (cdr head
) body
))
2314 (cons (list (list var data
))
2321 (list 'cdr var
)))))))))))
2324 (defun math-body-refers-to (body thing
)
2325 (or (equal body thing
)
2327 (or (math-body-refers-to (car body
) thing
)
2328 (math-body-refers-to (cdr body
) thing
)))))
2330 (defun math-break (&optional value
)
2331 (throw 'math-break value
))
2333 (defun math-return (&optional value
)
2334 (throw 'math-return value
))
2340 (defun math-composite-inequalities (x op
)
2341 (if (memq (nth 1 op
) '(calcFunc-eq calcFunc-neq
))
2342 (if (eq (car x
) (nth 1 op
))
2343 (append x
(list (math-read-expr-level (nth 3 op
))))
2344 (throw 'syntax
"Syntax error"))
2347 (if (memq (nth 1 op
) '(calcFunc-lt calcFunc-leq
))
2348 (if (memq (car x
) '(calcFunc-lt calcFunc-leq
))
2350 (+ (if (eq (car x
) 'calcFunc-leq
) 2 0)
2351 (if (eq (nth 1 op
) 'calcFunc-leq
) 1 0))
2352 (nth 1 x
) (math-read-expr-level (nth 3 op
)))
2353 (throw 'syntax
"Syntax error"))
2354 (if (memq (car x
) '(calcFunc-gt calcFunc-geq
))
2356 (+ (if (eq (nth 1 op
) 'calcFunc-geq
) 2 0)
2357 (if (eq (car x
) 'calcFunc-geq
) 1 0))
2358 (math-read-expr-level (nth 3 op
)) (nth 1 x
))
2359 (throw 'syntax
"Syntax error"))))))
2361 (provide 'calc-prog
)
2363 ;;; arch-tag: 4c5a183b-c9e5-4632-bb3f-e41a764518b0
2364 ;;; calc-prog.el ends here